From: Adam Sieradzan Date: Tue, 15 Apr 2014 12:07:19 +0000 (+0200) Subject: Added source/wham/src-NEWSC-NEWCORR/ X-Git-Url: http://mmka.chem.univ.gda.pl/gitweb/?p=unres.git;a=commitdiff_plain;h=ba3ea24615556f941a400995233bfa4d81201e7c Added source/wham/src-NEWSC-NEWCORR/ --- diff --git a/bin/wham/wham_ifort_MPICH_MM-KN-NEWC.exe b/bin/wham/wham_ifort_MPICH_MM-KN-NEWC.exe new file mode 100755 index 0000000..caee6c7 Binary files /dev/null and b/bin/wham/wham_ifort_MPICH_MM-KN-NEWC.exe differ diff --git a/bin/wham/wham_ifort_MPICH_MM-PH-NEWC.exe b/bin/wham/wham_ifort_MPICH_MM-PH-NEWC.exe new file mode 100755 index 0000000..0e46a37 Binary files /dev/null and b/bin/wham/wham_ifort_MPICH_MM-PH-NEWC.exe differ diff --git a/source/wham/src-NEWSC-NEWCORR/CMakeLists.txt b/source/wham/src-NEWSC-NEWCORR/CMakeLists.txt new file mode 100644 index 0000000..aca8eb4 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/CMakeLists.txt @@ -0,0 +1,298 @@ +# +# CMake project file for WHAM single chain version +# + +enable_language (Fortran) + +#================================ +# Set source file lists +#================================ +set(UNRES_WHAM_SRC0 + wham_multparm.F + bxread.F + xread.F + cxread.F + enecalc1.F + energy_p_new.F + initialize_p.F + molread_zs.F + openunits.F + readrtns.F + arcos.f + cartder.f + cartprint.f + chainbuild.f + geomout.F + gnmr1.f + icant.f + intcor.f + int_from_cart.f + make_ensemble1.F + matmult.f + misc.f + mygetenv.F + parmread.F + pinorm.f + printmat.f + rescode.f + setup_var.f + slices.F + store_parm.F + timing.F + wham_calc1.F + readrtns_compar.F + readpdb.f + fitsq.f + contact.f + elecont.f + contfunc.f + cont_frag.f + conf_compar.F + match_contact.f + angnorm.f + odlodc.f + promienie.f + qwolynes.f + read_ref_str.F + rmscalc.f + secondary.f + proc_cont.f + define_pairs.f + mysort.f +) + +set(UNRES_WHAM_PP_SRC + bxread.F + chainbuild.F + conf_compar.F + cxread.F + enecalc1.F + energy_p_new.F + geomout.F + initialize_p.F + make_ensemble1.F + molread_zs.F + mygetenv.F + openunits.F + parmread.F + read_ref_str.F + readrtns_compar.F + readrtns.F + slices.F + store_parm.F + timing.F + wham_calc1.F + wham_multparm.F + xread.F + proc_proc.c +) + + +#================================================ +# Set comipiler flags for different sourcefiles +#================================================ +if (Fortran_COMPILER_NAME STREQUAL "ifort") + set(FFLAGS0 "-mcmodel=medium -g -CB -I. -I${CMAKE_CURRENT_SOURCE_DIR}/include_unres" ) +elseif (Fortran_COMPILER_NAME STREQUAL "gfortran") + set(FFLAGS0 "-std=legacy -g -I. -I${CMAKE_CURRENT_SOURCE_DIR}/include_unres" ) +endif (Fortran_COMPILER_NAME STREQUAL "ifort") + + +#========================================= +# Add MPI compiler flags +#========================================= +if(UNRES_WITH_MPI) + set(FFLAGS0 "${FFLAGS0} -I${MPIF_INCLUDE_DIRECTORIES}") +endif(UNRES_WITH_MPI) + +set_property(SOURCE ${UNRES_WHAM_SRC0} PROPERTY COMPILE_FLAGS ${FFLAGS0} ) + +#========================================= +# WHAM preprocesor flags +#========================================= + +set(CPPFLAGS "PROCOR -DUNRES -DISNAN -DSPLITELE -DCRYST_BOND -DCRYST_THETA -DCRYST_SC" ) + +#========================================= +# System specific flags +#========================================= +if(${CMAKE_SYSTEM_NAME} MATCHES "Linux") + set(CPPFLAGS "${CPPFLAGS} -DLINUX") +endif(${CMAKE_SYSTEM_NAME} MATCHES "Linux") + +#========================================= +# Compiler specific flags +#========================================= + +if (Fortran_COMPILER_NAME STREQUAL "ifort") + # Add ifort preprocessor flags + set(CPPFLAGS "${CPPFLAGS} -DPGI") +elseif (Fortran_COMPILER_NAME STREQUAL "f95") + # Add new gfortran flags + set(CPPFLAGS "${CPPFLAGS} -DG77") +elseif (Fortran_COMPILER_NAME STREQUAL "gfortran") + # Add old gfortran flags + set(CPPFLAGS "${CPPFLAGS} -DG77") +endif (Fortran_COMPILER_NAME STREQUAL "ifort") + +#========================================= +# Add MPI preprocessor flags +#========================================= +set(CPPFLAGS "${CPPFLAGS} -DMPI") + +#========================================= +# Add 64-bit specific preprocessor flags +#========================================= +if (architektura STREQUAL "64") + set(CPPFLAGS "${CPPFLAGS} -DAMD64") +endif (architektura STREQUAL "64") + +#========================================= +# Apply preprocesor flags to *.F files +#========================================= +set_property(SOURCE ${UNRES_WHAM_PP_SRC} PROPERTY COMPILE_DEFINITIONS ${CPPFLAGS} ) + + +#======================================== +# Setting binary name +#======================================== +set(UNRES_WHAM_BIN "wham_${Fortran_COMPILER_NAME}.exe") + +#========================================= +# cinfo.f workaround for CMake +#========================================= +# get the current date +TODAY(DATE) +# generate cinfo.f + +set(CINFO "${CMAKE_CURRENT_BINARY_DIR}/cinfo.f") +FILE(WRITE ${CINFO} +"C CMake generated file + subroutine cinfo + include 'COMMON.IOUNITS' + write(iout,*)'++++ Compile info ++++' + write(iout,*)'Version ${UNRES_MAJOR}.${UNRES_MINOR} build ${UNRES_PATCH}' +") + +CINFO_FORMAT(${CINFO} "Compiled" "${DATE}" ) +CINFO_FORMAT(${CINFO} "Compiled by" "$ENV{USER}@$ENV{HOST}" ) +CINFO_FORMAT(${CINFO} "OS name:" "${CMAKE_SYSTEM_NAME}" ) +CINFO_FORMAT(${CINFO} "OS release:" "${CMAKE_SYSTEM}" ) +CINFO_FORMAT(${CINFO} "Fortran Compiler:" "${CMAKE_Fortran_COMPILER}" ) +CINFO_FORMAT(${CINFO} "MD Force field:" "${UNRES_MD_FF}" ) +CINFO_FORMAT(${CINFO} "CPPFLAGS =" "${CPPFLAGS}") + +FILE(APPEND ${CINFO} +" write(iout,*)'++++ End of compile info ++++' + return + end ") + +# set include path +set_property(SOURCE ${CMAKE_CURRENT_BINARY_DIR}/cinfo.f PROPERTY COMPILE_FLAGS "${FFLAGS0} -I${CMAKE_CURRENT_SOURCE_DIR}" ) + +#========================================= +# Set full unres CSA sources +#========================================= +set(UNRES_WHAM_SRCS ${UNRES_WHAM_SRC0} ${CMAKE_CURRENT_BINARY_DIR}/cinfo.f proc_proc.c) + +#========================================= +# Build the binary +#========================================= +add_executable(UNRES_WHAM_BIN ${UNRES_WHAM_SRCS} ) +set_target_properties(UNRES_WHAM_BIN PROPERTIES OUTPUT_NAME ${UNRES_WHAM_BIN}) + +#set_property(TARGET ${UNRES_BIN} PROPERTY RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/bin/unres/MD ) +#add_dependencies (${UNRES_BIN} ${UNRES_XDRFLIB}) + +#========================================= +# Link libraries +#========================================= +# link MPI library (libmpich.a) +target_link_libraries( UNRES_WHAM_BIN ${MPIF_LIBRARIES} ) +# link libxdrf.a +target_link_libraries( UNRES_WHAM_BIN xdrf ) + +#========================================= +# TESTS +#========================================= + +#-- Copy all the data files from the test directory into the source directory +#SET(UNRES_TEST_FILES +# ala10.inp +# ) + +#FOREACH (UNRES_TEST_FILE ${UNRES_TEST_FILES}) +# SET (unres_test_dest "${CMAKE_CURRENT_BINARY_DIR}/${UNRES_TEST_FILE}") +# MESSAGE (STATUS " Copying ${UNRES_TEST_FILE} from ${CMAKE_SOURCE_DIR}/examples/unres/MD/ff_gab/${UNRES_TEST_FILE} to ${unres_test_dest}") +# ADD_CUSTOM_COMMAND ( +# TARGET ${UNRES_BIN} +# POST_BUILD +# COMMAND ${CMAKE_COMMAND} -E copy ${CMAKE_SOURCE_DIR}/examples/unres/MD/ff_gab/${UNRES_TEST_FILE} ${unres_test_dest} +# ) +#ENDFOREACH (UNRES_TEST_FILE ${UNRES_TEST_FILES}) + +#========================================= +# Generate data test files +#========================================= +# test_single_ala.sh +#========================================= + +#FILE(WRITE ${CMAKE_CURRENT_BINARY_DIR}/test_single_ala.sh +#"#!/bin/sh +#export POT=GB +#export PREFIX=ala10 +#----------------------------------------------------------------------------- +#UNRES_BIN=./${UNRES_BIN} +#----------------------------------------------------------------------------- +#DD=${CMAKE_SOURCE_DIR}/PARAM +#export BONDPAR=$DD/bond.parm +#export THETPAR=$DD/thetaml.5parm +#export ROTPAR=$DD/scgauss.parm +#export TORPAR=$DD/torsion_631Gdp.parm +#export TORDPAR=$DD/torsion_double_631Gdp.parm +#export ELEPAR=$DD/electr_631Gdp.parm +#export SIDEPAR=$DD/sc_GB_opt.1gab_3S_qclass5no310-shan2-sc-16-10-8k +#export FOURIER=$DD/fourier_opt.parm.1igd_hc_iter3_3 +#export SCPPAR=$DD/scp.parm +#export SCCORPAR=$DD/rotcorr_AM1.parm +#export PATTERN=$DD/patterns.cart +#----------------------------------------------------------------------------- +#$UNRES_BIN +#") + +#========================================= +# ala10.inp +#========================================= + +#file(WRITE ${CMAKE_CURRENT_BINARY_DIR}/ala10.inp +#"ala10 unblocked +#SEED=-1111333 MD ONE_LETTER rescale_mode=2 PDBOUT +#nstep=15000 ntwe=100 ntwx=1000 dt=0.1 lang=0 tbf t_bath=300 damax=1.0 & +#reset_moment=1000 reset_vel=1000 MDPDB +#WLONG=1.35279 WSCP=1.59304 WELEC=0.71534 WBOND=1.00000 WANG=1.13873 & +#WSCLOC=0.16258 WTOR=1.98599 WTORD=1.57069 WCORRH=0.42887 WCORR5=0.00000 & +#WCORR6=0.00000 WEL_LOC=0.16036 WTURN3=1.68722 WTURN4=0.66230 WTURN6=0.00000 & +#WVDWPP=0.11371 WHPB=1.00000 & +#CUTOFF=7.00000 WCORR4=0.00000 +#12 +#XAAAAAAAAAAX +# 0 +# 0 +# 90.0000 90.0000 90.0000 90.000 90.000 90.000 90.000 90.000 +# 90.0000 90.0000 +# 180.0000 180.0000 180.0000 180.000 180.000 180.000 180.000 180.000 +# 180.0000 +# 110.0000 110.0000 110.0000 100.000 110.000 100.000 110.000 110.000 +# 110.0000 110.0000 +# -120.0000 -120.0000 -120.000 -120.000 -120.000 -120.000 -120.000 -120.000 +# -120.0000 -120.0000 +#") + + +# Add tests + +#if(NOT UNRES_WITH_MPI) + +# add_test(NAME UNRES_MD_Ala10 COMMAND sh ${CMAKE_CURRENT_BINARY_DIR}/test_single_ala.sh ) + +#endif(NOT UNRES_WITH_MPI) diff --git a/source/wham/src-NEWSC-NEWCORR/COMMON.ALLPARM b/source/wham/src-NEWSC-NEWCORR/COMMON.ALLPARM new file mode 100644 index 0000000..62d1e47 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/COMMON.ALLPARM @@ -0,0 +1,99 @@ + double precision ww_all(max_ene,max_parm), + & vbldp0_all(max_parm),akp_all(max_parm), + & vbldsc0_all(maxbondterm,ntyp,max_parm), + & aksc_all(maxbondterm,ntyp,max_parm), + & abond0_all(maxbondterm,ntyp,max_parm), + & a0thet_all(ntyp,max_parm),athet_all(2,ntyp,max_parm), + & bthet_all(2,ntyp,max_parm),polthet_all(0:3,ntyp,max_parm), + & gthet_all(3,ntyp,max_parm),theta0_all(ntyp,max_parm), + & sig0_all(ntyp,max_parm),sigc0_all(ntyp,max_parm), + & aa0thet_all(maxthetyp1,maxthetyp1,maxthetyp1,max_parm), + & aathet_all(maxtheterm,maxthetyp1,maxthetyp1,maxthetyp1,max_parm), + & bbthet_all(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1, + & maxthetyp1,max_parm), + & ccthet_all(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1, + & maxthetyp1,max_parm), + & ddthet_all(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1, + & maxthetyp1,max_parm), + & eethet_all(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1, + & maxthetyp1,max_parm), + & ffthet_all(maxdouble,maxdouble,maxtheterm3,maxthetyp1,maxthetyp1, + & maxthetyp1,max_parm), + & ggthet_all(maxdouble,maxdouble,maxtheterm3,maxthetyp1,maxthetyp1, + & maxthetyp1,max_parm), + & dsc_all(ntyp1,max_parm),bsc_all(maxlob,ntyp,max_parm), + & censc_all(3,maxlob,ntyp,max_parm), + & gaussc_all(3,3,maxlob,ntyp,max_parm),dsc0_all(ntyp1,max_parm), + & sc_parmin_all(65,ntyp,max_parm), + & v0_all(maxtor,maxtor,max_parm), + & v1_all(maxterm,maxtor,maxtor,max_parm), + & v2_all(maxterm,maxtor,maxtor,max_parm), + & vlor1_all(maxlor,maxtor,maxtor,max_parm), + & vlor2_all(maxlor,maxtor,maxtor,max_parm), + & vlor3_all(maxlor,maxtor,maxtor,max_parm), + & v1c_all(2,maxtermd_1,maxtor,maxtor,maxtor,max_parm), + & v1s_all(2,maxtermd_1,maxtor,maxtor,maxtor,max_parm), + & v2c_all(maxtermd_2,maxtermd_2,maxtor,maxtor,maxtor,max_parm), + & v2s_all(maxtermd_2,maxtermd_2,maxtor,maxtor,maxtor,max_parm), + & b1_all(2,maxtor,max_parm),b2_all(2,maxtor,max_parm), + & cc_all(2,2,maxtor,max_parm),dd_all(2,2,maxtor,max_parm), + & ee_all(2,2,maxtor,max_parm),ctilde_all(2,2,maxtor,max_parm), + & dtilde_all(2,2,maxtor,max_parm),b1tilde_all(2,maxtor,max_parm), + & app_all(2,2,max_parm),bpp_all(2,2,max_parm), + & ael6_all(2,2,max_parm),ael3_all(2,2,max_parm), + & aad_all(ntyp,2,max_parm),bad_all(ntyp,2,max_parm), + & aa_all(ntyp,ntyp,max_parm),bb_all(ntyp,ntyp,max_parm), + & augm_all(ntyp,ntyp,max_parm),eps_all(ntyp,ntyp,max_parm), + & sigma_all(ntyp,ntyp,max_parm),r0_all(ntyp,ntyp,max_parm), + & chi_all(ntyp,ntyp,max_parm),chip_all(ntyp,max_parm), + & chipp_all(ntyp,ntyp,max_parm),sigmap1_all(ntyp,ntyp,max_parm), + & sigmap2_all(ntyp,ntyp,max_parm),chis_all(ntyp,ntyp,max_parm), + & alphasur_all(4,ntyp,ntyp,max_parm), + & wstate_all(4,ntyp,ntyp,max_parm), + & nstate_all(ntyp,ntyp,max_parm), + & dhead_all(2,2,ntyp,ntyp,max_parm), + & dtail_all(2,ntyp,ntyp,max_parm), + & epshead_all(ntyp,ntyp,max_parm), + & rborn_all(ntyp,ntyp,max_parm), + & wqdip_all(2,ntyp,ntyp,max_parm),wquad_all(ntyp,ntyp,max_parm), + & alphapol_all(ntyp,ntyp,max_parm), + & alphiso_all(4,ntyp,ntyp,max_parm), + & sigiso1_all(ntyp,ntyp,max_parm), + & sigiso2_all(ntyp,ntyp,max_parm), + & epsintab_all(ntyp,ntyp,max_parm), + & alp_all(ntyp,max_parm),ebr_all(max_parm),d0cm_all(max_parm), + & akcm_all(max_parm),akth_all(max_parm),akct_all(max_parm), + & v1ss_all(max_parm),v2ss_all(max_parm),v3ss_all(max_parm), + & v1sccor_all(maxterm_sccor,3,ntyp,ntyp,max_parm), + & v2sccor_all(maxterm_sccor,3,ntyp,ntyp,max_parm) + integer nlob_all(ntyp1,max_parm),nlor_all(maxtor,maxtor,max_parm), + & nterm_all(maxtor,maxtor,max_parm), + & ntermd1_all(maxtor,maxtor,maxtor,max_parm), + & ntermd2_all(maxtor,maxtor,maxtor,max_parm), + & nbondterm_all(ntyp,max_parm),nthetyp_all(max_parm), + & ithetyp_all(ntyp1,max_parm),ntheterm_all(max_parm), + & ntheterm2_all(max_parm),ntheterm3_all(max_parm), + & nsingle_all(max_parm),ndouble_all(max_parm), + & nntheterm_all(max_parm),nterm_sccor_all(ntyp,ntyp,max_parm) + common /allparm/ ww_all,vbldp0_all,akp_all,vbldsc0_all,aksc_all, + & abond0_all,aa0thet_all,aathet_all,bbthet_all,ccthet_all, + & ddthet_all,eethet_all,ffthet_all,ggthet_all, + & a0thet_all,athet_all,bthet_all,polthet_all,gthet_all,theta0_all, + & sig0_all,sigc0_all,dsc_all,bsc_all,censc_all,gaussc_all,dsc0_all, + & sc_parmin_all, + & v0_all,v1_all,v2_all,vlor1_all,vlor2_all,vlor3_all,v1c_all, + & v1s_all,v2c_all,v2s_all,b1_all,b2_all,cc_all,dd_all,ee_all, + & ctilde_all,dtilde_all,b1tilde_all,app_all,bpp_all,ael6_all, + & ael3_all,aad_all,bad_all,aa_all,bb_all,augm_all, + & eps_all,sigma_all,r0_all,chi_all,chipp_all,sigmap1_all, + & sigmap2_all, + & chis_all,alphasur_all,wstate_all,dhead_all,dtail_all, + & epshead_all, + & rborn_all,wqdip_all,wquad_all,alphapol_all,alphiso_all, + & sigiso1_all, + & sigiso2_all,epsintab_all,chip_all,alp_all,ebr_all, + & d0cm_all,akcm_all,akth_all,akct_all,v1ss_all,v2ss_all,v3ss_all, + & v1sccor_all,v2sccor_all,nbondterm_all, + & nlob_all,nlor_all,nterm_all,ntermd1_all,ntermd2_all, + & nthetyp_all,ithetyp_all,ntheterm_all,ntheterm2_all,ntheterm3_all, + & nsingle_all,ndouble_all,nntheterm_all,nterm_sccor_all,nstate_all diff --git a/source/wham/src-NEWSC-NEWCORR/COMMON.CHAIN b/source/wham/src-NEWSC-NEWCORR/COMMON.CHAIN new file mode 100644 index 0000000..07dd87e --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/COMMON.CHAIN @@ -0,0 +1,8 @@ + integer nres,nres0,nsup,nstart_sup,nend_sup,nstart_seq,ishift_pdb + double precision c,cref,dc,xloc,xrot,dc_norm,t,r,prod,rt + common /chain/ c(3,maxres2+2),dc(3,maxres2),xloc(3,maxres), + & xrot(3,maxres),dc_norm(3,maxres2),nres,nres0 + common /rotmat/ t(3,3,maxres),r(3,3,maxres),prod(3,3,maxres), + & rt(3,3,maxres) + common /refstruct/ cref(3,maxres2+2),nsup,nstart_sup,nend_sup, + & nstart_seq,ishift_pdb diff --git a/source/wham/src-NEWSC-NEWCORR/COMMON.COMPAR b/source/wham/src-NEWSC-NEWCORR/COMMON.COMPAR new file mode 100644 index 0000000..eb59ea4 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/COMMON.COMPAR @@ -0,0 +1,39 @@ + integer ifrag,nfrag,npiece,iclass,iscore,ishifft,ncont_nat,ibase, + & n_shift,ipiece,istruct,ielecont,isccont,irms,len_frag,isnfrag, + & nc_req_setf,iloc,iloc_single,list_frag,nlist_frag,nlevel + double precision rmsfrag,rmscutfrag,rmscut_base_low, + & rmscut_base_up, + & rmsup_lim,rmsupup_lim,rms_nat,rmsang,ang_cut,ang_cut1, + & frac_min,nc_fragm,qfrag,qnat + logical lgrp,lgrp_out,binary + integer ncreq_hel,ncreq_bet,ncreq_pair,irms_pair,icont_pair, + & isplit_bet,nshift_hel,nshift_bet,nshift_strand,nshift_pair, + & irms_single,icont_single + double precision angcut_hel,angcut1_hel,angcut_bet,angcut1_bet, + & angcut_strand,angcut1_strand,frac_min_set,ncfrac_hel,ncfrac_bet, + & ncfrac_pair,frac_sec + common /compar/ rmsfrag(maxfrag,maxlevel), + & qfrag(maxfrag,2),rmscut_base_low, + & rmscut_base_up,rmsup_lim,rmsupup_lim, + & rmscutfrag(2,maxfrag,maxlevel), + & rms_nat,qnat,rmsang,ang_cut(maxfrag), + & ang_cut1(maxfrag), + & frac_min(maxfrag),nc_fragm(maxfrag,maxlevel), + & nc_req_setf(maxfrag,maxlevel), + & ncont_nat(2,maxfrag,maxlevel),nfrag(maxlevel), + & isnfrag(maxlevel+1), + & npiece(maxfrag,maxlevel),ifrag(2,maxpiece,maxfrag), + & ipiece(maxpiece,maxfrag,2:maxlevel),istruct(maxfrag), + & ielecont(maxfrag,maxlevel), + & isccont(maxfrag,maxlevel),irms(maxfrag,maxlevel), + & iloc(maxfrag), + & iclass(maxlevel*maxfrag,maxlevel), + & iscore,ishifft(maxfrag,maxlevel), + & len_frag(maxfrag,maxlevel),n_shift(2,maxfrag,maxlevel), + & nlevel,ibase,lgrp,lgrp_out,binary, + & nlist_frag(maxfrag),list_frag(maxres,maxfrag) + common /compar1/ angcut_hel,angcut1_hel,angcut_bet,angcut1_bet, + & angcut_strand,angcut1_strand,frac_min_set,ncfrac_hel,ncfrac_bet, + & ncfrac_pair,frac_sec,ncreq_hel,ncreq_bet,ncreq_pair,irms_pair, + & icont_pair,isplit_bet,nshift_hel,nshift_bet,nshift_strand, + & nshift_pair,irms_single,icont_single,iloc_single diff --git a/source/wham/src-NEWSC-NEWCORR/COMMON.CONTACTS1 b/source/wham/src-NEWSC-NEWCORR/COMMON.CONTACTS1 new file mode 100644 index 0000000..04affa9 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/COMMON.CONTACTS1 @@ -0,0 +1,5 @@ + integer ncont,ncont_ref,icont,icont_ref,num_cont,jcont, + & nsccont_frag_ref,isccont_frag_ref + common /contacts/ ncont,ncont_ref,icont(2,maxcont), + & icont_ref(2,maxcont),nsccont_frag_ref(mmaxfrag), + & isccont_frag_ref(2,maxcont,mmaxfrag) diff --git a/source/wham/src-NEWSC-NEWCORR/COMMON.CONTROL b/source/wham/src-NEWSC-NEWCORR/COMMON.CONTROL new file mode 100644 index 0000000..1178504 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/COMMON.CONTROL @@ -0,0 +1,10 @@ + integer iscode,indpdb,outpdb,outmol2,icomparfunc,pdbint, + & ensembles,constr_dist + logical refstr,pdbref,punch_dist,print_rms,caonly,verbose, + & merge_helices,bxfile,cxfile,histfile,entfile,zscfile, + & rmsrgymap,with_dihed_constr,check_conf,histout,energy_dec + common /cntrl/ iscode,indpdb,refstr,pdbref,outpdb,outmol2, + & punch_dist,print_rms,caonly,verbose,icomparfunc,pdbint, + & merge_helices,bxfile,cxfile,histfile,entfile,zscfile,rmsrgymap, + & ensembles,with_dihed_constr,check_conf,histout,constr_dist, + & energy_dec diff --git a/source/wham/src-NEWSC-NEWCORR/COMMON.CONTROL.org b/source/wham/src-NEWSC-NEWCORR/COMMON.CONTROL.org new file mode 100644 index 0000000..7dc2298 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/COMMON.CONTROL.org @@ -0,0 +1,9 @@ + integer iscode,indpdb,outpdb,outmol2,icomparfunc,pdbint, + & ensembles + logical refstr,pdbref,punch_dist,print_rms,caonly,verbose, + & merge_helices,bxfile,cxfile,histfile,entfile,zscfile, + & rmsrgymap + common /cntrl/ iscode,indpdb,refstr,pdbref,outpdb,outmol2, + & punch_dist,print_rms,caonly,verbose,icomparfunc,pdbint, + & merge_helices,bxfile,cxfile,histfile,entfile,zscfile,rmsrgymap, + & ensembles diff --git a/source/wham/src-NEWSC-NEWCORR/COMMON.EMP b/source/wham/src-NEWSC-NEWCORR/COMMON.EMP new file mode 100644 index 0000000..5a39536 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/COMMON.EMP @@ -0,0 +1,126 @@ +c! Variable Declarations +c! Charge of i-th residue, charge of j-th residue,... + INTEGER Qi, Qj, Qij, ii, jj, itypi, itypj + +c! STUFF FROM EMOMO + +c! why do *I* have to declare those guys, when it is used throughout the whole code... + REAL*8 evdw, evdw_p, evdw_m + double precision xi, yi, zi, ctail(3,2), chead(3,2) +c! FOLLOWING ARE ***NOT*** in common block!!! +c! They are here just for their declarations + REAL*8 ecl,elj,equad,epol + INTEGER istate +c! intermediates + REAL*8 c1, c2, fac, pom +c! switch in the selector choosing which electrostatic energy/gradient function to call + INTEGER isel +c! sigma factors + REAL*8 sig, sig0ij, sig1, sig2 +c! intermediates related to distance + REAL*8 rij_shift, rrij, R1, R2, RR1, RR2 +c! intermediates related to angles + REAL*8 sinth1sq, sinth2sq +c! intermediates of Fgb + REAL*8 fgb, ee, ee1, ee2, eps0, pis + +c! squares of om1, om2 and om12 (those hold cosines of angles +c! theta) + REAL*8 sqom1, sqom2, sqom12 + +c! Geometry and general stuff +c! a12sq = ai*aj from fgb which is present in Egbpol/Fgbpol, +c! Epol/Gpol and others, ee is an intermediate. +c! three dimensions for X, Y and Z Cartesians + REAL*8 a12sq + +c! square distance and cartesian distances of polar/charged heads of sidechains + REAL*8 Rhead, Rhead_distance(3), Rhead_sq +c! square distance and cartesian distances of tail(hydrophobic centre of interaction) +c! of a given pair of sidechains + REAL*8 Rtail, Rtail_distance(3) +c! intermediates used in dXhead/dXtail + REAL*8 erhead(3), ertail(3), facd1, facd2, erdxi, erdxj + +c! unit vectors used to calculate R's + REAL*8 d1sq, d2sq, d1d2 + REAL*8 d1, d2 + +c! intermediates (hold different meanining in different places) + REAL*8 bat, hawk, eagle, condor, sparrow, rosella + REAL*8 tuna(3) + +c! holds 1/eps_in - 1/eps_out which appears in EGBpol Makowski et al JPCB 2011 +c! p. 6122 + REAL*8 eps_inout_fac, eps_in + +c! DERIVATIVES +c! intermediates + Real*8 dFdR, dFdL, dFdOM1, dFdOM2, dFdOM12 +c! Kronecker Delta used for dXhead/dXtail derivatives + Real*8 kro_delta +c! Gcl + REAL*8 Gelconst + REAL*8 dGCLdR, dGCLdOM1, dGCLdOM2, dGCLdOM12 + +c! Ggbpol +c! energy + REAL*8 Egb, dGGBdFGB, dGGBdR + REAL*8 dFGBdR, alphapol1, alphapol2 + +c! Gpol + REAL*8 fgb1, fgb2 + REAL*8 dPOLdOM1, dPOLdOM2, dPOLdR1, dPOLdR2 + REAL*8 dFGBdOM1, dFGBdOM2, dFGBdR1, dFGBdR2 + REAL*8 dPOLdFGB1, dPOLdFGB2, MomoFac1, MomoFac2 + REAL*8 erhead_tail(3,2) + +c! Gisocav + REAL*8 Fisocav, dGCVdR +c! alpha parameters for Fisocav/Gisocav + REAL*8 al1, al2, al3, al4, csig + +c! Gcav +c! energy + REAL*8 Fcav +c! alphas from the equation + REAL*8 b1, b2, b3, b4 +c! intermediates + Real*8 chif, lambf, chilambf + REAL*8 top, bot, dtop, dbot, botsq + REAL*8 chis1, chis2, chis12 +c! final value + REAL*8 dCAVdOM1, dCAVdOM2, dCAVdOM12 + +c! Gquad stuff +c! intermediates + REAL*8 wqd, w1, w2, beta1 +c! final value + REAl*8 dQUADdR, dQUADdOM1, dQUADdOM2, dQUADdOM12 + +c! Glj +c! parameter, radial derivative + REAL*8 eps_head, dGLJdR + +c! Sum of states + REAL*8 BetaT, eheadtail, weightbol, sumweight +c! this thing holds intermediates and final value +c! (dimensions, gvdw(c/x)(i/j),intermediate(1) or final(2)) + REAL*8 gheadtail(3,4,2) + +c! Now Commonize what we need to + COMMON /emp/ Qi, Qj, Qij, ii, jj, itypi, itypj, xi, yi, zi + & , sqom1, sqom2, sqom12, chead, ctail + & , al1, al2, al3, al4 + & , b1, b2, b3, b4 + & , Rhead, Rhead_distance, Rtail, Rtail_distance + & , R1, R2, RR1, RR2 + & , d1sq, d2sq, d1, d2, d1d2 + & , eps_inout_fac, eps_in, wqd, eps_head, a12sq + & , chis1, chis2, chis12, sig1, sig2, sig0ij + & , BetaT + & , dFdR, dFdL, dFdOM1, dFdOM2, dFdOM12 + & , dCAVdOM1, dCAVdOM2, dCAVdOM12 + & , dGCLdOM1, dGCLdOM2, dGCLdOM12 + & , dPOLdOM1, dPOLdOM2 + & , dQUADdR, dQUADdOM1, dQUADdOM2, dQUADdOM12 \ No newline at end of file diff --git a/source/wham/src-NEWSC-NEWCORR/COMMON.ENEPS b/source/wham/src-NEWSC-NEWCORR/COMMON.ENEPS new file mode 100644 index 0000000..eaf002e --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/COMMON.ENEPS @@ -0,0 +1,3 @@ + double precision eneps_temp(2,nntyp) + integer n_ene + common /weightder/ eneps_temp,n_ene diff --git a/source/wham/src-NEWSC-NEWCORR/COMMON.ENERGIES b/source/wham/src-NEWSC-NEWCORR/COMMON.ENERGIES new file mode 100644 index 0000000..2d40a95 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/COMMON.ENERGIES @@ -0,0 +1,4 @@ + double precision potE(MaxStr_Proc,Max_Parm),entfac(MaxStr_Proc), + & q(MaxQ+2,MaxStr_Proc),enetb(max_ene,MaxStr_Proc,Max_Parm) + integer einicheck + common /energies/ potE,entfac,q,enetb,einicheck diff --git a/source/wham/src-NEWSC-NEWCORR/COMMON.FREE b/source/wham/src-NEWSC-NEWCORR/COMMON.FREE new file mode 100644 index 0000000..3e378ca --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/COMMON.FREE @@ -0,0 +1,15 @@ + integer nQ,nparmset,stot(maxslice),rescale_mode,iparmprint,myparm + logical hamil_rep,separate_parset + double precision Kh(MaxQ,MaxR,MaxT_h,max_parm), + & q0(MaxQ,MaxR,MaxT_h,max_parm),delta,deltrms,deltrgy,fimin, + & f(maxR,maxT_h,max_parm),beta_h(MaxT_h,max_parm) + double precision delta_T,startGridT + integer nR(maxT_h,max_parm),snk(MaxR,MaxT_h,max_parm,MaxSlice), + & nT_h(max_parm),maxit,totraj(maxR,max_parm),nRR(maxT_h,max_parm) + integer nGridT + logical replica(max_parm),umbrella(max_parm),read_iset(max_parm) + common /wham/ Kh,q0,f,beta_h,delta,deltrms,deltrgy,delta_T, + & startGridT,fimin,snk,nR, + & nRR,nT_h,nQ,stot,nparmset,maxit,rescale_mode,replica,umbrella, + & read_iset,totraj,hamil_rep,separate_parset,iparmprint,myparm, + & nGridT diff --git a/source/wham/src-NEWSC-NEWCORR/COMMON.IOUNITS b/source/wham/src-NEWSC-NEWCORR/COMMON.IOUNITS new file mode 100644 index 0000000..23783bb --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/COMMON.IOUNITS @@ -0,0 +1,51 @@ +C----------------------------------------------------------------------- +C I/O units used by the program +C----------------------------------------------------------------------- +C 9/18/99 - unit ifourier and filename fouriername included to identify +C the file from which the coefficients of second-order Fourier expansion +C of the local-interaction energy are read. +C 8/9/01 - file for SCP interaction constants named scpname (unit iscpp) +C included. +C----------------------------------------------------------------------- +C General I/O units & files + integer inp,iout,igeom,intin,ipdb,imol2,ipdbin,ithep,irotam, + & itorp,itordp,ifourier,ielep,isidep,iscpp,isccor,icbase, + & istat,ientin,ientout,isidep1,ibond,ihist,izsc,idistr + common /iounits/ inp,iout,igeom,intin,ipdb,imol2,ipdbin,ithep, + & irotam,itorp,itordp,ifourier,ielep,isidep,iscpp,isccor, + & icbase,istat,ientin,ientout,isidep1,ibond,ihist,izsc, + & idistr + character*256 outname,intname,pdbname,mol2name,statname,intinname, + & entname,restartname,prefix,scratchdir,sidepname,pdbfile, + & histname,zscname + common /fnames/ outname,intname,pdbname,mol2name,statname, + & intinname,entname,restartname,prefix,pot,scratchdir, + & sidepname,pdbfile,histname,zscname +C Parameter files + character*256 bondname,thetname,rotname,torname,tordname, + & fouriername,elename,sidename,scpname,sccorname,patname + common /parfiles/ thetname,rotname,torname,tordname,bondname, + & fouriername,elename,sidename,scpname,sccorname,patname + character*3 pot +C----------------------------------------------------------------------- +C INP - main input file +C IOUT - list file +C IGEOM - geometry output in the form of virtual-chain internal coordinates +C INTIN - geometry input (for multiple conformation processing) in int. coords. +C IPDB - Cartesian-coordinate output in PDB format +C IMOL2 - Cartesian-coordinate output in Tripos mol2 format +C IPDBIN - PDB input file +C ITHEP - virtual-bond torsional angle parametrs +C IROTAM - side-chain geometry and local-interaction parameters +C ITORP - torsional parameters +C ITORDP - double torsional parameters +C IFOURIER - coefficients of the expansion of local-interaction energy +C IELEP - electrostatic-interaction parameters +C ISIDEP - side-chain interaction parameters. +C ISCPP - SCp interaction parameters. +C IBOND - virtual-bond constant parameters and moments of inertia. +C ISCCOR - parameters of the potential of SCCOR term +C ICBASE - data base with Cartesian coords of known structures. +C ISTAT - energies and other conf. characteristics from an MCM run. +C IENTIN - entropy from preceding simulation(s) to be read in. +C----------------------------------------------------------------------- diff --git a/source/wham/src-NEWSC-NEWCORR/COMMON.MPI b/source/wham/src-NEWSC-NEWCORR/COMMON.MPI new file mode 100644 index 0000000..037c1c9 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/COMMON.MPI @@ -0,0 +1,8 @@ + integer me, me1, Master, Master1, Nprocs, Nprocs1, Comm1, + & Indstart, Indend, scount, idispl, i2ii, WHAM_COMM + integer indstart_map,indend_map,idispl_map,scount_map + common /MPI_Data/ Nprocs, Master,Master1,Me,Comm1,Me1,Nprocs1, + & WHAM_COMM, + & Indstart(0:MaxProcs), + & Indend(0:MaxProcs), idispl(0:MaxProcs), + & scount(0:MaxProcs) diff --git a/source/wham/src-NEWSC-NEWCORR/COMMON.OBCINKA b/source/wham/src-NEWSC-NEWCORR/COMMON.OBCINKA new file mode 100644 index 0000000..e0d9c61 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/COMMON.OBCINKA @@ -0,0 +1,3 @@ + real*8 time_start_collect(maxR,MaxT_h,Max_Parm), + & time_end_collect(maxR,MaxT_h,Max_Parm) + common /obcinka/ time_start_collect,time_end_collect diff --git a/source/wham/src-NEWSC-NEWCORR/COMMON.PEPTCONT b/source/wham/src-NEWSC-NEWCORR/COMMON.PEPTCONT new file mode 100644 index 0000000..59e05dd --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/COMMON.PEPTCONT @@ -0,0 +1,7 @@ + integer ncont_pept_ref,icont_pept_ref,ncont_frag_ref, + & icont_frag_ref,isec_ref + common /peptcont/ ncont_pept_ref, + & icont_pept_ref(2,maxcont), + & ncont_frag_ref(mmaxfrag), + & icont_frag_ref(2,maxcont,mmaxfrag), + & isec_ref(maxres) diff --git a/source/wham/src-NEWSC-NEWCORR/COMMON.PROT b/source/wham/src-NEWSC-NEWCORR/COMMON.PROT new file mode 100644 index 0000000..054ec47 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/COMMON.PROT @@ -0,0 +1,2 @@ + integer ntot(maxslice),isampl(max_parm),nslice + common /protein/ ntot,isampl,nslice diff --git a/source/wham/src-NEWSC-NEWCORR/COMMON.PROTFILES b/source/wham/src-NEWSC-NEWCORR/COMMON.PROTFILES new file mode 100644 index 0000000..3287326 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/COMMON.PROTFILES @@ -0,0 +1,10 @@ + character*80 protfiles(maxfile_prot,2,MaxR,MaxT_h,Max_Parm), + & bprotfiles + integer nfile_bin(MaxR,MaxT_h,Max_Parm), + & nfile_asc(MaxR,MaxT_h,Max_Parm), + & nfile_cx(MaxR,MaxT_h,Max_Parm), + & rec_start(MaxR,MaxT_h,Max_Parm), + & rec_end(MaxR,MaxT_h,Max_Parm),lenrec,lenrec1,lenrec2 + common /protfil/ protfiles,bprotfiles, + & nfile_bin,nfile_asc,nfile_cx,rec_start,rec_end,lenrec,lenrec1, + & lenrec2 diff --git a/source/wham/src-NEWSC-NEWCORR/COMMON.VAR b/source/wham/src-NEWSC-NEWCORR/COMMON.VAR new file mode 100644 index 0000000..2b11894 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/COMMON.VAR @@ -0,0 +1,17 @@ +C Store the geometric variables in the following COMMON block. + integer ntheta,nphi,nside,nvar,ialph,ivar + double precision theta,phi,alph,omeg,vbld,vbld_ref, + & theta_ref,phi_ref,alph_ref,omeg_ref, + & costtab,sinttab,cost2tab,sint2tab, + & xxtab,yytab,zztab,tauangle,omicron + common /var/ theta(maxres),phi(maxres),alph(maxres),omeg(maxres), + & omicron(2,maxres),tauangle(3,maxres), + & vbld(2*maxres), + & costtab(maxres), sinttab(maxres), cost2tab(maxres), + & sint2tab(maxres),xxtab(maxres),yytab(maxres), + & zztab(maxres), + & ialph(maxres,2),ivar(4*maxres2),ntheta,nphi,nside,nvar +C Angles from experimental structure + common /varref/ vbld_ref(maxres), + & theta_ref(maxres),phi_ref(maxres), + & alph_ref(maxres),omeg_ref(maxres) diff --git a/source/wham/src-NEWSC-NEWCORR/DIMENSIONS b/source/wham/src-NEWSC-NEWCORR/DIMENSIONS new file mode 100644 index 0000000..4d9279d --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/DIMENSIONS @@ -0,0 +1,142 @@ +******************************************************************************** +* Settings for the program of united-residue peptide simulation in real space * +* * +* ------- As of 6/23/01 ----------- * +* * +******************************************************************************** +c implicit real*8 (a-h,o-z) +C Max. number of processors. +c parameter (maxprocs=128) +C Max. number of fine-grain processors +c parameter (max_fg_procs=maxprocs) +C Max. number of coarse-grain processors +c parameter (max_cg_procs=maxprocs) +C Max. number of AA residues + integer maxres +c parameter (maxres=250) + parameter (maxres=400) +C Appr. max. number of interaction sites + integer maxres2 + parameter (maxres2=2*maxres) +C Max. number of variables + integer maxvar + parameter (maxvar=4*maxres) +C Max. number of groups of interactions that a given SC is involved in + integer maxint_gr + parameter (maxint_gr=2) +C Max. number of derivatives of virtual-bond and side-chain vectors in theta +C or phi. + integer maxdim + parameter (maxdim=(maxres-1)*(maxres-2)/2) +C Max. number of SC contacts + integer maxcont + parameter (maxcont=12*maxres) +C Max. number of contacts per residue + integer maxconts + parameter (maxconts=maxres) +C Number of AA types (at present only natural AA's will be handled + integer ntyp,ntyp1 + parameter (ntyp=20,ntyp1=ntyp+1) + integer nntyp + parameter (nntyp=ntyp*(ntyp+1)/2) +C Max. number of types of dihedral angles & multiplicity of torsional barriers +C and the number of terms in double torsionals + integer maxtor,maxterm,maxlor,maxtermd_1,maxtermd_2 + parameter (maxtor=4,maxterm=10,maxlor=3,maxtermd_1=8,maxtermd_2=8) +c Max number of torsional terms in SCCOR + integer maxterm_sccor + parameter (maxterm_sccor=6) +C Max. number of residue types and parameters in expressions for +C virtual-bond angle bending potentials + integer maxthetyp,maxthetyp1,maxtheterm,maxtheterm2,maxtheterm3, + & maxsingle,maxdouble,mmaxtheterm + parameter (maxthetyp=3,maxthetyp1=maxthetyp+1,maxtheterm=20, + & maxtheterm2=6,maxtheterm3=4,maxsingle=6,maxdouble=4, + & mmaxtheterm=maxtheterm) +C Max. number of lobes in SC distribution + integer maxlob + parameter (maxlob=4) +C Max. number of S-S bridges + integer maxss + parameter (maxss=20) +C Max. number of dihedral angle constraints + integer maxdih_constr + parameter (maxdih_constr=maxres) +C Max. number of patterns in the pattern database + integer maxseq + parameter (maxseq=1000) +C Max. number of residues in a peptide in the database + integer maxres_base + parameter (maxres_base=1000) +C Max. number of threading attempts + integer maxthread + parameter (maxthread=2000) +C Max. number of move types in MCM + integer maxmovetype + parameter (maxmovetype=4) +C Max. number of stored confs. in MC/MCM simulation + integer maxsave + parameter (maxsave=2000) +C Max. number of conformations in Master's cache array + integer max_cache + parameter (max_cache=1000) +C Max. number of conformations in the pool + integer max_pool + parameter (max_pool=1000) +C Number of threads in deformation + integer max_thread,max_thread2 + parameter (max_thread=40,max_thread2=2*max_thread) +C Number of steps in DSM + integer max_step + parameter (max_step=1) +C Number of structures to compare at t=0 + integer max_threadss,max_threadss2 + parameter (max_threadss=80,max_threadss2=2*max_threadss) +C Maxmimum number of angles per residue + integer mxang + parameter (mxang=4) +C Maximum number of groups of angles + integer mxgr + parameter (mxgr=2*maxres) +C Maximum number of chains + integer mxch + parameter (mxch=1) +C Maximum number of generated conformations + integer mxio + parameter (mxio=1000) +C Maximum number of seed + integer max_seed + parameter (max_seed=100) +C Maximum number of structures for ZSCORE for each protein + integer maxzs + parameter (maxzs=2) +C Maximum number of structures stored for comparison for ZSCORE for each protein + integer maxzs1 + parameter (maxzs1=6) +C Maximum number of proteins for ZSCORE + integer maxprotzs + parameter (maxprotzs=1) +C Maximum number of conf in rmsdbank + integer maxrmsdb + parameter (maxrmsdb=110) +C Maximum number of bankt conformations + integer mxiot + parameter (mxiot=mxio) +c Maximum number of conformations in MCMF + integer maxstr_mcmf + parameter (maxstr_mcmf=800) +c Maximum number of families in MCMF + integer maxfam_p + parameter (maxfam_p=20) +c Maximum number of structures in family in MCMF + integer maxstr_fam + parameter (maxstr_fam=40) +C Maximum number of threads in MCMF + integer maxthread_mcmf + parameter (maxthread_mcmf=10) +C Maximum number of SC local term fitting function coefficiants + integer maxsccoef + parameter (maxsccoef=65) +C Maximum number of terms in SC bond-stretching potential + integer maxbondterm + parameter (maxbondterm=3) diff --git a/source/wham/src-NEWSC-NEWCORR/DIMENSIONS.COMPAR b/source/wham/src-NEWSC-NEWCORR/DIMENSIONS.COMPAR new file mode 100644 index 0000000..911bd4e --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/DIMENSIONS.COMPAR @@ -0,0 +1,25 @@ +****************************************************************** +* +* Array dimensions for level-based conformation comparison program: +* +* Max. number of conformations in the data set. +* + integer maxconf + PARAMETER (MAXCONF=maxstr_proc) +* +* Max. number levels of comparison +* + integer maxlevel + PARAMETER (MAXLEVEL=3) +* +* Max. number of fragments at a given level of comparison +* + integer maxfrag,mmaxfrag + PARAMETER (MAXFRAG=30,MMAXFRAG=MAXFRAG*(MAXFRAG+1)/2) +* +* Max. number of pieces forming a substructure to be compared +* + integer maxpiece + PARAMETER (MAXPIECE=20) +* +******************************************************************* diff --git a/source/wham/src-NEWSC-NEWCORR/DIMENSIONS.FREE b/source/wham/src-NEWSC-NEWCORR/DIMENSIONS.FREE new file mode 100644 index 0000000..5f1a041 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/DIMENSIONS.FREE @@ -0,0 +1,14 @@ + integer Max_Parm + integer MaxQ,MaxQ1 + integer MaxR,MaxT_h + integer MaxSlice + parameter (Max_Parm=1) + parameter (MaxQ=4,MaxQ1=MaxQ+2) + parameter(MaxR=1,MaxT_h=32) + parameter(MaxSlice=40) + integer MaxN + parameter (MaxN=100) + integer MaxPrintConf + parameter (MaxPrintConf=1000) + integer Max_GridT + parameter (Max_GridT=400) diff --git a/source/wham/src-NEWSC-NEWCORR/DIMENSIONS.FREE.old b/source/wham/src-NEWSC-NEWCORR/DIMENSIONS.FREE.old new file mode 100644 index 0000000..e579dd1 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/DIMENSIONS.FREE.old @@ -0,0 +1,12 @@ + integer Max_Parm + integer MaxQ,MaxQ1 + integer MaxR,MaxT_h + integer MaxSlice + parameter (Max_Parm=6) + parameter (MaxQ=5,MaxQ1=MaxQ+2) + parameter(MaxR=1,MaxT_h=32) + parameter(MaxSlice=40) + integer MaxN + parameter (MaxN=100) + integer MaxPrintConf + parameter (MaxPrintConf=1000) diff --git a/source/wham/src-NEWSC-NEWCORR/DIMENSIONS.ZSCOPT b/source/wham/src-NEWSC-NEWCORR/DIMENSIONS.ZSCOPT new file mode 100644 index 0000000..0d8e64b --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/DIMENSIONS.ZSCOPT @@ -0,0 +1,40 @@ + integer maxstr,max_ene,maxprot,maxclass,maxfile_prot,maxobj, + & maxstr_proc, maxclass1 +c Maximum number of structures in the database, energy components, proteins, +c and structural classes +c#ifdef JUBL + parameter (maxstr=200000,max_ene=21,maxprot=7,maxclass=5000) + parameter (maxclass1=10) +c Maximum number of structures to be dealt with by one processor + parameter (maxstr_proc=20000) +c Maximum number of temperatures + integer maxT + parameter (maxT=10) +c Maximum number of batches + integer maxbatch + parameter (maxbatch=1) +c Maximum number of energy/Zscore gaps for a single protein + integer maxgap + parameter (maxgap=2*maxclass1) +c Maximum number of the components of the target function + parameter (maxobj=maxgap*maxprot*maxT) +c Maximum number of files with energies/coordinates + parameter (maxfile_prot=100) +c Maximum number of grid points in energy map evaluation + integer max_x,max_y,max_minim + parameter (max_x=200,max_y=200,max_minim=1000) +c Maximum number of processors + integer MaxProcs + parameter (MaxProcs = 2048) +c Maximum number of optimizable parameters + integer max_paropt + parameter (max_paropt=500) +c Maximum number of fragments +c integer maxfrag +c parameter (maxfrag=0) +c Maximum number of sublevels + integer maxlev + parameter (maxlev=maxclass) +c Maximum number of grid points in temperature + integer MaxGridT + parameter (MaxGridT=2000) diff --git a/source/wham/src-NEWSC-NEWCORR/Makefile b/source/wham/src-NEWSC-NEWCORR/Makefile new file mode 120000 index 0000000..8453cdd --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/Makefile @@ -0,0 +1 @@ +Makefile_MPICH_ifort \ No newline at end of file diff --git a/source/wham/src-NEWSC-NEWCORR/Makefile-pgi b/source/wham/src-NEWSC-NEWCORR/Makefile-pgi new file mode 100644 index 0000000..40cc442 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/Makefile-pgi @@ -0,0 +1,74 @@ +BIN = /users/adam/ZSCOREZ/bin +CC = cc +FC = mpif90 +#FC = ifc +OPT = -fast -pc 64 -tp p6 -Minline=name:scalar2,scalar,transpose2,matvec2,prodmat3 +#FFLAGS = ${OPT} -g -c -I. -I./include_unres +#FFLAGS = ${OPT} -c -C -g -I. -I./include_unres +FFLAGS = ${OPT} -c -I. -I./include_unres +LIBS = -L../../MEY_MD/src_Tc/xdrf -lxdrf +#LIBS = -L$(INSTALL_DIR)/lib_pgi -lmpich -lpmpich -Vaxlib +#CPPFLAGS = -DMPI -DLINUX -DUNRES -DMOMENT -DCHECKGRAD -DPGI +#CPPFLAGS = -DMPI -DLINUX -DUNRES -DCHECKGRAD -DPGI -DMYGETENV +CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI +#CPPFLAGS = -DMPI -DLINUX -DUNRES -DPGI +#CPPFLAGS = -DMPI -DLINUX -DUNRES + +.f.o: + ${FC} ${FFLAGS} $*.f + +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + +all: make_dbase + +objects = \ + wham_multparm.o \ + bxread.o \ + xread.o \ + cxread.o \ + enecalc1.o \ + energy_p_new.o \ + initialize_p.o \ + molread_zs.o \ + openunits.o \ + readrtns.o \ + arcos.o \ + cartder.o \ + cartprint.o \ + chainbuild.o \ + geomout.o \ + icant.o \ + intcor.o \ + int_from_cart.o \ + make_ensemble1.o \ + matmult.o \ + misc.o \ + mygetenv.o \ + parmread.o \ + pinorm.o \ + printmat.o \ + proc_proc.o \ + rescode.o \ + setup_var.o \ + slices.o \ + store_parm.o \ + timing.o \ + wham_calc1.o + +objects_compar = \ + readrtns_compar.o \ + readpdb.o fitsq.o contact.o \ + elecont.o contfunc.o cont_frag.o conf_compar.o match_contact.o \ + angnorm.o odlodc.o promienie.o qwolynes.o read_ref_str.o \ + rmscalc.o secondary.o proc_cont.o define_pairs.o mysort.o + +make_dbase: ${objects} ${objects_compar} + cc -o compinfo compinfo.c + ./compinfo + ${FC} -c ${FFLAGS} cinfo.f + $(FC) ${OPT} -Wl,-Bstatic ${objects} ${objects_compar} cinfo.o \ + ${LIBS} -o ${BIN}/wham_multparm-T-sccor + +clean: + /bin/rm *.o diff --git a/source/wham/src-NEWSC-NEWCORR/Makefile1_jump b/source/wham/src-NEWSC-NEWCORR/Makefile1_jump new file mode 100644 index 0000000..1df1586 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/Makefile1_jump @@ -0,0 +1,60 @@ +BIN = ../bin +CC = cc +FC = mpxlf90 -qfixed -w +OPT = -q64 +FFLAGS = -c ${OPT} -O3 -I./include_unres +LIBS = xdrf/libxdrf.o xdrf/ftocstr.o +CPPFLAGS = -WF,-DMPI -WF,-DAIX -WF,-DUNRES -WF,-DSPLITELE -WF,-DPROCOR -WF,-DISNAN + +.SUFFIXES: .F +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + +all: make_dbase + +objects = \ + wham_multparm.o \ + cxread.o \ + enecalc1.o \ + energy_p_new.o \ + initialize_p.o \ + molread_zs.o \ + openunits.o \ + readrtns.o \ + arcos.o \ + cartder.o \ + cartprint.o \ + chainbuild.o \ + geomout.o \ + icant.o \ + intcor.o \ + int_from_cart.o \ + make_ensemble1.o \ + matmult.o \ + misc.o \ + mygetenv.o \ + parmread.o \ + pinorm.o \ + printmat.o \ + rescode.o \ + setup_var.o \ + store_parm.o \ + timing.o \ + wham_calc1.o + +objects_compar = \ + readrtns_compar.o \ + readpdb.o fitsq.o contact.o \ + elecont.o contfunc.o cont_frag.o conf_compar.o match_contact.o \ + angnorm.o odlodc.o promienie.o qwolynes.o read_ref_str.o \ + rmscalc.o secondary.o proc_cont.o define_pairs.o mysort.o + +make_dbase: ${objects} ${objects_compar} + cc -o compinfo compinfo.c + ./compinfo + ${FC} -c ${FFLAGS} cinfo.f + $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ + ${LIBS} -o ${BIN}/wham_multparm1-T-procor + +clean: + /bin/rm *.o diff --git a/source/wham/src-NEWSC-NEWCORR/Makefile_MPICH_ifort b/source/wham/src-NEWSC-NEWCORR/Makefile_MPICH_ifort new file mode 100644 index 0000000..9377fbb --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/Makefile_MPICH_ifort @@ -0,0 +1,89 @@ +INSTALL_DIR = /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh +BIN = /users/adam/unres/bin/wham +FC= ifort +#OPT = -mcmodel=medium -O3 -ip -w +OPT = -mcmodel=medium -g -CA -CB +FFLAGS = ${OPT} -c -I. -I./include_unres -I$(INSTALL_DIR)/include +LIBS = -L$(INSTALL_DIR)/lib -lmpich -lpmpich xdrf/libxdrf.a + +.f.o: + ${FC} ${FFLAGS} $*.f + +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + +objects = \ + wham_multparm.o \ + bxread.o \ + xread.o \ + cxread.o \ + enecalc1.o \ + energy_p_new.o \ + gnmr1.o \ + initialize_p.o \ + molread_zs.o \ + openunits.o \ + readrtns.o \ + arcos.o \ + cartder.o \ + cartprint.o \ + chainbuild.o \ + geomout.o \ + icant.o \ + intcor.o \ + int_from_cart.o \ + make_ensemble1.o \ + matmult.o \ + misc.o \ + mygetenv.o \ + parmread.o \ + pinorm.o \ + printmat.o \ + proc_proc.o \ + rescode.o \ + setup_var.o \ + slices.o \ + store_parm.o \ + timing.o \ + wham_calc1.o + +objects_compar = \ + readrtns_compar.o \ + readpdb.o fitsq.o contact.o \ + elecont.o contfunc.o cont_frag.o conf_compar.o match_contact.o \ + angnorm.o odlodc.o promienie.o qwolynes.o read_ref_str.o \ + rmscalc.o secondary.o proc_cont.o define_pairs.o mysort.o + +GABs: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 \ + -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DSCALREP +GABs: ${objects} ${objects_compar} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo + ${FC} -c ${FFLAGS} cinfo.f + $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ + ${LIBS} -static-intel -o ${BIN}/wham_ifort_MPICH_MM-KN-DEBUG-scalrep.exe + +GAB: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 \ + -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DNEWCORR +GAB: ${objects} ${objects_compar} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo + ${FC} -c ${FFLAGS} cinfo.f + $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ + ${LIBS} -static-intel -o ${BIN}/wham_ifort_MPICH_MM-KN-NEWC.exe + +E0LL2Y: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 -DNEWCORR +E0LL2Y: ${objects} ${objects_compar} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo + ${FC} -c ${FFLAGS} cinfo.f + $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ + ${LIBS} -static-intel -o ${BIN}/wham_ifort_MPICH_MM-PH-NEWC.exe + +xdrf/libxdrf.a: + cd xdrf && make + + +clean: + /bin/rm -f *.o && /bin/rm -f compinfo && cd xdrf && make clean + diff --git a/source/wham/src-NEWSC-NEWCORR/Makefile_jubl b/source/wham/src-NEWSC-NEWCORR/Makefile_jubl new file mode 100644 index 0000000..5f37ee7 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/Makefile_jubl @@ -0,0 +1,95 @@ +CPPFLAGS = -WF,-DOLD_GINV \ + -WF,-DUNRES -WF,-DMPI \ + -WF,-DSPLITELE -WF,-DISNAN \ + -WF,-DAIX -WF,-DLANG0 -WF,-DPROCOR -WF,-DJUBL +#-WF,-DNOXDR +#-WF,-DPROCOR +## -DMOMENT +#-DCO_BIAS +#-DCRYST_TOR +#-DDEBUG + +BGLSYS = /bgl/BlueLight/ppcfloor/bglsys + +CC = /usr/bin/blrts_xlc +CPPC = /usr/bin/blrts_xlc +FC = /usr/bin/blrts_xlf90 +#-pg -g + +# try -qarch=440 first, then use -qarch=440d for 2nd FPU later on +# (SIMDization requires at least -O3) +# use -qlist -qsource with 440d and look for Parallel ASM instructions. +# +OPT= -I$(BGLSYS)/include -L$(BGLSYS)/lib -qarch=440d -qtune=440 -qfixed -w -qnosave +CFLAGS= -O3 -I$(BGLSYS)/include -L$(BGLSYS)/lib -qarch=440d -qtune=440 +FFLAGS= -c -O3 ${OPT} -I./include_unres +# +LIBS_MPI = -lmpich.rts -lmsglayer.rts -lrts.rts -ldevices.rts +LIBSF_MPI = -lmpich.rts -lfmpich.rts -lmsglayer.rts -lrts.rts -ldevices.rts + +FFLAGS1 = -c ${OPT} -O2 +FFLAGS2 = -c ${OPT} -O +FFLAGSE = -c ${OPT} -O4 + + +BIN = ${HOME}/UNRES/bin/wham_multparm-T-procor.rts +LIBS = ${LIBSF_MPI} ../src_Tc/xdrf/libxdrf.a +#LIBS = ${LIBSF_MPI} + +ARCH = LINUX +PP = /lib/cpp -P + +all: unresCSA + +.SUFFIXES: .F +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + + +objects = \ + wham_multparm.o \ + cxread.o \ + enecalc.o \ + energy_p_new.o \ + initialize_p.o \ + molread_zs.o \ + openunits.o \ + readrtns.o \ + arcos.o \ + cartder.o \ + cartprint.o \ + chainbuild.o \ + geomout.o \ + icant.o \ + intcor.o \ + int_from_cart.o \ + make_ensemble.o \ + matmult.o \ + misc.o \ + mygetenv.o \ + parmread.o \ + pinorm.o \ + printmat.o \ + rescode.o \ + setup_var.o \ + store_parm.o \ + timing.o \ + wham_calc.o + +objects_compar = \ + readrtns_compar.o \ + readpdb.o fitsq.o contact.o \ + elecont.o contfunc.o cont_frag.o conf_compar.o match_contact.o \ + angnorm.o odlodc.o promienie.o qwolynes.o read_ref_str.o \ + rmscalc.o secondary.o proc_cont.o define_pairs.o mysort.o + + +unresCSA: ${objects} ${objects_compar} + cc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + ${FC} ${OPT} ${objects} ${objects_compar} cinfo.o ${LIBS} -o ${BIN} + + +clean: + /bin/rm *.o diff --git a/source/wham/src-NEWSC-NEWCORR/Makefile_jump b/source/wham/src-NEWSC-NEWCORR/Makefile_jump new file mode 100644 index 0000000..e79c218 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/Makefile_jump @@ -0,0 +1,69 @@ +BIN = ../bin +CC = cc +CFLAGS = -DAIX -c +FC = mpxlf90 -qlistopt -qfixed -w +OPT = -q64 +FFLAGS = -c ${OPT} -O3 -I./include_unres +#FFLAGS = -c ${OPT} -g -C -I./include_unres +LIBS = xdrf/libxdrf.o xdrf/ftocstr.o +CPPFLAGS = -WF,-DMPI -WF,-DAIX -WF,-DUNRES -WF,-DSPLITELE -WF,-DPROCOR -WF,-DISNAN + +.SUFFIXES: .F +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + +.SUFFIXES: .c +.c.o: + ${CC} ${CFLAGS} $*.c + +all: make_dbase + +objects = \ + wham_multparm.o \ + bxread.o \ + xread.o \ + cxread.o \ + enecalc1.o \ + energy_p_new.o \ + initialize_p.o \ + molread_zs.o \ + openunits.o \ + readrtns.o \ + arcos.o \ + cartder.o \ + cartprint.o \ + chainbuild.o \ + geomout.o \ + icant.o \ + intcor.o \ + int_from_cart.o \ + make_ensemble1.o \ + matmult.o \ + misc.o \ + mygetenv.o \ + parmread.o \ + pinorm.o \ + printmat.o \ + rescode.o \ + setup_var.o \ + slices.o \ + store_parm.o \ + timing.o \ + wham_calc1.o + +objects_compar = \ + readrtns_compar.o \ + readpdb.o fitsq.o contact.o \ + elecont.o contfunc.o cont_frag.o conf_compar.o match_contact.o \ + angnorm.o odlodc.o promienie.o qwolynes.o read_ref_str.o \ + rmscalc.o secondary.o proc_cont.o define_pairs.o mysort.o + +make_dbase: ${objects} ${objects_compar} + cc -o compinfo compinfo.c + ./compinfo + ${FC} -c ${FFLAGS} cinfo.f + $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ + ${LIBS} -o ${BIN}/wham_multparm-T-procor-c1 + +clean: + /bin/rm *.o diff --git a/source/wham/src-NEWSC-NEWCORR/Makefile_matrix b/source/wham/src-NEWSC-NEWCORR/Makefile_matrix new file mode 100644 index 0000000..d16bc8c --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/Makefile_matrix @@ -0,0 +1,67 @@ +INSTALL_DIR = /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh +BIN = ../bin +FC= ifort +#OPT = -mcmodel=medium -O3 -ip -w +OPT = -mcmodel=medium -g -CB +FFLAGS = ${OPT} -c -I. -I./include_unres -I$(INSTALL_DIR)/include +LIBS = -L$(INSTALL_DIR)/lib -lmpich -lpmpich xdrf/libxdrf.a +CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 + +.f.o: + ${FC} ${FFLAGS} $*.f + +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + +all: make_dbase + +objects = \ + wham_multparm.o \ + bxread.o \ + xread.o \ + cxread.o \ + enecalc1.o \ + energy_p_new.o \ + initialize_p.o \ + molread_zs.o \ + openunits.o \ + readrtns.o \ + arcos.o \ + cartder.o \ + cartprint.o \ + chainbuild.o \ + geomout.o \ + icant.o \ + intcor.o \ + int_from_cart.o \ + make_ensemble1.o \ + matmult.o \ + misc.o \ + mygetenv.o \ + parmread.o \ + pinorm.o \ + printmat.o \ + proc_proc.o \ + rescode.o \ + setup_var.o \ + slices.o \ + store_parm.o \ + timing.o \ + wham_calc1.o + +objects_compar = \ + readrtns_compar.o \ + readpdb.o fitsq.o contact.o \ + elecont.o contfunc.o cont_frag.o conf_compar.o match_contact.o \ + angnorm.o odlodc.o promienie.o qwolynes.o read_ref_str.o \ + rmscalc.o secondary.o proc_cont.o define_pairs.o mysort.o + +make_dbase: ${objects} ${objects_compar} + cc -o compinfo compinfo.c + ./compinfo + ${FC} -c ${FFLAGS} cinfo.f + $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ + ${LIBS} -static-intel -o ${BIN}/wham_multparm-ham_rep + +clean: + /bin/rm *.o diff --git a/source/wham/src-NEWSC-NEWCORR/Makefile_matrix_PGI b/source/wham/src-NEWSC-NEWCORR/Makefile_matrix_PGI new file mode 100644 index 0000000..bb4982d --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/Makefile_matrix_PGI @@ -0,0 +1,76 @@ +INSTALL_DIR = /users/software/mpich-1.2.7p1_pgi_9.0_64bit_ssh +BIN = ../bin +CC = cc +FC = pgf90 +#FC = ifc +#OPT = -mcmodel=medium -Mlarge_arrays -fast -pc 64 -tp amd64 -C -g +OPT = -mcmodel=medium -Mlarge_arrays -tp amd64 +#FFLAGS = ${OPT} -g -c -I. -I./include_unres -I$(INSTALL_DIR)/include +FFLAGS = ${OPT} -c -C -g -I. -I./include_unres -I$(INSTALL_DIR)/include +#FFLAGS = ${OPT} -c -I. -I./include_unres -I$(INSTALL_DIR)/include +LIBS = -L$(INSTALL_DIR)/lib -lmpich -lpmpich xdrf/libxdrf.a +#LIBS = -L$(INSTALL_DIR)/lib_pgi -lmpich -lpmpich -Vaxlib +#CPPFLAGS = -DMPI -DLINUX -DUNRES -DMOMENT -DCHECKGRAD -DPGI +#CPPFLAGS = -DMPI -DLINUX -DUNRES -DCHECKGRAD -DPGI -DMYGETENV +CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI +#CPPFLAGS = -DMPI -DLINUX -DUNRES -DPGI +#CPPFLAGS = -DMPI -DLINUX -DUNRES + +.f.o: + ${FC} ${FFLAGS} $*.f + +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + +all: make_dbase + +objects = \ + wham_multparm.o \ + bxread.o \ + xread.o \ + cxread.o \ + enecalc1.o \ + energy_p_new.o \ + initialize_p.o \ + molread_zs.o \ + openunits.o \ + readrtns.o \ + arcos.o \ + cartder.o \ + cartprint.o \ + chainbuild.o \ + geomout.o \ + icant.o \ + intcor.o \ + int_from_cart.o \ + make_ensemble1.o \ + matmult.o \ + misc.o \ + mygetenv.o \ + parmread.o \ + pinorm.o \ + printmat.o \ + proc_proc.o \ + rescode.o \ + setup_var.o \ + slices.o \ + store_parm.o \ + timing.o \ + wham_calc1.o + +objects_compar = \ + readrtns_compar.o \ + readpdb.o fitsq.o contact.o \ + elecont.o contfunc.o cont_frag.o conf_compar.o match_contact.o \ + angnorm.o odlodc.o promienie.o qwolynes.o read_ref_str.o \ + rmscalc.o secondary.o proc_cont.o define_pairs.o mysort.o + +make_dbase: ${objects} ${objects_compar} + cc -o compinfo compinfo.c + ./compinfo + ${FC} -c ${FFLAGS} cinfo.f + $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o -Bstatic_pgi \ + ${LIBS} -o ${BIN}/wham_multparm-hamrep-sep + +clean: + /bin/rm *.o diff --git a/source/wham/src-NEWSC-NEWCORR/Makefile_matrix_PGI-SCT-oldparm b/source/wham/src-NEWSC-NEWCORR/Makefile_matrix_PGI-SCT-oldparm new file mode 100644 index 0000000..82001ca --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/Makefile_matrix_PGI-SCT-oldparm @@ -0,0 +1,76 @@ +INSTALL_DIR = /users/software/mpich-1.2.7p1_pgi_9.0_64bit_ssh +BIN = ../bin +CC = cc +FC = pgf90 +#FC = ifc +OPT = -mcmodel=medium -Mlarge_arrays -fast -pc 64 -tp amd64 +#OPT = -mcmodel=medium -Mlarge_arrays -tp amd64 +#FFLAGS = ${OPT} -g -c -I. -I./include_unres -I$(INSTALL_DIR)/include +#FFLAGS = ${OPT} -c -C -g -I. -I./include_unres -I$(INSTALL_DIR)/include +FFLAGS = ${OPT} -c -I. -I./include_unres -I$(INSTALL_DIR)/include +LIBS = -L$(INSTALL_DIR)/lib -lmpich -lpmpich xdrf/libxdrf.a +#LIBS = -L$(INSTALL_DIR)/lib_pgi -lmpich -lpmpich -Vaxlib +#CPPFLAGS = -DMPI -DLINUX -DUNRES -DMOMENT -DCHECKGRAD -DPGI +#CPPFLAGS = -DMPI -DLINUX -DUNRES -DCHECKGRAD -DPGI -DMYGETENV +CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DCRYST_BOND -DCRYST_SC -DCRYST_THETA -DFUNCT +#CPPFLAGS = -DMPI -DLINUX -DUNRES -DPGI +#CPPFLAGS = -DMPI -DLINUX -DUNRES + +.f.o: + ${FC} ${FFLAGS} $*.f + +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + +all: make_dbase + +objects = \ + wham_multparm.o \ + bxread.o \ + xread.o \ + cxread.o \ + enecalc1.o \ + energy_p_new.o \ + initialize_p.o \ + molread_zs.o \ + openunits.o \ + readrtns.o \ + arcos.o \ + cartder.o \ + cartprint.o \ + chainbuild.o \ + geomout.o \ + icant.o \ + intcor.o \ + int_from_cart.o \ + make_ensemble1.o \ + matmult.o \ + misc.o \ + mygetenv.o \ + parmread.o \ + pinorm.o \ + printmat.o \ + proc_proc.o \ + rescode.o \ + setup_var.o \ + slices.o \ + store_parm.o \ + timing.o \ + wham_calc1.o + +objects_compar = \ + readrtns_compar.o \ + readpdb.o fitsq.o contact.o \ + elecont.o contfunc.o cont_frag.o conf_compar.o match_contact.o \ + angnorm.o odlodc.o promienie.o qwolynes.o read_ref_str.o \ + rmscalc.o secondary.o proc_cont.o define_pairs.o mysort.o + +make_dbase: ${objects} ${objects_compar} + cc -o compinfo compinfo.c + ./compinfo + ${FC} -c ${FFLAGS} cinfo.f + $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o -Bstatic_pgi \ + ${LIBS} -o ${BIN}/wham_multparm-OPTERON-SCT-sccor-oldparm + +clean: + /bin/rm *.o diff --git a/source/wham/src-NEWSC-NEWCORR/Makefile_matrix_PGI-SCTF-oldparm b/source/wham/src-NEWSC-NEWCORR/Makefile_matrix_PGI-SCTF-oldparm new file mode 100644 index 0000000..66ebf03 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/Makefile_matrix_PGI-SCTF-oldparm @@ -0,0 +1,76 @@ +INSTALL_DIR = /users/software/mpich-1.2.7p1_pgi_9.0_64bit_ssh +BIN = ../bin +CC = cc +FC = pgf90 +#FC = ifc +OPT = -mcmodel=medium -Mlarge_arrays -fast -pc 64 -tp amd64 +#OPT = -mcmodel=medium -Mlarge_arrays -tp amd64 +#FFLAGS = ${OPT} -g -c -I. -I./include_unres -I$(INSTALL_DIR)/include +#FFLAGS = ${OPT} -c -C -g -I. -I./include_unres -I$(INSTALL_DIR)/include +FFLAGS = ${OPT} -c -I. -I./include_unres -I$(INSTALL_DIR)/include +LIBS = -L$(INSTALL_DIR)/lib -lmpich -lpmpich xdrf/libxdrf.a +#LIBS = -L$(INSTALL_DIR)/lib_pgi -lmpich -lpmpich -Vaxlib +#CPPFLAGS = -DMPI -DLINUX -DUNRES -DMOMENT -DCHECKGRAD -DPGI +#CPPFLAGS = -DMPI -DLINUX -DUNRES -DCHECKGRAD -DPGI -DMYGETENV +CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DCRYST_BOND -DCRYST_SC -DCRYST_THETA -DFUNCTH +#CPPFLAGS = -DMPI -DLINUX -DUNRES -DPGI +#CPPFLAGS = -DMPI -DLINUX -DUNRES + +.f.o: + ${FC} ${FFLAGS} $*.f + +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + +all: make_dbase + +objects = \ + wham_multparm.o \ + bxread.o \ + xread.o \ + cxread.o \ + enecalc1.o \ + energy_p_new.o \ + initialize_p.o \ + molread_zs.o \ + openunits.o \ + readrtns.o \ + arcos.o \ + cartder.o \ + cartprint.o \ + chainbuild.o \ + geomout.o \ + icant.o \ + intcor.o \ + int_from_cart.o \ + make_ensemble1.o \ + matmult.o \ + misc.o \ + mygetenv.o \ + parmread.o \ + pinorm.o \ + printmat.o \ + proc_proc.o \ + rescode.o \ + setup_var.o \ + slices.o \ + store_parm.o \ + timing.o \ + wham_calc1.o + +objects_compar = \ + readrtns_compar.o \ + readpdb.o fitsq.o contact.o \ + elecont.o contfunc.o cont_frag.o conf_compar.o match_contact.o \ + angnorm.o odlodc.o promienie.o qwolynes.o read_ref_str.o \ + rmscalc.o secondary.o proc_cont.o define_pairs.o mysort.o + +make_dbase: ${objects} ${objects_compar} + cc -o compinfo compinfo.c + ./compinfo + ${FC} -c ${FFLAGS} cinfo.f + $(FC) ${OPT} ${objects} ${objects_compar} -Bstatic_pgi cinfo.o \ + ${LIBS} -o ${BIN}/wham_multparm-OPTERON-SCTF-sccor-oldparm + +clean: + /bin/rm *.o diff --git a/source/wham/src-NEWSC-NEWCORR/Makefile_matrix_PGI-oldparm b/source/wham/src-NEWSC-NEWCORR/Makefile_matrix_PGI-oldparm new file mode 100644 index 0000000..1c9d56b --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/Makefile_matrix_PGI-oldparm @@ -0,0 +1,76 @@ +INSTALL_DIR = /usr/local/mpich-1.2.7p1_pgi64-6.2-3_ssh +BIN = ../bin +CC = cc +FC = pgf90 +#FC = ifc +OPT = -mcmodel=medium -Mlarge_arrays -fast -pc 64 -tp amd64 +#OPT = -mcmodel=medium -Mlarge_arrays -tp amd64 +#FFLAGS = ${OPT} -g -c -I. -I./include_unres -I$(INSTALL_DIR)/include +#FFLAGS = ${OPT} -c -C -g -I. -I./include_unres -I$(INSTALL_DIR)/include +FFLAGS = ${OPT} -c -I. -I./include_unres -I$(INSTALL_DIR)/include +LIBS = -L$(INSTALL_DIR)/lib -lmpich -lpmpich xdrf/libxdrf.a +#LIBS = -L$(INSTALL_DIR)/lib_pgi -lmpich -lpmpich -Vaxlib +#CPPFLAGS = -DMPI -DLINUX -DUNRES -DMOMENT -DCHECKGRAD -DPGI +#CPPFLAGS = -DMPI -DLINUX -DUNRES -DCHECKGRAD -DPGI -DMYGETENV +CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DCRYST_BOND -DCRYST_SC -DCRYST_THETA +#CPPFLAGS = -DMPI -DLINUX -DUNRES -DPGI +#CPPFLAGS = -DMPI -DLINUX -DUNRES + +.f.o: + ${FC} ${FFLAGS} $*.f + +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + +all: make_dbase + +objects = \ + wham_multparm.o \ + bxread.o \ + xread.o \ + cxread.o \ + enecalc1.o \ + energy_p_new.o \ + initialize_p.o \ + molread_zs.o \ + openunits.o \ + readrtns.o \ + arcos.o \ + cartder.o \ + cartprint.o \ + chainbuild.o \ + geomout.o \ + icant.o \ + intcor.o \ + int_from_cart.o \ + make_ensemble1.o \ + matmult.o \ + misc.o \ + mygetenv.o \ + parmread.o \ + pinorm.o \ + printmat.o \ + proc_proc.o \ + rescode.o \ + setup_var.o \ + slices.o \ + store_parm.o \ + timing.o \ + wham_calc1.o + +objects_compar = \ + readrtns_compar.o \ + readpdb.o fitsq.o contact.o \ + elecont.o contfunc.o cont_frag.o conf_compar.o match_contact.o \ + angnorm.o odlodc.o promienie.o qwolynes.o read_ref_str.o \ + rmscalc.o secondary.o proc_cont.o define_pairs.o mysort.o + +make_dbase: ${objects} ${objects_compar} + cc -o compinfo compinfo.c + ./compinfo + ${FC} -c ${FFLAGS} cinfo.f + $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ + ${LIBS} -o ${BIN}/wham_multparm-OPTERON-SCTF-sccor-oldparm + +clean: + /bin/rm *.o diff --git a/source/wham/src-NEWSC-NEWCORR/a.sh b/source/wham/src-NEWSC-NEWCORR/a.sh new file mode 100644 index 0000000..00b1548 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/a.sh @@ -0,0 +1,9 @@ +a=1 +echo $a +while [ $a -lt 10 ] +do + a=`expr $a + 1` +done +echo $a +b=`expr $a / 5` +echo a=$a b=$b diff --git a/source/wham/src-NEWSC-NEWCORR/angnorm.f b/source/wham/src-NEWSC-NEWCORR/angnorm.f new file mode 100644 index 0000000..2d17942 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/angnorm.f @@ -0,0 +1,439 @@ + subroutine add_angpair(ici,icj,nang_pair,iang_pair) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + integer ici,icj,nang_pair,iang_pair(2,maxres) + integer i,ian1,ian2 +c write (iout,*) "add_angpair: ici",ici," icj",icj, +c & " nang_pair",nang_pair + ian1=ici+2 + if (ian1.lt.4 .or. ian1.gt.nres) return + ian2=icj+2 +c write (iout,*) "ian1",ian1," ian2",ian2 + if (ian2.lt.4 .or. ian2.gt.nres) return + do i=1,nang_pair + if (ian1.eq.iang_pair(1,i) .and. ian2.eq.iang_pair(2,i)) return + enddo + nang_pair=nang_pair+1 + iang_pair(1,nang_pair)=ian1 + iang_pair(2,nang_pair)=ian2 + return + end +c------------------------------------------------------------------------- + subroutine angnorm(jfrag,ishif1,ishif2,diffang_max,angn,fract, + & lprn) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.COMPAR' + include 'COMMON.IOUNITS' + include 'COMMON.VAR' + include 'COMMON.COMPAR' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + double precision pinorm,deltang + logical lprn + if (lprn) write (iout,'(80(1h*))') + angn=0.0d0 + nn = 0 + fract = 1.0d0 + npart = npiece(jfrag,1) + nn4 = nstart_sup+3 + nne = min0(nend_sup,nres) + if (lprn) write (iout,*) "nn4",nn4," nne",nne + do i=1,npart + nbeg = ifrag(1,i,jfrag) + 3 - ishif1 + if (nbeg.lt.nn4) nbeg=nn4 + nend = ifrag(2,i,jfrag) + 1 - ishif2 + if (nend.gt.nne) nend=nne + if (nend.ge.nbeg) then + nn = nn + nend - nbeg + 1 + if (lprn) write (iout,*) "i=",i," nbeg",nbeg," nend",nend, + & " nn",nn," ishift1",ishif1," ishift2",ishif2 + if (lprn) write (iout,*) "angles" + longest=0 + ll = 0 + do j=nbeg,nend +c deltang = pinorm(phi(j)-phi_ref(j+ishif1)) + deltang=spherang(phi_ref(j+ishif1),theta_ref(j-1+ishif1), + & theta_ref(j+ishif1),phi(j),theta(j-1),theta(j)) + if (dabs(deltang).gt.diffang_max) then + if (ll.gt.longest) longest = ll + ll = 0 + else + ll=ll+1 + endif + if (ll.gt.longest) longest = ll + if (lprn) write (iout,'(i5,3f10.5)')j,rad2deg*phi(j), + & rad2deg*phi_ref(j+ishif1),rad2deg*deltang + angn=angn+dabs(deltang) + enddo + longest=longest+3 + ff = dfloat(longest)/dfloat(nend - nbeg + 4) + if (lprn) write (iout,*)"segment",i," longest fragment within", + & diffang_max*rad2deg,":",longest," fraction",ff + if (ff.lt.fract) fract = ff + endif + enddo + if (nn.gt.0) then + angn = angn/nn + else + angn = dwapi + endif + if (lprn) write (iout,*) "nn",nn," norm",rad2deg*angn, + & " fract",fract + return + end +c------------------------------------------------------------------------- + subroutine angnorm2(jfrag,ishif1,ishif2,ncont,icont,lprn, + & diffang_max,anorm,fract) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.COMPAR' + include 'COMMON.IOUNITS' + include 'COMMON.VAR' + include 'COMMON.COMPAR' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + integer ncont,icont(2,ncont),longest + double precision anorm,diffang_max,fract + integer npiece_c,ifrag_c(2,maxpiece),ishift_c(maxpiece) + double precision pinorm + logical lprn + if (lprn) write (iout,'(80(1h*))') +c +c Determine the segments for which angles will be compared +c + nn4 = nstart_sup+3 + nne = min0(nend_sup,nres) + if (lprn) write (iout,*) "nn4",nn4," nne",nne + npart=npiece(jfrag,1) + npiece_c=0 + do i=1,npart +c write (iout,*) "i",i," ifrag",ifrag(1,i,jfrag),ifrag(2,i,jfrag) + if (icont(1,ncont).lt.ifrag(1,i,jfrag) .or. + & icont(1,1).gt.ifrag(2,i,jfrag)) goto 11 + jstart=1 + do while (jstart.lt.ncont .and. + & icont(1,jstart).lt.ifrag(1,i,jfrag)) +c write (iout,*) "jstart",jstart," icont",icont(1,jstart), +c & " ifrag",ifrag(1,i,jfrag) + jstart=jstart+1 + enddo +c write (iout,*) "jstart",jstart," icont",icont(1,jstart), +c & " ifrag",ifrag(1,i,jfrag) + if (icont(1,jstart).lt.ifrag(1,i,jfrag)) goto 11 + npiece_c=npiece_c+1 + ic1=icont(1,jstart) + ifrag_c(1,npiece_c)=icont(1,jstart) + jend=ncont + do while (jend.gt.1 .and. icont(1,jend).gt.ifrag(2,i,jfrag)) +c write (iout,*) "jend",jend," icont",icont(1,jend), +c & " ifrag",ifrag(2,i,jfrag) + jend=jend-1 + enddo +c write (iout,*) "jend",jend," icont",icont(1,jend), +c & " ifrag",ifrag(2,i,jfrag) + ic2=icont(1,jend) + ifrag_c(2,npiece_c)=icont(1,jend)+1 + ishift_c(npiece_c)=ishif1 +c write (iout,*) "1: i",i," jstart:",jstart," jend",jend, +c & " ic1",ic1," ic2",ic2, +c & " ifrag",ifrag(1,i,jfrag),ifrag(2,i,jfrag) + 11 continue + if (ncont.eq.1 .or. icont(2,ncont).gt.icont(2,1)) then + idi=1 + else + idi=-1 + endif +c write (iout,*) "idi",idi + if (idi.eq.1) then + if (icont(2,1).gt.ifrag(2,i,jfrag) .or. + & icont(2,ncont).lt.ifrag(1,i,jfrag)) goto 12 + jstart=1 + do while (jstart.lt.ncont .and. + & icont(2,jstart).lt.ifrag(1,i,jfrag)) +c write (iout,*) "jstart",jstart," icont",icont(2,jstart), +c & " ifrag",ifrag(1,i,jfrag) + jstart=jstart+1 + enddo +c write (iout,*) "jstart",jstart," icont",icont(2,jstart), +c & " ifrag",ifrag(1,i,jfrag) + if (icont(2,jstart).lt.ifrag(1,i,jfrag)) goto 12 + npiece_c=npiece_c+1 + ic1=icont(2,jstart) + ifrag_c(2,npiece_c)=icont(2,jstart)+1 + jend=ncont + do while (jend.gt.1 .and. icont(2,jend).gt.ifrag(2,i,jfrag)) +c write (iout,*) "jend",jend," icont",icont(2,jend), +c & " ifrag",ifrag(2,i,jfrag) + jend=jend-1 + enddo +c write (iout,*) "jend",jend," icont",icont(2,jend), +c & " ifrag",ifrag(2,i,jfrag) + else if (idi.eq.-1) then + if (icont(2,ncont).gt.ifrag(2,i,jfrag) .or. + & icont(2,1).lt.ifrag(1,i,jfrag)) goto 12 + jstart=ncont + do while (jstart.gt.ncont .and. + & icont(2,jstart).lt.ifrag(1,i,jfrag)) +c write (iout,*) "jstart",jstart," icont",icont(2,jstart), +c & " ifrag",ifrag(1,i,jfrag) + jstart=jstart-1 + enddo +c write (iout,*) "jstart",jstart," icont",icont(2,jstart), +c & " ifrag",ifrag(1,i,jfrag) + if (icont(2,jstart).lt.ifrag(1,i,jfrag)) goto 12 + npiece_c=npiece_c+1 + ic1=icont(2,jstart) + ifrag_c(2,npiece_c)=icont(2,jstart)+1 + jend=1 + do while (jend.lt.ncont .and. + & icont(2,jend).gt.ifrag(2,i,jfrag)) +c write (iout,*) "jend",jend," icont",icont(2,jend), +c & " ifrag",ifrag(2,i,jfrag) + jend=jend+1 + enddo +c write (iout,*) "jend",jend," icont",icont(2,jend), +c & " ifrag",ifrag(2,i,jfrag) + endif + ic2=icont(2,jend) + if (ic2.lt.ic1) then + iic = ic1 + ic1 = ic2 + ic2 = iic + endif +c write (iout,*) "2: i",i," ic1",ic1," ic2",ic2, +c & " jstart:",jstart," jend",jend, +c & " ifrag",ifrag(1,i,jfrag),ifrag(2,i,jfrag) + ifrag_c(1,npiece_c)=ic1 + ifrag_c(2,npiece_c)=ic2+1 + ishift_c(npiece_c)=ishif2 + 12 continue + enddo + if (lprn) then + write (iout,*) "Before merge: npiece_c",npiece_c + do i=1,npiece_c + write (iout,*) ifrag_c(1,i),ifrag_c(2,i),ishift_c(i) + enddo + endif +c +c Merge overlapping segments (e.g., avoid splitting helices) +c + i=1 + do while (i .lt. npiece_c) + if (ishift_c(i).eq.ishift_c(i+1) .and. + & ifrag_c(2,i).gt.ifrag_c(1,i+1)) then + ifrag_c(2,i)=ifrag_c(2,i+1) + do j=i+1,npiece_c + ishift_c(j)=ishift_c(j+1) + ifrag_c(1,j)=ifrag_c(1,j+1) + ifrag_c(2,j)=ifrag_c(2,j+1) + enddo + npiece_c=npiece_c-1 + else + i=i+1 + endif + enddo + if (lprn) then + write (iout,*) "After merge: npiece_c",npiece_c + do i=1,npiece_c + write (iout,*) ifrag_c(1,i),ifrag_c(2,i),ishift_c(i) + enddo + endif +c +c Compare angles +c + angn=0.0d0 + anorm=0 + nn = 0 + fract = 1.0d0 + npart = npiece_c + do i=1,npart + ishifc=ishift_c(i) + nbeg = ifrag_c(1,i) + 3 - ishifc + if (nbeg.lt.nn4) nbeg=nn4 + nend = ifrag_c(2,i) - ishifc + 1 + if (nend.gt.nne) nend=nne + if (nend.ge.nbeg) then + nn = nn + nend - nbeg + 1 + if (lprn) write (iout,*) "i=",i," nbeg",nbeg," nend",nend, + & " nn",nn," ishifc",ishifc + if (lprn) write (iout,*) "angles" + longest=0 + ll = 0 + do j=nbeg,nend +c deltang = pinorm(phi(j)-phi_ref(j+ishifc)) + deltang=spherang(phi_ref(j+ishifc),theta_ref(j-1+ishifc), + & theta_ref(j+ishifc),phi(j),theta(j-1),theta(j)) + if (dabs(deltang).gt.diffang_max) then + if (ll.gt.longest) longest = ll + ll = 0 + else + ll=ll+1 + endif + if (ll.gt.longest) longest = ll + if (lprn) write (iout,'(i5,3f10.5)')j,rad2deg*phi(j), + & rad2deg*phi_ref(j+ishifc),rad2deg*deltang + angn=angn+dabs(deltang) + enddo + longest=longest+3 + ff = dfloat(longest)/dfloat(nend - nbeg + 4) + if (lprn) write (iout,*)"segment",i," longest fragment within", + & diffang_max*rad2deg,":",longest," fraction",ff + if (ff.lt.fract) fract = ff + endif + enddo + if (nn.gt.0) anorm = angn/nn + if (lprn) write (iout,*) "nn",nn," norm",anorm," fract:",fract + return + end +c------------------------------------------------------------------------- + double precision function angnorm1(nang_pair,iang_pair,lprn) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.COMPAR' + include 'COMMON.IOUNITS' + include 'COMMON.VAR' + include 'COMMON.COMPAR' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + logical lprn + integer nang_pair,iang_pair(2,maxres) + double precision pinorm + angn=0.0d0 + if (lprn) write (iout,'(80(1h*))') + if (lprn) write (iout,*) "nang_pair",nang_pair + if (lprn) write (iout,*) "angles" + do j=1,nang_pair + ia1 = iang_pair(1,j) + ia2 = iang_pair(2,j) +c deltang = pinorm(phi(ia1)-phi_ref(ia2)) + deltang=spherang(phi_ref(ia2),theta_ref(ia2-1), + & theta_ref(ia2),phi(ia2),theta(ia2-1),theta(ia2)) + if (lprn) write (iout,'(3i5,3f10.5)')j,ia1,ia2,rad2deg*phi(ia1), + & rad2deg*phi_ref(ia2),rad2deg*deltang + angn=angn+dabs(deltang) + enddo + if (lprn) + &write (iout,*)"nang_pair",nang_pair," angn",rad2deg*angn/nang_pair + angnorm1 = angn/nang_pair + return + end +c------------------------------------------------------------------------------ + subroutine angnorm12(diff) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.COMPAR' + include 'COMMON.IOUNITS' + include 'COMMON.VAR' + include 'COMMON.COMPAR' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + double precision pinorm + diff=0.0d0 + nn4 = nstart_sup+3 + nne = min0(nend_sup,nres) +c do j=nn4-1,nne +c diff = diff+rad2deg*dabs(pinorm(theta(j)-theta_ref(j))) +c enddo + do j=nn4,nne +c diff = diff+rad2deg*dabs(pinorm(phi(j)-phi_ref(j))) + diff=diff+spherang(phi_ref(j),theta_ref(j-1), + & theta_ref(j),phi(j),theta(j-1),theta(j)) + enddo + return + end +c-------------------------------------------------------------------------------- + double precision function spherang(gam1,theta11,theta12, + & gam2,theta21,theta22) + implicit none + double precision gam1,theta11,theta12,gam2,theta21,theta22, + & x1,x2,xmed,f1,f2,fmed + double precision tolx /1.0d-4/, tolf /1.0d-4/ + double precision sumcos + double precision arcos,pinorm,sumangp + integer it,maxit /100/ +c Calculate the difference of the angles of two superposed 4-redidue fragments +c +c O P +c \ / +c O'--C--C +c \ +c P' +c +c The fragment O'-C-C-P' is rotated by angle fi about the C-C axis +c to achieve the minimum difference between the O'-C-O and P-C-P angles; +c the sum of these angles is the difference returned by the function. +c +c 4/28/04 AL +c If thetas match, take the difference of gamma and exit. + if (dabs(theta11-theta12).lt.tolx + & .and. dabs(theta21-theta22).lt.tolx) then + spherang=dabs(pinorm(gam2-gam1)) + return + endif +c If the gammas are the same, take the difference of thetas and exit. + x1=0.0d0 + x2=0.5d0*pinorm(gam2-gam1) + if (dabs(x2) .lt. tolx) then + spherang=dabs(theta11-theta21)+dabs(theta12-theta22) + return + else if (x2.lt.0.0d0) then + x1=x2 + x2=0.0d0 + endif +c Else apply regula falsi method to compute optimum overlap of the terminal Calphas + f1=sumangp(gam1,theta11,theta12,gam2,theta21,theta22,x1) + f2=sumangp(gam1,theta11,theta12,gam2,theta21,theta22,x2) + do it=1,maxit + xmed=x1-f1*(x2-x1)/(f2-f1) + fmed=sumangp(gam1,theta11,theta12,gam2,theta21,theta22,xmed) +c write (*,*) 'it',it,' xmed ',xmed,' fmed ',fmed + if ( (dabs(xmed-x1).lt.tolx .or. dabs(x2-xmed).lt.tolx) + & .and. dabs(fmed).lt.tolf ) then + x1=xmed + f1=fmed + goto 10 + else if ( fmed*f1.lt.0.0d0 ) then + x2=xmed + f2=fmed + else + x1=xmed + f1=fmed + endif + enddo + 10 continue + spherang=arcos(dcos(theta11)*dcos(theta12) + & +dsin(theta11)*dsin(theta12)*dcos(x1))+ + & arcos(dcos(theta21)*dcos(theta22)+ + & dsin(theta21)*dsin(theta22)*dcos(gam2-gam1+x1)) + return + end +c-------------------------------------------------------------------------------- + double precision function sumangp(gam1,theta11,theta12,gam2, + & theta21,theta22,fi) + implicit none + double precision gam1,theta11,theta12,gam2,theta21,theta22,fi, + & cost11,cost12,cost21,cost22,sint11,sint12,sint21,sint22,cosd1, + & cosd2 +c derivarive of the sum of the difference of the angles of a 4-residue fragment. + double precision arcos + cost11=dcos(theta11) + cost12=dcos(theta12) + cost21=dcos(theta21) + cost22=dcos(theta22) + sint11=dsin(theta11) + sint12=dsin(theta12) + sint21=dsin(theta21) + sint22=dsin(theta22) + cosd1=cost11*cost12+sint11*sint12*dcos(fi) + cosd2=cost21*cost22+sint21*sint22*dcos(gam2-gam1+fi) + sumangp=sint11*sint12*dsin(fi)/dsqrt(1.0d0-cosd1*cosd1) + & +sint21*sint22*dsin(gam2-gam1+fi)/dsqrt(1.0d0-cosd2*cosd2) + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/arcos.f b/source/wham/src-NEWSC-NEWCORR/arcos.f new file mode 100644 index 0000000..69810ea --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/arcos.f @@ -0,0 +1,9 @@ + FUNCTION ARCOS(X) + implicit real*8 (a-h,o-z) + include 'COMMON.GEO' + IF (DABS(X).LT.1.0D0) GOTO 1 + ARCOS=0.5D0*(PI+DSIGN(1.0D0,X)*PI) + RETURN + 1 ARCOS=DACOS(X) + RETURN + END diff --git a/source/wham/src-NEWSC-NEWCORR/bxread.F b/source/wham/src-NEWSC-NEWCORR/bxread.F new file mode 100644 index 0000000..c459499 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/bxread.F @@ -0,0 +1,89 @@ + subroutine bxread(nazwa,islice,ii,jj,kk,ll,mm,iR,ib,iparm) + implicit none + include "DIMENSIONS" + include "DIMENSIONS.ZSCOPT" + include "DIMENSIONS.FREE" +#ifdef MPI + include "mpif.h" + integer IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE) + include "COMMON.MPI" +#endif + include "COMMON.CHAIN" + include "COMMON.IOUNITS" + include "COMMON.PROTFILES" + include "COMMON.NAMES" + include "COMMON.VAR" + include "COMMON.GEO" + include "COMMON.ENEPS" + include "COMMON.PROT" + include "COMMON.INTERACT" + include "COMMON.FREE" + include "COMMON.SBRIDGE" + real*4 csingle(3,maxres2) + character*64 nazwa,bprotfile_temp + character*3 liczba + integer i,is,ie,j,ii,jj,k,kk,l,ll,mm,if + integer nrec,nlines,iscor,islice + double precision energ + integer ilen,iroof + external ilen,iroof + double precision rmsdev,energia(0:max_ene),efree,eini,temp + double precision prop(maxQ) + integer ntot_all(0:maxprocs-1) + integer iparm,ib,iib,ir,nprop,nthr,nrec_slice + double precision etot,time + logical lerr + nrec_slice=(rec_end(iR,ib,iparm)-rec_start(iR,ib,iparm)+1)/nslice + is=rec_start(iR,ib,iparm)+(islice-1)*nrec_slice + ie=rec_start(iR,ib,iparm)+islice*nrec_slice-1 + write (iout,*) "bxread: islice",islice," nslice",nslice, + & " nrec_slice",nrec_slice + write (iout,*) "is",is," ie",ie,"rec_start", + & rec_start(iR,ib,iparm)," rec_end",rec_end(iR,ib,iparm) + do i=is,ie + read(ientin,rec=i+1,err=101) + & ((csingle(l,k),l=1,3),k=1,nres), + & ((csingle(l,k+nres),l=1,3),k=nnt,nct), + & nss,(ihpb(k),jhpb(k),k=1,nss), + & eini,efree,rmsdev,(prop(j),j=1,nQ),iscor + ii=ii+1 + kk=kk+1 + if (mod(kk,isampl(iparm)).eq.0) then + jj=jj+1 + write(ientout,rec=jj) + & ((csingle(l,k),l=1,3),k=1,nres), + & ((csingle(l,k+nres),l=1,3),k=nnt,nct), + & nss,(ihpb(k),jhpb(k),k=1,nss), + & eini,efree,rmsdev,(prop(j),j=1,nQ),iR,ib,iparm +#ifdef DEBUG + do i=1,2*nres + do j=1,3 + c(j,i)=csingle(j,i) + enddo + enddo + call int_from_cart1(.false.) + write (iout,*) "Writing conformation, record",jj + write (iout,*) "Cartesian coordinates" + write (iout,'(8f10.5)') ((c(j,i),j=1,3),i=1,nres) + write (iout,'(8f10.5)') ((c(j,i+nres),j=1,3),i=nnt,nct) + write (iout,*) "Internal coordinates" + write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) + write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) + write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) + write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) + write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) + write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) + write (iout,'(16i5)') nss,(ihpb(k),jhpb(k),k=1,nss) + write (iout,'(f10.5,i5)') rmsdev,iscor +#endif + endif + enddo + 101 continue + close(ientin) + write (iout,*) ii," conformations read from DA file ", + & nazwa(:ilen(nazwa)) + write (iout,*) kk," conformations read so far, slice",islice + write (iout,*) jj," conformations stored so far, slice",islice + + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/cartder.f b/source/wham/src-NEWSC-NEWCORR/cartder.f new file mode 100644 index 0000000..ed14f18 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/cartder.f @@ -0,0 +1,306 @@ + subroutine cartder + implicit real*8 (a-h,o-z) +*********************************************************************** +* This subroutine calculates the derivatives of the consecutive virtual +* bond vectors and the SC vectors in the virtual-bond angles theta and +* virtual-torsional angles phi, as well as the derivatives of SC vectors +* in the angles alpha and omega, describing the location of a side chain +* in its local coordinate system. +* +* The derivatives are stored in the following arrays: +* +* DDCDV - the derivatives of virtual-bond vectors DC in theta and phi. +* The structure is as follows: +* +* dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0, 0, 0 +* dDC(x,3)/dT(4),...,dDC(z,3)/dT(4),dDC(x,3)/dP(4),dDC(y,4)/dP(4),dDC(z,4)/dP(4) +* . . . . . . . . . . . . . . . . . . +* dDC(x,N-1)/dT(4),...,dDC(z,N-1)/dT(4),dDC(x,N-1)/dP(4),dDC(y,N-1)/dP(4),dDC(z,N-1)/dP(4) +* . +* . +* . +* dDC(x,N-1)/dT(N),...,dDC(z,N-1)/dT(N),dDC(x,N-1)/dP(N),dDC(y,N-1)/dP(N),dDC(z,N-1)/dP(N) +* +* DXDV - the derivatives of the side-chain vectors in theta and phi. +* The structure is same as above. +* +* DCDS - the derivatives of the side chain vectors in the local spherical +* andgles alph and omega: +* +* dX(x,2)/dA(2),dX(y,2)/dA(2),dX(z,2)/dA(2),dX(x,2)/dO(2),dX(y,2)/dO(2),dX(z,2)/dO(2) +* dX(x,3)/dA(3),dX(y,3)/dA(3),dX(z,3)/dA(3),dX(x,3)/dO(3),dX(y,3)/dO(3),dX(z,3)/dO(3) +* . +* . +* . +* dX(x,N-1)/dA(N-1),dX(y,N-1)/dA(N-1),dX(z,N-1)/dA(N-1),dX(x,N-1)/dO(N-1),dX(y,N-1)/dO(N-1),dX(z,N-1)/dO(N-1) +* +* Version of March '95, based on an early version of November '91. +* +*********************************************************************** + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + dimension drt(3,3,maxres),rdt(3,3,maxres),dp(3,3),temp(3,3), + & fromto(3,3,maxdim),prordt(3,3,maxres),prodrt(3,3,maxres) + dimension xx(3),xx1(3) +* get the position of the jth ijth fragment of the chain coordinate system +* in the fromto array. + indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1 +* +* calculate the derivatives of transformation matrix elements in theta +* + do i=1,nres-2 + rdt(1,1,i)=-rt(1,2,i) + rdt(1,2,i)= rt(1,1,i) + rdt(1,3,i)= 0.0d0 + rdt(2,1,i)=-rt(2,2,i) + rdt(2,2,i)= rt(2,1,i) + rdt(2,3,i)= 0.0d0 + rdt(3,1,i)=-rt(3,2,i) + rdt(3,2,i)= rt(3,1,i) + rdt(3,3,i)= 0.0d0 + enddo +* +* derivatives in phi +* + do i=2,nres-2 + drt(1,1,i)= 0.0d0 + drt(1,2,i)= 0.0d0 + drt(1,3,i)= 0.0d0 + drt(2,1,i)= rt(3,1,i) + drt(2,2,i)= rt(3,2,i) + drt(2,3,i)= rt(3,3,i) + drt(3,1,i)=-rt(2,1,i) + drt(3,2,i)=-rt(2,2,i) + drt(3,3,i)=-rt(2,3,i) + enddo +* +* generate the matrix products of type r(i)t(i)...r(j)t(j) +* + do i=2,nres-2 + ind=indmat(i,i+1) + do k=1,3 + do l=1,3 + temp(k,l)=rt(k,l,i) + enddo + enddo + do k=1,3 + do l=1,3 + fromto(k,l,ind)=temp(k,l) + enddo + enddo + do j=i+1,nres-2 + ind=indmat(i,j+1) + do k=1,3 + do l=1,3 + dpkl=0.0d0 + do m=1,3 + dpkl=dpkl+temp(k,m)*rt(m,l,j) + enddo + dp(k,l)=dpkl + fromto(k,l,ind)=dpkl + enddo + enddo + do k=1,3 + do l=1,3 + temp(k,l)=dp(k,l) + enddo + enddo + enddo + enddo +* +* Calculate derivatives. +* + ind1=0 + do i=1,nres-2 + ind1=ind1+1 +* +* Derivatives of DC(i+1) in theta(i+2) +* + do j=1,3 + do k=1,2 + dpjk=0.0D0 + do l=1,3 + dpjk=dpjk+prod(j,l,i)*rdt(l,k,i) + enddo + dp(j,k)=dpjk + prordt(j,k,i)=dp(j,k) + enddo + dp(j,3)=0.0D0 + dcdv(j,ind1)=vbl*dp(j,1) + enddo +* +* Derivatives of SC(i+1) in theta(i+2) +* + xx1(1)=-0.5D0*xloc(2,i+1) + xx1(2)= 0.5D0*xloc(1,i+1) + do j=1,3 + xj=0.0D0 + do k=1,2 + xj=xj+r(j,k,i)*xx1(k) + enddo + xx(j)=xj + enddo + do j=1,3 + rj=0.0D0 + do k=1,3 + rj=rj+prod(j,k,i)*xx(k) + enddo + dxdv(j,ind1)=rj + enddo +* +* Derivatives of SC(i+1) in theta(i+3). The have to be handled differently +* than the other off-diagonal derivatives. +* + do j=1,3 + dxoiij=0.0D0 + do k=1,3 + dxoiij=dxoiij+dp(j,k)*xrot(k,i+2) + enddo + dxdv(j,ind1+1)=dxoiij + enddo +cd print *,ind1+1,(dxdv(j,ind1+1),j=1,3) +* +* Derivatives of DC(i+1) in phi(i+2) +* + do j=1,3 + do k=1,3 + dpjk=0.0 + do l=2,3 + dpjk=dpjk+prod(j,l,i)*drt(l,k,i) + enddo + dp(j,k)=dpjk + prodrt(j,k,i)=dp(j,k) + enddo + dcdv(j+3,ind1)=vbl*dp(j,1) + enddo +* +* Derivatives of SC(i+1) in phi(i+2) +* + xx(1)= 0.0D0 + xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i) + xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i) + do j=1,3 + rj=0.0D0 + do k=2,3 + rj=rj+prod(j,k,i)*xx(k) + enddo + dxdv(j+3,ind1)=-rj + enddo +* +* Derivatives of SC(i+1) in phi(i+3). +* + do j=1,3 + dxoiij=0.0D0 + do k=1,3 + dxoiij=dxoiij+dp(j,k)*xrot(k,i+2) + enddo + dxdv(j+3,ind1+1)=dxoiij + enddo +* +* Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru +* theta(nres) and phi(i+3) thru phi(nres). +* + do j=i+1,nres-2 + ind1=ind1+1 + ind=indmat(i+1,j+1) +cd print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1 + do k=1,3 + do l=1,3 + tempkl=0.0D0 + do m=1,2 + tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind) + enddo + temp(k,l)=tempkl + enddo + enddo +cd print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3) +cd print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3) +cd print '(9f8.3)',((temp(k,l),l=1,3),k=1,3) +* Derivatives of virtual-bond vectors in theta + do k=1,3 + dcdv(k,ind1)=vbl*temp(k,1) + enddo +cd print '(3f8.3)',(dcdv(k,ind1),k=1,3) +* Derivatives of SC vectors in theta + do k=1,3 + dxoijk=0.0D0 + do l=1,3 + dxoijk=dxoijk+temp(k,l)*xrot(l,j+2) + enddo + dxdv(k,ind1+1)=dxoijk + enddo +* +*--- Calculate the derivatives in phi +* + do k=1,3 + do l=1,3 + tempkl=0.0D0 + do m=1,3 + tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind) + enddo + temp(k,l)=tempkl + enddo + enddo + do k=1,3 + dcdv(k+3,ind1)=vbl*temp(k,1) + enddo + do k=1,3 + dxoijk=0.0D0 + do l=1,3 + dxoijk=dxoijk+temp(k,l)*xrot(l,j+2) + enddo + dxdv(k+3,ind1+1)=dxoijk + enddo + enddo + enddo +* +* Derivatives in alpha and omega: +* + do i=2,nres-1 + dsci=dsc(itype(i)) + alphi=alph(i) + omegi=omeg(i) +cd print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi + cosalphi=dcos(alphi) + sinalphi=dsin(alphi) + cosomegi=dcos(omegi) + sinomegi=dsin(omegi) + temp(1,1)=-dsci*sinalphi + temp(2,1)= dsci*cosalphi*cosomegi + temp(3,1)=-dsci*cosalphi*sinomegi + temp(1,2)=0.0D0 + temp(2,2)=-dsci*sinalphi*sinomegi + temp(3,2)=-dsci*sinalphi*cosomegi + theta2=pi-0.5D0*theta(i+1) + cost2=dcos(theta2) + sint2=dsin(theta2) + jjj=0 +cd print *,((temp(l,k),l=1,3),k=1,2) + do j=1,2 + xp=temp(1,j) + yp=temp(2,j) + xxp= xp*cost2+yp*sint2 + yyp=-xp*sint2+yp*cost2 + zzp=temp(3,j) + xx(1)=xxp + xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1) + xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1) + do k=1,3 + dj=0.0D0 + do l=1,3 + dj=dj+prod(k,l,i-1)*xx(l) + enddo + dxds(jjj+k,i)=dj + enddo + jjj=jjj+3 + enddo + enddo + return + end + diff --git a/source/wham/src-NEWSC-NEWCORR/cartprint.f b/source/wham/src-NEWSC-NEWCORR/cartprint.f new file mode 100644 index 0000000..fd8ffe3 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/cartprint.f @@ -0,0 +1,20 @@ + subroutine cartprint + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + write (iout,100) + do i=1,nres + write (iout,110) restyp(itype(i)),i,c(1,i),c(2,i), + & c(3,i),c(1,nres+i),c(2,nres+i),c(3,nres+i) + enddo + 100 format (//' alpha-carbon coordinates ', + & ' centroid coordinates'/ + 1 ' ', 6X,'X',11X,'Y',11X,'Z', + & 10X,'X',11X,'Y',11X,'Z') + 110 format (a,'(',i3,')',6f12.5) + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/chainbuild.F b/source/wham/src-NEWSC-NEWCORR/chainbuild.F new file mode 100644 index 0000000..4c9f32f --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/chainbuild.F @@ -0,0 +1,281 @@ + subroutine chainbuild +C +C Build the virtual polypeptide chain. Side-chain centroids are moveable. +C As of 2/17/95. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.CHAIN' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.INTERACT' + logical lprn +C Set lprn=.true. for debugging + lprn = .false. +C +C Define the origin and orientation of the coordinate system and locate the +C first three CA's and SC(2). +C + call orig_frame +* +* Build the alpha-carbon chain. +* + do i=4,nres + call locate_next_res(i) + enddo +C +C First and last SC must coincide with the corresponding CA. +C + do j=1,3 + dc(j,nres+1)=0.0D0 + dc_norm(j,nres+1)=0.0D0 + dc(j,nres+nres)=0.0D0 + dc_norm(j,nres+nres)=0.0D0 + c(j,nres+1)=c(j,1) + c(j,nres+nres)=c(j,nres) + enddo +* +* Temporary diagnosis +* + if (lprn) then + + call cartprint + write (iout,'(/a)') 'Recalculated internal coordinates' + do i=2,nres-1 + do j=1,3 + c(j,maxres2)=0.5D0*(c(j,i-1)+c(j,i+1)) + enddo + be=0.0D0 + if (i.gt.3) be=rad2deg*beta(i-3,i-2,i-1,i) + be1=rad2deg*beta(nres+i,i,maxres2,i+1) + alfai=0.0D0 + if (i.gt.2) alfai=rad2deg*alpha(i-2,i-1,i) + write (iout,1212) restyp(itype(i)),i,dist(i-1,i), + & alfai,be,dist(nres+i,i),rad2deg*alpha(nres+i,i,maxres2),be1 + enddo + 1212 format (a3,'(',i3,')',2(f10.5,2f10.2)) + + endif + + return + end +c------------------------------------------------------------------------- + subroutine orig_frame +C +C Define the origin and orientation of the coordinate system and locate +C the first three atoms. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.CHAIN' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + include 'COMMON.VAR' + cost=dcos(theta(3)) + sint=dsin(theta(3)) + t(1,1,1)=-cost + t(1,2,1)=-sint + t(1,3,1)= 0.0D0 + t(2,1,1)=-sint + t(2,2,1)= cost + t(2,3,1)= 0.0D0 + t(3,1,1)= 0.0D0 + t(3,2,1)= 0.0D0 + t(3,3,1)= 1.0D0 + r(1,1,1)= 1.0D0 + r(1,2,1)= 0.0D0 + r(1,3,1)= 0.0D0 + r(2,1,1)= 0.0D0 + r(2,2,1)= 1.0D0 + r(2,3,1)= 0.0D0 + r(3,1,1)= 0.0D0 + r(3,2,1)= 0.0D0 + r(3,3,1)= 1.0D0 + do i=1,3 + do j=1,3 + rt(i,j,1)=t(i,j,1) + enddo + enddo + do i=1,3 + do j=1,3 + prod(i,j,1)=0.0D0 + prod(i,j,2)=t(i,j,1) + enddo + prod(i,i,1)=1.0D0 + enddo + c(1,1)=0.0D0 + c(2,1)=0.0D0 + c(3,1)=0.0D0 + c(1,2)=vbld(2) + c(2,2)=0.0D0 + c(3,2)=0.0D0 + dc(1,1)=vbld(2) + dc(2,1)=0.0D0 + dc(3,1)=0.0D0 + dc_norm(1,1)=1.0D0 + dc_norm(2,1)=0.0D0 + dc_norm(3,1)=0.0D0 + do j=1,3 + dc_norm(j,2)=prod(j,1,2) + dc(j,2)=vbld(3)*prod(j,1,2) + c(j,3)=c(j,2)+dc(j,2) + enddo + call locate_side_chain(2) + return + end +c----------------------------------------------------------------------------- + subroutine locate_next_res(i) +C +C Locate CA(i) and SC(i-1) +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.CHAIN' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.INTERACT' +C +C Define the rotation matrices corresponding to CA(i) +C +#ifdef OSF + theti=theta(i) + icrc=0 + call proc_proc(theti,icrc) + if(icrc.eq.1)theti=100.0 + phii=phi(i) + icrc=0 + call proc_proc(phii,icrc) + if(icrc.eq.1)phii=180.0 +#else + theti=theta(i) + phii=phi(i) +#endif + cost=dcos(theti) + sint=dsin(theti) + cosphi=dcos(phii) + sinphi=dsin(phii) +* Define the matrices of the rotation about the virtual-bond valence angles +* theta, T(i,j,k), virtual-bond dihedral angles gamma (miscalled PHI in this +* program), R(i,j,k), and, the cumulative matrices of rotation RT + t(1,1,i-2)=-cost + t(1,2,i-2)=-sint + t(1,3,i-2)= 0.0D0 + t(2,1,i-2)=-sint + t(2,2,i-2)= cost + t(2,3,i-2)= 0.0D0 + t(3,1,i-2)= 0.0D0 + t(3,2,i-2)= 0.0D0 + t(3,3,i-2)= 1.0D0 + r(1,1,i-2)= 1.0D0 + r(1,2,i-2)= 0.0D0 + r(1,3,i-2)= 0.0D0 + r(2,1,i-2)= 0.0D0 + r(2,2,i-2)=-cosphi + r(2,3,i-2)= sinphi + r(3,1,i-2)= 0.0D0 + r(3,2,i-2)= sinphi + r(3,3,i-2)= cosphi + rt(1,1,i-2)=-cost + rt(1,2,i-2)=-sint + rt(1,3,i-2)=0.0D0 + rt(2,1,i-2)=sint*cosphi + rt(2,2,i-2)=-cost*cosphi + rt(2,3,i-2)=sinphi + rt(3,1,i-2)=-sint*sinphi + rt(3,2,i-2)=cost*sinphi + rt(3,3,i-2)=cosphi + call matmult(prod(1,1,i-2),rt(1,1,i-2),prod(1,1,i-1)) + do j=1,3 + dc_norm(j,i-1)=prod(j,1,i-1) + dc(j,i-1)=vbld(i)*prod(j,1,i-1) + c(j,i)=c(j,i-1)+dc(j,i-1) + enddo +cd print '(2i3,2(3f10.5,5x))', i-1,i,(dc(j,i-1),j=1,3),(c(j,i),j=1,3) +C +C Now calculate the coordinates of SC(i-1) +C + call locate_side_chain(i-1) + return + end +c----------------------------------------------------------------------------- + subroutine locate_side_chain(i) +C +C Locate the side-chain centroid i, 1 < i < NRES. Put in C(*,NRES+i). +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.CHAIN' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.INTERACT' + dimension xx(3) + +c dsci=dsc(itype(i)) +c dsci_inv=dsc_inv(itype(i)) + dsci=vbld(i+nres) + dsci_inv=vbld_inv(i+nres) +#ifdef OSF + alphi=alph(i) + omegi=omeg(i) +c detecting NaNQ + icrc=0 + call proc_proc(alphi,icrc) + if(icrc.eq.1)alphi=100.0 + icrc=0 + call proc_proc(omegi,icrc) + if(icrc.eq.1)omegi=-100.0 +#else + alphi=alph(i) + omegi=omeg(i) +#endif + cosalphi=dcos(alphi) + sinalphi=dsin(alphi) + cosomegi=dcos(omegi) + sinomegi=dsin(omegi) + xp= dsci*cosalphi + yp= dsci*sinalphi*cosomegi + zp=-dsci*sinalphi*sinomegi +* Now we have to rotate the coordinate system by 180-theta(i)/2 so as to get its +* X-axis aligned with the vector DC(*,i) + theta2=pi-0.5D0*theta(i+1) + cost2=dcos(theta2) + sint2=dsin(theta2) + xx(1)= xp*cost2+yp*sint2 + xx(2)=-xp*sint2+yp*cost2 + xx(3)= zp +cd print '(a3,i3,3f10.5,5x,3f10.5)',restyp(itype(i)),i, +cd & xp,yp,zp,(xx(k),k=1,3) + do j=1,3 + xloc(j,i)=xx(j) + enddo +* Bring the SC vectors to the common coordinate system. + xx(1)=xloc(1,i) + xx(2)=xloc(2,i)*r(2,2,i-1)+xloc(3,i)*r(2,3,i-1) + xx(3)=xloc(2,i)*r(3,2,i-1)+xloc(3,i)*r(3,3,i-1) + do j=1,3 + xrot(j,i)=xx(j) + enddo + do j=1,3 + rj=0.0D0 + do k=1,3 + rj=rj+prod(j,k,i-1)*xx(k) + enddo + dc(j,nres+i)=rj + dc_norm(j,nres+i)=rj*dsci_inv + c(j,nres+i)=c(j,i)+rj + enddo + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/chainbuild.f b/source/wham/src-NEWSC-NEWCORR/chainbuild.f new file mode 100644 index 0000000..26afd44 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/chainbuild.f @@ -0,0 +1,258 @@ + subroutine chainbuild +C +C Build the virtual polypeptide chain. Side-chain centroids are moveable. +C As of 2/17/95. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.CHAIN' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.INTERACT' + logical lprn +C Set lprn=.true. for debugging + lprn = .false. +C +C Define the origin and orientation of the coordinate system and locate the +C first three CA's and SC(2). +C + call orig_frame +* +* Build the alpha-carbon chain. +* + do i=4,nres + call locate_next_res(i) + enddo +C +C First and last SC must coincide with the corresponding CA. +C + do j=1,3 + dc(j,nres+1)=0.0D0 + dc_norm(j,nres+1)=0.0D0 + dc(j,nres+nres)=0.0D0 + dc_norm(j,nres+nres)=0.0D0 + c(j,nres+1)=c(j,1) + c(j,nres+nres)=c(j,nres) + enddo +* +* Temporary diagnosis +* + if (lprn) then + + call cartprint + write (iout,'(/a)') 'Recalculated internal coordinates' + do i=2,nres-1 + do j=1,3 + c(j,maxres2)=0.5D0*(c(j,i-1)+c(j,i+1)) + enddo + be=0.0D0 + if (i.gt.3) be=rad2deg*beta(i-3,i-2,i-1,i) + be1=rad2deg*beta(nres+i,i,maxres2,i+1) + alfai=0.0D0 + if (i.gt.2) alfai=rad2deg*alpha(i-2,i-1,i) + write (iout,1212) restyp(itype(i)),i,dist(i-1,i), + & alfai,be,dist(nres+i,i),rad2deg*alpha(nres+i,i,maxres2),be1 + enddo + 1212 format (a3,'(',i3,')',2(f10.5,2f10.2)) + + endif + + return + end +c------------------------------------------------------------------------- + subroutine orig_frame +C +C Define the origin and orientation of the coordinate system and locate +C the first three atoms. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.CHAIN' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + include 'COMMON.VAR' + cost=dcos(theta(3)) + sint=dsin(theta(3)) + t(1,1,1)=-cost + t(1,2,1)=-sint + t(1,3,1)= 0.0D0 + t(2,1,1)=-sint + t(2,2,1)= cost + t(2,3,1)= 0.0D0 + t(3,1,1)= 0.0D0 + t(3,2,1)= 0.0D0 + t(3,3,1)= 1.0D0 + r(1,1,1)= 1.0D0 + r(1,2,1)= 0.0D0 + r(1,3,1)= 0.0D0 + r(2,1,1)= 0.0D0 + r(2,2,1)= 1.0D0 + r(2,3,1)= 0.0D0 + r(3,1,1)= 0.0D0 + r(3,2,1)= 0.0D0 + r(3,3,1)= 1.0D0 + do i=1,3 + do j=1,3 + rt(i,j,1)=t(i,j,1) + enddo + enddo + do i=1,3 + do j=1,3 + prod(i,j,1)=0.0D0 + prod(i,j,2)=t(i,j,1) + enddo + prod(i,i,1)=1.0D0 + enddo + c(1,1)=0.0D0 + c(2,1)=0.0D0 + c(3,1)=0.0D0 + c(1,2)=vbld(2) + c(2,2)=0.0D0 + c(3,2)=0.0D0 + dc(1,1)=vbld(2) + dc(2,1)=0.0D0 + dc(3,1)=0.0D0 + dc_norm(1,1)=1.0D0 + dc_norm(2,1)=0.0D0 + dc_norm(3,1)=0.0D0 + do j=1,3 + dc_norm(j,2)=prod(j,1,2) + dc(j,2)=vbld(3)*prod(j,1,2) + c(j,3)=c(j,2)+dc(j,2) + enddo + call locate_side_chain(2) + return + end +c----------------------------------------------------------------------------- + subroutine locate_next_res(i) +C +C Locate CA(i) and SC(i-1) +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.CHAIN' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.INTERACT' +C +C Define the rotation matrices corresponding to CA(i) +C + theti=theta(i) + phii=phi(i) + cost=dcos(theti) + sint=dsin(theti) + cosphi=dcos(phii) + sinphi=dsin(phii) +* Define the matrices of the rotation about the virtual-bond valence angles +* theta, T(i,j,k), virtual-bond dihedral angles gamma (miscalled PHI in this +* program), R(i,j,k), and, the cumulative matrices of rotation RT + t(1,1,i-2)=-cost + t(1,2,i-2)=-sint + t(1,3,i-2)= 0.0D0 + t(2,1,i-2)=-sint + t(2,2,i-2)= cost + t(2,3,i-2)= 0.0D0 + t(3,1,i-2)= 0.0D0 + t(3,2,i-2)= 0.0D0 + t(3,3,i-2)= 1.0D0 + r(1,1,i-2)= 1.0D0 + r(1,2,i-2)= 0.0D0 + r(1,3,i-2)= 0.0D0 + r(2,1,i-2)= 0.0D0 + r(2,2,i-2)=-cosphi + r(2,3,i-2)= sinphi + r(3,1,i-2)= 0.0D0 + r(3,2,i-2)= sinphi + r(3,3,i-2)= cosphi + rt(1,1,i-2)=-cost + rt(1,2,i-2)=-sint + rt(1,3,i-2)=0.0D0 + rt(2,1,i-2)=sint*cosphi + rt(2,2,i-2)=-cost*cosphi + rt(2,3,i-2)=sinphi + rt(3,1,i-2)=-sint*sinphi + rt(3,2,i-2)=cost*sinphi + rt(3,3,i-2)=cosphi + call matmult(prod(1,1,i-2),rt(1,1,i-2),prod(1,1,i-1)) + do j=1,3 + dc_norm(j,i-1)=prod(j,1,i-1) + dc(j,i-1)=vbld(i)*prod(j,1,i-1) + c(j,i)=c(j,i-1)+dc(j,i-1) + enddo +cd print '(2i3,2(3f10.5,5x))', i-1,i,(dc(j,i-1),j=1,3),(c(j,i),j=1,3) +C +C Now calculate the coordinates of SC(i-1) +C + call locate_side_chain(i-1) + return + end +c----------------------------------------------------------------------------- + subroutine locate_side_chain(i) +C +C Locate the side-chain centroid i, 1 < i < NRES. Put in C(*,NRES+i). +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.CHAIN' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.INTERACT' + dimension xx(3) + +c dsci=dsc(itype(i)) +c dsci_inv=dsc_inv(itype(i)) + dsci=vbld(i+nres) + dsci_inv=vbld_inv(i+nres) + alphi=alph(i) + omegi=omeg(i) + cosalphi=dcos(alphi) + sinalphi=dsin(alphi) + cosomegi=dcos(omegi) + sinomegi=dsin(omegi) + xp= dsci*cosalphi + yp= dsci*sinalphi*cosomegi + zp=-dsci*sinalphi*sinomegi +* Now we have to rotate the coordinate system by 180-theta(i)/2 so as to get its +* X-axis aligned with the vector DC(*,i) + theta2=pi-0.5D0*theta(i+1) + cost2=dcos(theta2) + sint2=dsin(theta2) + xx(1)= xp*cost2+yp*sint2 + xx(2)=-xp*sint2+yp*cost2 + xx(3)= zp +cd print '(a3,i3,3f10.5,5x,3f10.5)',restyp(itype(i)),i, +cd & xp,yp,zp,(xx(k),k=1,3) + do j=1,3 + xloc(j,i)=xx(j) + enddo +* Bring the SC vectors to the common coordinate system. + xx(1)=xloc(1,i) + xx(2)=xloc(2,i)*r(2,2,i-1)+xloc(3,i)*r(2,3,i-1) + xx(3)=xloc(2,i)*r(3,2,i-1)+xloc(3,i)*r(3,3,i-1) + do j=1,3 + xrot(j,i)=xx(j) + enddo + do j=1,3 + rj=0.0D0 + do k=1,3 + rj=rj+prod(j,k,i-1)*xx(k) + enddo + dc(j,nres+i)=rj + dc_norm(j,nres+i)=rj*dsci_inv + c(j,nres+i)=c(j,i)+rj + enddo + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/compinfo.c b/source/wham/src-NEWSC-NEWCORR/compinfo.c new file mode 100644 index 0000000..e28f686 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/compinfo.c @@ -0,0 +1,82 @@ +#include +#include +#include +#include +#include + +main() +{ +FILE *in, *in1, *out; +int i,j,k,iv1,iv2,iv3; +char *p1,buf[500],buf1[500],buf2[100],buf3[100]; +struct utsname Name; +time_t Tp; + +in=fopen("cinfo.f","r"); +out=fopen("cinfo.f.new","w"); +if (fgets(buf,498,in) != NULL) + fprintf(out,"C DO NOT EDIT THIS FILE - IT HAS BEEN GENERATED BY COMPINFO.C\n"); +if (fgets(buf,498,in) != NULL) + sscanf(&buf[1],"%d %d %d",&iv1,&iv2,&iv3); +iv3++; +fprintf(out,"C %d %d %d\n",iv1,iv2,iv3); +fprintf(out," subroutine cinfo\n"); +fprintf(out," include 'COMMON.IOUNITS'\n"); +fprintf(out," write(iout,*)'++++ Compile info ++++'\n"); +fprintf(out," write(iout,*)'Version %d.%-d build %d'\n",iv1,iv2,iv3); +uname(&Name); +time(&Tp); +system("whoami > tmptmp"); +in1=fopen("tmptmp","r"); +if (fscanf(in1,"%s",buf1) != EOF) +{ +p1=ctime(&Tp); +p1[strlen(p1)-1]='\0'; +fprintf(out," write(iout,*)'compiled %s'\n",p1); +fprintf(out," write(iout,*)'compiled by %s@%s'\n",buf1,Name.nodename); +fprintf(out," write(iout,*)'OS name: %s '\n",Name.sysname); +fprintf(out," write(iout,*)'OS release: %s '\n",Name.release); +fprintf(out," write(iout,*)'OS version:',\n"); +fprintf(out," & ' %s '\n",Name.version); +fprintf(out," write(iout,*)'flags:'\n"); +} +system("rm tmptmp"); +fclose(in1); +in1=fopen("Makefile","r"); +while(fgets(buf,498,in1) != NULL) + { + if((p1=strchr(buf,'=')) != NULL && buf[0] != '#') + { + buf[strlen(buf)-1]='\0'; + if(strlen(buf) > 49) + { + buf[47]='\0'; + strcat(buf,"..."); + } + else + { + while(buf[strlen(buf)-1]=='\\') + { + strcat(buf,"\\"); + fprintf(out," write(iout,*)'%s'\n",buf); + if (fgets(buf,498,in1) != NULL) + buf[strlen(buf)-1]='\0'; + if(strlen(buf) > 49) + { + buf[47]='\0'; + strcat(buf,"..."); + } + } + } + + fprintf(out," write(iout,*)'%s'\n",buf); + } + } +fprintf(out," write(iout,*)'++++ End of compile info ++++'\n"); +fprintf(out," return\n"); +fprintf(out," end\n"); +fclose(out); +fclose(in1); +fclose(in); +system("mv cinfo.f.new cinfo.f"); +} diff --git a/source/wham/src-NEWSC-NEWCORR/conf_compar.F b/source/wham/src-NEWSC-NEWCORR/conf_compar.F new file mode 100644 index 0000000..4b49345 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/conf_compar.F @@ -0,0 +1,374 @@ + subroutine conf_compar(jcon,lprn,print_class) + implicit real*8 (a-h,o-z) +#ifdef MPI + include "mpif.h" +#endif + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.COMPAR' + include 'DIMENSIONS.FREE' + include 'COMMON.CONTROL' + include 'COMMON.IOUNITS' + include 'COMMON.COMPAR' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.PEPTCONT' + include 'COMMON.CONTACTS1' + include 'COMMON.HEADER' + include 'COMMON.FREE' + include 'COMMON.ENERGIES' +#ifdef MPI + include 'COMMON.MPI' +#endif + integer ilen + external ilen + logical lprn,print_class + integer ncont_frag(mmaxfrag), + & icont_frag(2,maxcont,mmaxfrag),ncontsc, + & icontsc(1,maxcont),nsccont_frag(mmaxfrag), + & isccont_frag(2,maxcont,mmaxfrag) + integer isecstr(maxres) + integer itemp(maxfrag) + character*4 liczba + double precision Epot +c print *,"Enter conf_compar",jcon + call angnorm12(rmsang) +c Level 1: check secondary and supersecondary structure + call elecont(lprn,ncont,icont,nnt,nct) + call secondary2(lprn,.false.,ncont,icont,isecstr) + call contact(lprn,ncontsc,icontsc,nnt,nct) + if (lprn) write(iout,*) "Assigning electrostatic contacts" + call contacts_between_fragments(lprn,3,ncont,icont,ncont_frag, + & icont_frag) + if (lprn) write(iout,*) "Assigning sidechain contacts" + call contacts_between_fragments(lprn,3,ncontsc,icontsc, + & nsccont_frag,isccont_frag) + do i=1,nlevel + do j=1,isnfrag(nlevel+1) + iclass(j,i)=0 + enddo + enddo + do j=1,nfrag(1) + ind = icant(j,j) + if (lprn) then + write (iout,'(80(1h=))') + write (iout,*) "Level",1," fragment",j + write (iout,'(80(1h=))') + endif + rmsfrag(j,1)=rmscalc(0,1,j,jcon,lprn) +c Compare electrostatic contacts in the current conf with that in the native +c structure. + if (lprn) write (iout,*) + & "Comparing electrostatic contact map and local structure" + ncnat=ncont_frag_ref(ind) +c write (iout,*) "before match_contact:",nc_fragm(j,1), +c & nc_req_setf(j,1) + call match_secondary(j,isecstr,nsec_match,lprn) + if (lprn) write (iout,*) "Fragment",j," nsec_match", + & nsec_match," length",len_frag(j,1)," min_len", + & frac_sec*len_frag(j,1) + if (nsec_match.lt.frac_sec*len_frag(j,1)) then + iclass(j,1)=0 + if (lprn) write (iout,*) "Fragment",j, + & " has incorrect secondary structure" + else + iclass(j,1)=1 + if (lprn) write (iout,*) "Fragment",j, + & " has correct secondary structure" + endif + if (ielecont(j,1).gt.0) then + call match_contact(ishif1,ishif2,nc_match,ncon_match, + & ncont_frag_ref(ind),icont_frag_ref(1,1,ind), + & ncont_frag(ind),icont_frag(1,1,ind), + & j,n_shift(1,j,1),n_shift(2,j,1),nc_fragm(j,1), + & nc_req_setf(j,1),istruct(j),.true.,lprn) + else if (isccont(j,1).gt.0) then + call match_contact(ishif1,ishif2,nc_match,ncon_match, + & nsccont_frag_ref(ind),isccont_frag_ref(1,1,ind), + & nsccont_frag(ind),isccont_frag(1,1,ind), + & j,n_shift(1,j,1),n_shift(2,j,1),nc_fragm(j,1), + & nc_req_setf(j,1),istruct(j),.true.,lprn) + else if (iloc(j).gt.0) then +c write (iout,*) "n_shif",n_shift(1,j,1),n_shift(2,j,1) + call match_contact(ishif1,ishif2,nc_match,ncon_match, + & 0,icont_frag_ref(1,1,ind), + & ncont_frag(ind),icont_frag(1,1,ind), + & j,n_shift(1,j,1),n_shift(2,j,1),nc_fragm(j,1), + & 0,istruct(j),.true.,lprn) +c write (iout,*) "n_shif",n_shift(1,j,1),n_shift(2,j,1) + else + ishif=0 + nc_match=1 + endif + if (lprn) write (iout,*) "ishif1",ishif1," ishif2",ishif2 + ishif=ishif1 + qfrag(j,1)=qwolynes(1,j) + if (iabs(ishif2).gt.iabs(ishif1)) ishif=ishif2 + if (lprn) write (iout,*) "ishift",ishif," nc_match",nc_match +c write (iout,*) "j",j," ishif",ishif," rms",rmsfrag(j,1) + if (irms(j,1).gt.0) then + if (rmsfrag(j,1).le.rmscutfrag(1,j,1)) then + iclass_rms=2 + ishifft_rms=0 + else + ishiff=0 + rms=1.0d2 + iclass_rms=0 + do while (rms.gt.rmscutfrag(1,j,1) .and. + & ishiff.lt.n_shift(1,j,1)) + ishiff=ishiff+1 + rms=rmscalc(-ishiff,1,j,jcon,lprn) +c write(iout,*)"jcon,i,j,ishiff",jcon,i,j,-ishiff, +c & " rms",rms," rmscut",rmscutfrag(1,j,1) + if (lprn) write (iout,*) "rms",rmsfrag(j,1) + if (rms.gt.rmscutfrag(1,j,1)) then + rms=rmscalc(ishiff,1,j,jcon,lprn) +c write (iout,*) "jcon,1,j,ishiff",jcon,1,j,ishiff, +c & " rms",rms + endif + if (lprn) write (iout,*) "rms",rmsfrag(j,1) + enddo +c write (iout,*) "After loop: rms",rms, +c & " rmscut",rmscutfrag(1,j,1) +c write (iout,*) "iclass_rms",iclass_rms + if (rms.le.rmscutfrag(1,j,1)) then + ishifft_rms=ishiff + rmsfrag(j,1)=rms + iclass_rms=1 + endif +c write (iout,*) "iclass_rms",iclass_rms + endif +c write (iout,*) "ishif",ishif + if (iabs(ishifft_rms).gt.iabs(ishif)) ishif=ishifft_rms + else + iclass_rms=1 + endif +c write (iout,*) "ishif",ishif," iclass",iclass(j,1), +c & " iclass_rms",iclass_rms + if (nc_match.gt.0 .and. iclass_rms.gt.0) then + if (ishif.eq.0) then + iclass(j,1)=iclass(j,1)+6 + else + iclass(j,1)=iclass(j,1)+2 + endif + endif + ncont_nat(1,j,1)=nc_match + ncont_nat(2,j,1)=ncon_match + ishifft(j,1)=ishif +c write (iout,*) "iclass",iclass(j,1) + enddo +c Next levels: Check arrangements of elementary fragments. + do i=2,nlevel + do j=1,nfrag(i) + if (i .eq. 2) ind = icant(ipiece(1,j,i),ipiece(2,j,i)) + if (lprn) then + write (iout,'(80(1h=))') + write (iout,*) "Level",i," fragment",j + write (iout,'(80(1h=))') + endif +c If an elementary fragment doesn't exist, don't check higher hierarchy levels. + do k=1,npiece(j,i) + ik=ipiece(k,j,i) + if (iclass(ik,1).eq.0) then + iclass(j,i)=0 + goto 12 + endif + enddo + if (i.eq.2 .and. ielecont(j,i).gt.0) then + iclass_con=0 + ishifft_con=0 + if (lprn) write (iout,*) + & "Comparing electrostatic contact map: fragments", + & ipiece(1,j,i),ipiece(2,j,i)," ind",ind + call match_contact(ishif1,ishif2,nc_match,ncon_match, + & ncont_frag_ref(ind),icont_frag_ref(1,1,ind), + & ncont_frag(ind),icont_frag(1,1,ind), + & j,n_shift(1,j,i),n_shift(2,j,i),nc_fragm(j,i), + & nc_req_setf(j,i),2,.false.,lprn) + ishif=ishif1 + if (iabs(ishif2).gt.iabs(ishif1)) ishif=ishif2 + if (nc_match.gt.0) then + if (ishif.eq.0) then + iclass_con=2 + else + iclass_con=1 + endif + endif + ncont_nat(1,j,i)=nc_match + ncont_nat(2,j,i)=ncon_match + ishifft_con=ishif + else if (i.eq.2 .and. isccont(j,i).gt.0) then + iclass_con=0 + ishifft_con=0 + if (lprn) write (iout,*) + & "Comparing sidechain contact map: fragments", + & ipiece(1,j,i),ipiece(2,j,i)," ind",ind + call match_contact(ishif1,ishif2,nc_match,ncon_match, + & nsccont_frag_ref(ind),isccont_frag_ref(1,1,ind), + & nsccont_frag(ind),isccont_frag(1,1,ind), + & j,n_shift(1,j,i),n_shift(2,j,i),nc_fragm(j,i), + & nc_req_setf(j,i),2,.false.,lprn) + ishif=ishif1 + if (iabs(ishif2).gt.iabs(ishif1)) ishif=ishif2 + if (nc_match.gt.0) then + if (ishif.eq.0) then + iclass_con=2 + else + iclass_con=1 + endif + endif + ncont_nat(1,j,i)=nc_match + ncont_nat(2,j,i)=ncon_match + ishifft_con=ishif + else if (i.eq.2) then + iclass_con=2 + ishifft_con=0 + endif + if (i.eq.2) qfrag(j,2)=qwolynes(2,j) + if (lprn) write (iout,*) + & "Comparing rms: fragments", + & (ipiece(k,j,i),k=1,npiece(j,i)) + rmsfrag(j,i)=rmscalc(0,i,j,jcon,lprn) + if (irms(j,i).gt.0) then + iclass_rms=0 + ishifft_rms=0 + if (lprn) write (iout,*) "rms",rmsfrag(j,i) +c write (iout,*) "i",i," j",j," rmsfrag",rmsfrag(j,i), +c & " rmscutfrag",rmscutfrag(1,j,i) + if (rmsfrag(j,i).le.rmscutfrag(1,j,i)) then + iclass_rms=2 + ishifft_rms=0 + else + ishif=0 + rms=1.0d2 + do while (rms.gt.rmscutfrag(1,j,i) .and. + & ishif.lt.n_shift(1,j,i)) + ishif=ishif+1 + rms=rmscalc(-ishif,i,j,jcon,lprn) +c print *,"jcon,i,j,ishif",jcon,i,j,-ishif," rms",rms + if (lprn) write (iout,*) "rms",rmsfrag(j,i) + if (rms.gt.rmscutfrag(1,j,i)) then + rms=rmscalc(ishif,i,j,jcon,lprn) +c print *,"jcon,i,j,ishif",jcon,i,j,ishif," rms",rms + endif + if (lprn) write (iout,*) "rms",rms + enddo + if (rms.le.rmscutfrag(1,j,i)) then + ishifft_rms=ishif + rmsfrag(j,i)=rms + iclass_rms=1 + endif + endif + endif + if (irms(j,i).eq.0 .and. ielecont(j,i).eq.0 .and. + & isccont(j,i).eq.0 ) then + write (iout,*) "Error: no measure of comparison specified:", + & " level",i," part",j + stop + endif + if (lprn) + & write (iout,*) "iclass_con",iclass_con," iclass_rms",iclass_rms + if (i.eq.2) then + iclass(j,i) = min0(iclass_con,iclass_rms) + if (iabs(ishifft_rms).gt.iabs(ishifft_con)) then + ishifft(j,i)=ishifft_rms + else + ishifft(j,i)=ishifft_con + endif + else if (i.gt.2) then + iclass(j,i) = iclass_rms + ishifft(j,i)= ishifft_rms + endif + 12 continue + enddo + enddo + rms_nat=rmsnat(jcon) + qnat=qwolynes(0,0) +C Compute the structural class + iscor=0 + IF (.NOT. BINARY) THEN + do i=1,nlevel + IF (I.EQ.1) THEN + do j=1,nfrag(i) + itemp(j)=iclass(j,i) + enddo + do kk=-1,1 + do j=1,nfrag(i) + idig = 2*isnfrag(nlevel+1)-2*isnfrag(i)-kk*nfrag(i)-j + iex = 2**idig + im=mod(itemp(j),2) + itemp(j)=itemp(j)/2 +c write (iout,*) "i",i," j",j," idig",idig," iex",iex, +c & " iclass",iclass(j,i)," im",im + iscor=iscor+im*iex + enddo + enddo + ELSE + do j=1,nfrag(i) + idig = 2*isnfrag(nlevel+1)-2*isnfrag(i)-j + iex = 2**idig + if (iclass(j,i).gt.0) then + im=1 + else + im=0 + endif +c write (iout,*) "i",i," j",j," idig",idig," iex",iex, +c & " iclass",iclass(j,i)," im",im + iscor=iscor+im*iex + enddo + do j=1,nfrag(i) + idig = 2*isnfrag(nlevel+1)-2*isnfrag(i)-nfrag(i)-j + iex = 2**idig + if (iclass(j,i).gt.1) then + im=1 + else + im=0 + endif +c write (iout,*) "i",i," j",j," idig",idig," iex",iex, +c & " iclass",iclass(j,i)," im",im + iscor=iscor+im*iex + enddo + ENDIF + enddo + iscore=iscor + ENDIF + if (print_class) then +#ifdef MPI + write(istat,'(i6,$)') jcon+indstart(me)-1 + write (istat,'(f10.2,$)') (potE(jcon,k),k=1,nParmSet), + & -entfac(jcon) +#else + write(istat,'(i6,$)') jcon + write (istat,'(f10.2,$)') (potE(jcon,k),k=1,nParmSet), + & -entfac(jcon) +#endif + write (istat,'(f8.3,2f6.3,$)') + & rms_nat,qnat,rmsang/(nres-3) + do j=1,nlevel + write(istat,'(1x,$,20(i3,$))') + & (ncont_nat(1,k,j),k=1,nfrag(j)) + if (j.lt.3) then + write(istat,'(1x,$,20(f5.1,f5.2$))') + & (rmsfrag(k,j),qfrag(k,j),k=1,nfrag(j)) + else + write(istat,'(1x,$,20(f5.1$))') + & (rmsfrag(k,j),k=1,nfrag(j)) + endif + write(istat,'(1x,$,20(i1,$))') + & (iclass(k,j),k=1,nfrag(j)) + enddo + if (binary) then + write (istat,'(" ",$)') + do j=1,nlevel + write (istat,'(100(i1,$))')(iclass(k,j), + & k=1,nfrag(j)) + if (j.lt.nlevel) write(iout,'(".",$)') + enddo + write (istat,*) + else + write (istat,'(i10)') iscore + endif + endif + RETURN + END diff --git a/source/wham/src-NEWSC-NEWCORR/cont_frag.f b/source/wham/src-NEWSC-NEWCORR/cont_frag.f new file mode 100644 index 0000000..63a7717 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/cont_frag.f @@ -0,0 +1,99 @@ + subroutine contacts_between_fragments(lprint,is,ncont,icont, + & ncont_interfrag,icont_interfrag) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.COMPAR' + include 'COMMON.INTERACT' + include 'COMMON.COMPAR' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + integer icont(2,maxcont),ncont_interfrag(mmaxfrag), + & icont_interfrag(2,maxcont,mmaxfrag) + logical OK1,OK2,lprint +c Determine the contacts that occur within a fragment and between fragments. + do i=1,nfrag(1) + do j=1,i + ind = icant(i,j) + nc=0 +c write (iout,*) "i",i,(ifrag(1,k,i),ifrag(2,k,i) +c & ,k=1,npiece(i,1)) +c write (iout,*) "j",j,(ifrag(1,k,j),ifrag(2,k,j) +c & ,k=1,npiece(j,1)) +c write (iout,*) "ncont",ncont + do k=1,ncont + ic1=icont(1,k) + ic2=icont(2,k) + OK1=.false. + l=0 + do while (.not.OK1 .and. l.lt.npiece(j,1)) + l=l+1 + OK1=ic1.ge.ifrag(1,l,j)-is .and. + & ic1.le.ifrag(2,l,j)+is + enddo + OK2=.false. + l=0 + do while (.not.OK2 .and. l.lt.npiece(i,1)) + l=l+1 + OK2=ic2.ge.ifrag(1,l,i)-is .and. + & ic2.le.ifrag(2,l,i)+is + enddo +c write(iout,*) "k",k," ic1",ic1," ic2",ic2," OK1",OK1, +c & " OK2",OK2 + if (OK1.and.OK2) then + nc=nc+1 + icont_interfrag(1,nc,ind)=ic1 + icont_interfrag(2,nc,ind)=ic2 +c write (iout,*) "nc",nc," ic1",ic1," ic2",ic2 + endif + enddo + ncont_interfrag(ind)=nc +c do k=1,ncont_interfrag(ind) +c i1=icont_interfrag(1,k,ind) +c i2=icont_interfrag(2,k,ind) +c it1=itype(i1) +c it2=itype(i2) +c write (iout,'(i3,2x,a,i4,2x,a,i4)') +c & i,restyp(it1),i1,restyp(it2),i2 +c enddo + enddo + enddo + if (lprint) then + write (iout,*) "Contacts within fragments:" + do i=1,nfrag(1) + write (iout,*) "Fragment",i," (",(ifrag(1,k,i), + & ifrag(2,k,i),k=1,npiece(i,1)),")" + ind=icant(i,i) + do k=1,ncont_interfrag(ind) + i1=icont_interfrag(1,k,ind) + i2=icont_interfrag(2,k,ind) + it1=itype(i1) + it2=itype(i2) + write (iout,'(i3,2x,a,i4,2x,a,i4)') + & i,restyp(it1),i1,restyp(it2),i2 + enddo + enddo + write (iout,*) + write (iout,*) "Contacts between fragments:" + do i=1,nfrag(1) + do j=1,i-1 + ind = icant(i,j) + write (iout,*) "Fragments",i," (",(ifrag(1,k,i), + & ifrag(2,k,i),k=1,npiece(i,1)),") and",j," (", + & (ifrag(1,k,j),ifrag(2,k,j),k=1,npiece(j,1)),")" + write (iout,*) "Number of contacts", + & ncont_interfrag(ind) + ind=icant(i,j) + do k=1,ncont_interfrag(ind) + i1=icont_interfrag(1,k,ind) + i2=icont_interfrag(2,k,ind) + it1=itype(i1) + it2=itype(i2) + write (iout,'(i3,2x,a,i4,2x,a,i4)') + & i,restyp(it1),i1,restyp(it2),i2 + enddo + enddo + enddo + endif + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/contact.f b/source/wham/src-NEWSC-NEWCORR/contact.f new file mode 100644 index 0000000..5b05d57 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/contact.f @@ -0,0 +1,171 @@ + subroutine contact(lprint,ncont,icont,ist,ien) + implicit none + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.CONTROL' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.NAMES' + include 'COMMON.CALC' + include 'COMMON.CONTPAR' + include 'COMMON.LOCAL' + integer ist,ien,kkk,iti,itj,itypi,itypj,i1,i2,it1,it2 + real*8 csc,dist + real*8 cscore(maxcont),omt1(maxcont),omt2(maxcont),omt12(maxcont), + & ddsc(maxcont),ddla(maxcont),ddlb(maxcont) + integer ncont,icont(2,maxcont) + real*8 u,v,a(3),b(3),dla,dlb + logical lprint + ncont=0 + kkk=3 + if (lprint) then + do i=1,nres + write (iout,110) restyp(itype(i)),i,c(1,i),c(2,i), + & c(3,i),dc(1,nres+i),dc(2,nres+i),dc(3,nres+i), + & dc_norm(1,nres+i),dc_norm(2,nres+i),dc_norm(3,nres+i) + enddo + endif + 110 format (a,'(',i3,')',9f8.3) + do i=ist,ien-kkk + iti=itype(i) + do j=i+kkk,ien + itj=itype(j) + itypi=iti + itypj=itj + xj = c(1,nres+j)-c(1,nres+i) + yj = c(2,nres+j)-c(2,nres+i) + zj = c(3,nres+j)-c(3,nres+i) + dxi = dc_norm(1,nres+i) + dyi = dc_norm(2,nres+i) + dzi = dc_norm(3,nres+i) + dxj = dc_norm(1,nres+j) + dyj = dc_norm(2,nres+j) + dzj = dc_norm(3,nres+j) + do k=1,3 + a(k)=dc(k,nres+i) + b(k)=dc(k,nres+j) + enddo +c write (iout,*) (a(k),k=1,3),(b(k),k=1,3) + if (icomparfunc.eq.1) then + call contfunc(csc,iti,itj) + else if (icomparfunc.eq.2) then + call scdist(csc,iti,itj) + else if (icomparfunc.eq.3 .or. icomparfunc.eq.5) then + csc = dist(nres+i,nres+j) + else if (icomparfunc.eq.4) then + call odlodc(c(1,i),c(1,j),a,b,u,v,dla,dlb,csc) + else + write (*,*) "Error - Unknown sidechain contact function" + write (iout,*) "Error - Unknown sidechain contact function" + endif + if (csc.lt.sc_cutoff(iti,itj)) then +c write(iout,*) "i",i," j",j," dla",dla,dsc(iti), +c & " dlb",dlb,dsc(itj)," csc",csc,sc_cutoff(iti,itj), +c & dxi,dyi,dzi,dxi**2+dyi**2+dzi**2, +c & dxj,dyj,dzj,dxj**2+dyj**2+dzj**2,om1,om2,om12, +c & xj,yj,zj +c write(iout,*)'egb',itypi,itypj,chi1,chi2,chip1,chip2, +c & sig0ij,rij,rrij,om1,om2,om12,chiom1,chiom2,chiom12, +c & chipom1,chipom2,chipom12,sig,eps2rt,rij_shift,e2,evdw, +c & csc + ncont=ncont+1 + cscore(ncont)=csc + icont(1,ncont)=i + icont(2,ncont)=j + omt1(ncont)=om1 + omt2(ncont)=om2 + omt12(ncont)=om12 + ddsc(ncont)=1.0d0/rij + ddla(ncont)=dla + ddlb(ncont)=dlb + endif + enddo + enddo + if (lprint) then + write (iout,'(a)') 'Contact map:' + do i=1,ncont + i1=icont(1,i) + i2=icont(2,i) + it1=itype(i1) + it2=itype(i2) + write (iout,'(i3,2x,a,i4,2x,a,i4,5f8.3,3f10.5)') + & i,restyp(it1),i1,restyp(it2),i2,cscore(i), + & sc_cutoff(it1,it2),ddsc(i),ddla(i),ddlb(i), + & omt1(i),omt2(i),omt12(i) + enddo + endif + return + end +c---------------------------------------------------------------------------- + double precision function contact_fract(ncont,ncont_ref, + & icont,icont_ref) + implicit none + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + integer i,j,nmatch + integer ncont,ncont_ref,icont(2,maxcont),icont_ref(2,maxcont) + nmatch=0 +c print *,'ncont=',ncont,' ncont_ref=',ncont_ref +c write (iout,'(20i4)') (icont_ref(1,i),i=1,ncont_ref) +c write (iout,'(20i4)') (icont_ref(2,i),i=1,ncont_ref) +c write (iout,'(20i4)') (icont(1,i),i=1,ncont) +c write (iout,'(20i4)') (icont(2,i),i=1,ncont) + do i=1,ncont + do j=1,ncont_ref + if (icont(1,i).eq.icont_ref(1,j) .and. + & icont(2,i).eq.icont_ref(2,j)) nmatch=nmatch+1 + enddo + enddo +c print *,' nmatch=',nmatch +c contact_fract=dfloat(nmatch)/dfloat(max0(ncont,ncont_ref)) + contact_fract=dfloat(nmatch)/dfloat(ncont_ref) + return + end +c------------------------------------------------------------------------------ + subroutine pept_cont(lprint,ncont,icont) + implicit none + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.NAMES' + integer ncont,icont(2,maxcont) + integer i,j,k,kkk,i1,i2,it1,it2 + logical lprint + real*8 dist + real*8 rcomp /5.5d0/ + ncont=0 + kkk=0 + print *,'Entering pept_cont: nnt=',nnt,' nct=',nct + do i=nnt,nct-3 + do k=1,3 + c(k,2*nres+1)=0.5d0*(c(k,i)+c(k,i+1)) + enddo + do j=i+2,nct-1 + do k=1,3 + c(k,2*nres+2)=0.5d0*(c(k,j)+c(k,j+1)) + enddo + if (dist(2*nres+1,2*nres+2).lt.rcomp) then + ncont=ncont+1 + icont(1,ncont)=i + icont(2,ncont)=j + endif + enddo + enddo + if (lprint) then + write (iout,'(a)') 'PP contact map:' + do i=1,ncont + i1=icont(1,i) + i2=icont(2,i) + it1=itype(i1) + it2=itype(i2) + write (iout,'(i3,2x,a,i4,2x,a,i4)') + & i,restyp(it1),i1,restyp(it2),i2 + enddo + endif + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/contfunc.f b/source/wham/src-NEWSC-NEWCORR/contfunc.f new file mode 100644 index 0000000..7aed575 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/contfunc.f @@ -0,0 +1,96 @@ + subroutine contfunc(cscore,itypi,itypj) +C +C This subroutine calculates the contact function based on +C the Gay-Berne potential of interaction. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTPAR' + include 'COMMON.CALC' + integer expon /6/ +C + sig0ij=sig_comp(itypi,itypj) + chi1=chi_comp(itypi,itypj) + chi2=chi_comp(itypj,itypi) + chi12=chi1*chi2 + chip1=chip_comp(itypi,itypj) + chip2=chip_comp(itypj,itypi) + chip12=chip1*chip2 + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + rij=dsqrt(rrij) +C Calculate angle-dependent terms of the contact function + erij(1)=xj*rij + erij(2)=yj*rij + erij(3)=zj*rij + om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) + om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) + om12=dxi*dxj+dyi*dyj+dzi*dzj + chiom12=chi12*om12 +c print *,'egb',itypi,itypj,chi1,chi2,chip1,chip2, +c & sig0ij, +c & rij,rrij,om1,om2,om12 +C Calculate eps1(om12) + faceps1=1.0D0-om12*chiom12 + faceps1_inv=1.0D0/faceps1 + eps1=dsqrt(faceps1_inv) +C Following variable is eps1*deps1/dom12 + eps1_om12=faceps1_inv*chiom12 +C Calculate sigma(om1,om2,om12) + om1om2=om1*om2 + chiom1=chi1*om1 + chiom2=chi2*om2 + facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12 + sigsq=1.0D0-facsig*faceps1_inv +C Calculate eps2 and its derivatives in om1, om2, and om12. + chipom1=chip1*om1 + chipom2=chip2*om2 + chipom12=chip12*om12 + facp=1.0D0-om12*chipom12 + facp_inv=1.0D0/facp + facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12 +C Following variable is the square root of eps2 + eps2rt=1.0D0-facp1*facp_inv + sigsq=1.0D0/sigsq + sig=sig0ij*dsqrt(sigsq) + rij_shift=1.0D0/rij-sig+sig0ij + if (rij_shift.le.0.0D0) then + evdw=1.0D1 + cscore = -dlog(evdw+1.0d-6) + return + endif + rij_shift=1.0D0/rij_shift + e2=(rij_shift*sig0ij)**expon + evdw=dabs(eps1*eps2rt**2*e2) + if (evdw.gt.1.0d1) evdw = 1.0d1 + cscore = -dlog(evdw+1.0d-6) + return + end +c------------------------------------------------------------------------------ + subroutine scdist(cscore,itypi,itypj) +C +C This subroutine calculates the contact distance +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTPAR' + include 'COMMON.CALC' +C + chi1=chi_comp(itypi,itypj) + chi2=chi_comp(itypj,itypi) + chi12=chi1*chi2 + rrij=xj*xj+yj*yj+zj*zj + rij=dsqrt(rrij) +C Calculate angle-dependent terms of the contact function + erij(1)=xj/rij + erij(2)=yj/rij + erij(3)=zj/rij + om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) + om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) + om12=dxi*dxj+dyi*dyj+dzi*dzj + chiom12=chi12*om12 + om1om2=om1*om2 + chiom1=chi1*om1 + chiom2=chi2*om2 + cscore=dsqrt(rrij+chi1**2+chi2**2+2*rij*(chiom2-chiom1)-2*chiom12) + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/cxread.F b/source/wham/src-NEWSC-NEWCORR/cxread.F new file mode 100644 index 0000000..0735f11 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/cxread.F @@ -0,0 +1,336 @@ + subroutine cxread(nazwa,ii,jj,kk,ll,mm,iR,ib,iparm,*) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.FREE' +#ifdef MPI + include "mpif.h" + include "COMMON.MPI" +#endif + integer MaxTraj + parameter (MaxTraj=2050) + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.HEADER' + include 'COMMON.SBRIDGE' + include 'COMMON.PROTFILES' + include 'COMMON.OBCINKA' + include 'COMMON.FREE' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.PROT' + character*64 nazwa,bprotfile_temp + real*4 rtime,rpotE,ruconst,rt_bath,rprop(maxQ) + double precision time + integer iret,itmp,itraj,ntraj + real xoord(3,maxres2+2),prec + integer nstep(0:MaxTraj-1) + integer ilen + external ilen + integer ii,jj(maxslice),kk(maxslice),ll(maxslice),mm(maxslice) + integer is(MaxSlice),ie(MaxSlice),nrec_slice + double precision ts(MaxSlice),te(MaxSlice),time_slice + integer slice + logical conf_check + character*4 lt_bath + character*256 pdbfilename + character*50 tytul + call set_slices(is,ie,ts,te,iR,ib,iparm) + + do i=1,nQ + rprop(i)=0.0d0 + enddo + do i=0,MaxTraj-1 + nstep(i)=0 + enddo + ntraj=0 + it=0 + iret=1 +#if (defined(AIX) && !defined(JUBL)) + call xdrfopen_(ixdrf,nazwa, "r", iret) +#else + call xdrfopen(ixdrf,nazwa, "r", iret) +#endif + if (iret.eq.0) return1 + + islice1=1 + call opentmp(islice1,ientout,bprotfile_temp) +c print *,"bumbum" + do while (iret.gt.0) + +#if (defined(AIX) && !defined(JUBL)) +#ifdef DEBUG + write (iout,*) "ii",ii," itraj",itraj," it",it +#endif + call xdrffloat_(ixdrf, rtime, iret) + call xdrffloat_(ixdrf, rpotE, iret) +#ifdef DEBUG + write (iout,*) "rtime",rtime," rpotE",rpotE," iret",iret +#endif + call flush(iout) + call xdrffloat_(ixdrf, ruconst, iret) + call xdrffloat_(ixdrf, rt_bath, iret) + call xdrfint_(ixdrf, nss, iret) +#ifdef DEBUG + write (iout,*) "ruconst",ruconst," rt_bath",rt_bath," nss",nss +#endif + do j=1,nss + call xdrfint_(ixdrf, ihpb(j), iret) + call xdrfint_(ixdrf, jhpb(j), iret) + enddo + call xdrfint_(ixdrf, nprop, iret) + if (umbrella(iparm) .or. read_iset(iparm) .or. hamil_rep) + & call xdrfint(ixdrf, iset, iret) + do i=1,nprop + call xdrffloat_(ixdrf, rprop(i), iret) + enddo +#else +#ifdef DEBUG + write (iout,*) "ii",ii," itraj",itraj," it",it +#endif + call xdrffloat(ixdrf, rtime, iret) + call xdrffloat(ixdrf, rpotE, iret) +#ifdef DEBUG + write (iout,*) "rtime",rtime," rpotE",rpotE," iret",iret +#endif + call flush(iout) + call xdrffloat(ixdrf, ruconst, iret) + call xdrffloat(ixdrf, rt_bath, iret) + call xdrfint(ixdrf, nss, iret) +#ifdef DEBUG + write (iout,*) "ruconst",ruconst," rt_bath",rt_bath," nss",nss +#endif + do j=1,nss + call xdrfint(ixdrf, ihpb(j), iret) + call xdrfint(ixdrf, jhpb(j), iret) + enddo + call xdrfint(ixdrf, nprop, iret) +c write (iout,*) "nprop",nprop + if (it.gt.0 .and. nprop.ne.nprop_prev) then + write (iout,*) "Warning previous nprop",nprop_prev, + & " current",nprop + nprop=nprop_prev + else + nprop_prev=nprop + endif + call flush(iout) + if (umbrella(iparm) .or. read_iset(iparm) .or. hamil_rep) + & call xdrfint(ixdrf, iset, iret) + do i=1,nprop + call xdrffloat(ixdrf, rprop(i), iret) + enddo +#endif + if (iret.eq.0) exit + itraj=mod(it,totraj(iR,iparm)) + if (iset.eq.0) iset = 1 + call flush(iout) + it=it+1 + if (itraj.gt.ntraj) ntraj=itraj + nstep(itraj)=nstep(itraj)+1 +c rprop(2)=dsqrt(rprop(2)) +c rprop(3)=dsqrt(rprop(3)) +#ifdef DEBUG + write (iout,*) "umbrella ",umbrella + write (iout,*) rtime,rpotE,rt_bath,nss, + & (ihpb(j),jhpb(j),j=1,nss),(rprop(j),j=1,nprop) + write (iout,*) "nprop",nprop," iset",iset," myparm",myparm + call flush(iout) +#endif + prec=10000.0 + + itmp=0 +#if (defined(AIX) && !defined(JUBL)) + call xdrf3dfcoord_(ixdrf, xoord, itmp, prec, iret) +#else + call xdrf3dfcoord(ixdrf, xoord, itmp, prec, iret) +#endif +#ifdef DEBUG + write (iout,'(10f8.3)') ((xoord(j,i),j=1,3),i=1,itmp) +#endif + if (iret.eq.0) exit + if (itmp .ne. nres + nct - nnt + 1) then + write (iout,*) "Error: inconsistent sizes",itmp,nres+nct-nnt+1 + call flush(iout) + exit + endif + + time=rtime +c write (iout,*) "calling slice" +c call flush(iout) + islice=slice(nstep(itraj),time,is,ie,ts,te) +c write (iout,*) "islice",islice +c call flush(iout) + + do i=1,nres + do j=1,3 + c(j,i)=xoord(j,i) + enddo + enddo + do i=1,nct-nnt+1 + do j=1,3 + c(j,i+nres+nnt-1)=xoord(j,i+nres) + enddo + enddo + + if (islice.gt.0 .and. islice.le.nslice .and. (.not.separate_parset + & .or. iset.eq.myparm)) then + ii=ii+1 + kk(islice)=kk(islice)+1 + mm(islice)=mm(islice)+1 + if (mod(nstep(itraj),isampl(iparm)).eq.0 .and. + & conf_check(ll(islice)+1,1)) then + if (replica(iparm)) then + rt_bath=1.0d0/(rt_bath*1.987D-3) + do i=1,nT_h(iparm) + if (abs(real(beta_h(i,iparm))-rt_bath).lt.1.0e-4) then + iib = i + goto 22 + endif + enddo + 22 continue + if (i.gt.nT_h(iparm)) then + write (iout,*) "Error - temperature of conformation", + & ii,1.0d0/(rt_bath*1.987D-3), + & " does not match any of the list" + write (iout,*) + & 1.0d0/(rt_bath*1.987D-3), + & (1.0d0/(beta_h(i,iparm)*1.987D-3),i=1,nT_h(iparm)) + call flush(iout) +c exit +c call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) + ii=ii-1 + kk(islice)=kk(islice)-1 + mm(islice)=mm(islice)-1 + goto 112 + endif + else + iib = ib + endif + + efree=0.0d0 + jj(islice)=jj(islice)+1 + if (umbrella(iparm)) then + snk(iset,iib,iparm,islice)=snk(iset,iib,iparm,islice)+1 + else if (hamil_rep) then + snk(1,iib,iparm,islice)=snk(1,iib,iparm,islice)+1 + else + snk(iR,iib,iparm,islice)=snk(iR,iib,iparm,islice)+1 + endif + ll(islice)=ll(islice)+1 +#ifdef DEBUG + write (iout,*) "Writing conformation, record",ll(islice) + write (iout,*) "ib",ib," iib",iib + write (iout,*) "ntraj",ntraj," itraj",itraj, + & " nstep",nstep(itraj) + write (iout,*) "pote",rpotE," time",rtime +c if (replica(iparm)) then +c write (iout,*) "TEMP",1.0d0/(rt_bath*1.987D-3) +c write (iout,*) "TEMP list" +c write (iout,*) +c & (1.0d0/(beta_h(i,iparm)*1.987D-3),i=1,nT_h(iparm)) +c endif + write (iout,*) "iparm",iparm," ib",ib," iR",iR," nQ",nQ +c write (iout,*) "nres",nres," nnt",nnt," nct",nct," nss",nss +c write (iout,*) "length",nres*4+(nct-nnt+1)*4+4+2*nss*4 + call flush(iout) +#endif + if (islice.ne.islice1) then +c write (iout,*) "islice",islice," islice1",islice1 + close(ientout) +c write (iout,*) "Closing file ", +c & bprotfile_temp(:ilen(bprotfile_temp)) + call opentmp(islice,ientout,bprotfile_temp) +c write (iout,*) "Opening file ", +c & bprotfile_temp(:ilen(bprotfile_temp)) + islice1=islice + endif + if (umbrella(iparm)) then + write(ientout,rec=ll(islice)) + & ((xoord(l,k),l=1,3),k=1,nres), + & ((xoord(l,k),l=1,3),k=nres+1,nres+nct-nnt+1), + & nss,(ihpb(k),jhpb(k),k=1,nss), + & rpotE+0.0d0,efree,rmsdev,(rprop(i)+0.0d0,i=1,nQ), + & iset,iib,iparm + else if (hamil_rep) then + write(ientout,rec=ll(islice)) + & ((xoord(l,k),l=1,3),k=1,nres), + & ((xoord(l,k),l=1,3),k=nres+1,nres+nct-nnt+1), + & nss,(ihpb(k),jhpb(k),k=1,nss), + & rpotE+0.0d0,efree,rmsdev,(rprop(i)+0.0d0,i=1,nQ), + & iR,iib,iset + else + write(ientout,rec=ll(islice)) + & ((xoord(l,k),l=1,3),k=1,nres), + & ((xoord(l,k),l=1,3),k=nres+1,nres+nct-nnt+1), + & nss,(ihpb(k),jhpb(k),k=1,nss), + & rpotE+0.0d0,efree,rmsdev,(rprop(i)+0.0d0,i=1,nQ), + & iR,iib,iparm + endif +#ifdef PDBOUT +#ifdef MPI + if (me.eq.Master) then +#endif + write (iout,*) "PDBOUT" + write (iout,*) "temperature",1.0d0/(rt_bath*1.987D-3) + call flush(iout) + write (lt_bath,'(f4.0)') 1.0d0/(rt_bath*1.987D-3) + write (iout,*) "lt_bath ",lt_bath + pdbfilename=prefix(:ilen(prefix))//"_"//lt_bath//"pdb" + write (iout,*) "pdb ",pdbfilename + call flush(iout) + open(ipdb,file=pdbfilename,position="append") +c write (tytul,'("Conformation",i10," T=",f5.1)') +c & kk(islice),rt_bath + call pdbout(kk(islice),1.0d0/(rt_bath*1.987D-3), + & efree+0.0d0,rpotE+0.0d0,efree+0.0d0,rmsdev+0.0d0) + close(ipdb) +#ifdef MPI + endif +#endif +#endif +#ifdef DEBUG + call int_from_cart1(.false.) + write (iout,*) "Writing conformation, record",ll(islice) + write (iout,*) "Cartesian coordinates" + write (iout,'(8f10.5)') ((c(j,i),j=1,3),i=1,nres) + write (iout,'(8f10.5)') ((c(j,i+nres),j=1,3),i=nnt,nct) + write (iout,*) "Internal coordinates" + write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) + write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) + write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) + write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) + write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) + write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) + write (iout,'(16i5)') nss,(ihpb(k),jhpb(k),k=1,nss) +c write (iout,'(8f10.5)') (rprop(j),j=1,nQ) + write (iout,'(16i5)') iscor + call flush(iout) +#endif + endif + endif + + 112 continue + + enddo + close(ientout) +#if (defined(AIX) && !defined(JUBL)) + call xdrfclose_(ixdrf, iret) +#else + call xdrfclose(ixdrf, iret) +#endif + write (iout,'(i10," trajectories found in file.")') ntraj+1 + write (iout,'(a)') "Numbers of steps in trajectories:" + write (iout,'(8i10)') (nstep(i),i=0,ntraj) + write (iout,*) ii," conformations read from file", + & nazwa(:ilen(nazwa)) + do islice=1,nslice + write (iout,*) mm(islice)," conformations read so far, slice", + & islice + write (iout,*) ll(islice), + & " conformations stored so far, slice",islice + enddo + call flush(iout) + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/cxread.F.org b/source/wham/src-NEWSC-NEWCORR/cxread.F.org new file mode 100644 index 0000000..80bc1a0 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/cxread.F.org @@ -0,0 +1,248 @@ + subroutine cxread(nazwa,ii,jj,kk,ll,mm,iR,ib,iparm,*) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.FREE' + integer MaxTraj + parameter (MaxTraj=2050) + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.HEADER' + include 'COMMON.SBRIDGE' + include 'COMMON.PROTFILES' + include 'COMMON.OBCINKA' + include 'COMMON.FREE' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.PROT' + character*64 nazwa,bprotfile_temp + real*4 rtime,rpotE,ruconst,rt_bath,rprop(maxQ) + double precision time + integer iret,itmp,itraj,ntraj + real xoord(3,maxres2+2),prec + integer nstep(0:MaxTraj-1) + integer ilen + external ilen + integer ii,jj(maxslice),kk(maxslice),ll(maxslice),mm(maxslice) + integer is(MaxSlice),ie(MaxSlice),nrec_slice + double precision ts(MaxSlice),te(MaxSlice),time_slice + integer slice + call set_slices(is,ie,ts,te,iR,ib,iparm) + + do i=1,nQ + rprop(i)=0.0d0 + enddo + do i=0,MaxTraj-1 + nstep(i)=0 + enddo + ntraj=0 + it=0 + iret=1 +#if (defined(AIX) && !defined(JUBL)) + call xdrfopen_(ixdrf,nazwa, "r", iret) +#else + call xdrfopen(ixdrf,nazwa, "r", iret) +#endif + if (iret.eq.0) return1 + + islice1=1 + call opentmp(islice1,ientout,bprotfile_temp) +c print *,"bumbum" + do while (iret.gt.0) + +#if (defined(AIX) && !defined(JUBL)) + call xdrffloat_(ixdrf, rtime, iret) +c print *,"rtime",rtime," iret",iret + call xdrffloat_(ixdrf, rpotE, iret) +c write (iout,*) "rpotE",rpotE," iret",iret + call flush(iout) + call xdrffloat_(ixdrf, ruconst, iret) + call xdrffloat_(ixdrf, rt_bath, iret) + call xdrfint_(ixdrf, nss, iret) + do j=1,nss + call xdrfint_(ixdrf, ihpb(j), iret) + call xdrfint_(ixdrf, jhpb(j), iret) + enddo + call xdrfint_(ixdrf, nprop, iret) + do i=1,nprop + call xdrffloat_(ixdrf, rprop(i), iret) + enddo +#else + call xdrffloat(ixdrf, rtime, iret) + call xdrffloat(ixdrf, rpotE, iret) +c write (iout,*) "rpotE",rpotE," iret",iret + call flush(iout) + call xdrffloat(ixdrf, ruconst, iret) + call xdrffloat(ixdrf, rt_bath, iret) + call xdrfint(ixdrf, nss, iret) + do j=1,nss + call xdrfint(ixdrf, ihpb(j), iret) + call xdrfint(ixdrf, jhpb(j), iret) + enddo + call xdrfint(ixdrf, nprop, iret) +c write (iout,*) "nprop",nprop + call flush(iout) + do i=1,nprop + call xdrffloat(ixdrf, rprop(i), iret) + enddo +#endif + if (iret.eq.0) exit + itraj=mod(it,totraj(iR,iparm)) +#ifdef DEBUG + write (iout,*) "ii",ii," itraj",itraj +#endif + call flush(iout) + it=it+1 + if (itraj.gt.ntraj) ntraj=itraj + nstep(itraj)=nstep(itraj)+1 +#ifdef DEBUG + write (iout,*) rtime,rpotE,rt_bath,nss, + & (ihpb(j),jhpb(j),j=1,nss),(rprop(j),j=1,nprop) + call flush(iout) +#endif + prec=10000.0 + + itmp=0 +#if (defined(AIX) && !defined(JUBL)) + call xdrf3dfcoord_(ixdrf, xoord, itmp, prec, iret) +#else + call xdrf3dfcoord(ixdrf, xoord, itmp, prec, iret) +#endif +#ifdef DEBUG + write (iout,'(10f8.3)') ((xoord(j,i),j=1,3),i=1,itmp) +#endif + if (iret.eq.0) exit + if (itmp .ne. nres + nct - nnt + 1) then + write (iout,*) "Error: inconsistent sizes",itmp,nres+nct-nnt+1 + call flush(iout) + exit + endif + + time=rtime +c write (iout,*) "calling slice" +c call flush(iout) + islice=slice(nstep(itraj),time,is,ie,ts,te) +c write (iout,*) "islice",islice +c call flush(iout) + + if (islice.gt.0 .and. islice.le.nslice) then + ii=ii+1 + kk(islice)=kk(islice)+1 + mm(islice)=mm(islice)+1 + if (mod(nstep(itraj),isampl(iparm)).eq.0) then + if (replica(iparm)) then + rt_bath=1.0d0/(rt_bath*1.987D-3) + do i=1,nT_h(iparm) + if (abs(real(beta_h(i,iparm))-rt_bath).lt.1.0e-4) then + iib = i + goto 22 + endif + enddo + 22 continue + if (i.gt.nT_h(iparm)) then + write (iout,*) "Error - temperature of conformation", + & ii,1.0d0/(rt_bath*1.987D-3), + & " does not match any of the list" + write (iout,*) + & 1.0d0/(rt_bath*1.987D-3), + & (1.0d0/(beta_h(i,iparm)*1.987D-3),i=1,nT_h(iparm)) + call flush(iout) + exit + call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) + endif + else + iib = ib + endif + + efree=0.0d0 + jj(islice)=jj(islice)+1 + snk(iR,iib,iparm,islice)=snk(iR,iib,iparm,islice)+1 + ll(islice)=ll(islice)+1 +#ifdef DEBUG + write (iout,*) "Writing conformation, record",ll(islice) + write (iout,*) "ib",ib," iib",iib + write (iout,*) "ntraj",ntraj," itraj",itraj, + & " nstep",nstep(itraj) + write (iout,*) "pote",rpotE," time",rtime +c if (replica(iparm)) then +c write (iout,*) "TEMP",1.0d0/(rt_bath*1.987D-3) +c write (iout,*) "TEMP list" +c write (iout,*) +c & (1.0d0/(beta_h(i,iparm)*1.987D-3),i=1,nT_h(iparm)) +c endif + write (iout,*) "iparm",iparm," ib",ib," iR",iR," nQ",nQ +c write (iout,*) "nres",nres," nnt",nnt," nct",nct," nss",nss +c write (iout,*) "length",nres*4+(nct-nnt+1)*4+4+2*nss*4 + call flush(iout) +#endif + if (islice.ne.islice1) then +c write (iout,*) "islice",islice," islice1",islice1 + close(ientout) +c write (iout,*) "Closing file ", +c & bprotfile_temp(:ilen(bprotfile_temp)) + call opentmp(islice,ientout,bprotfile_temp) +c write (iout,*) "Opening file ", +c & bprotfile_temp(:ilen(bprotfile_temp)) + islice1=islice + endif + write(ientout,rec=ll(islice)) + & ((xoord(l,k),l=1,3),k=1,nres), + & ((xoord(l,k),l=1,3),k=nres+1,nres+nct-nnt+1), + & nss,(ihpb(k),jhpb(k),k=1,nss), + & rpotE+0.0d0,efree,rmsdev,(rprop(i)+0.0d0,i=1,nQ), + & iR,iib,iparm +#ifdef DEBUG + do i=1,nres + do j=1,3 + c(j,i)=xoord(j,i) + enddo + enddo + do i=1,nct-nnt+1 + do j=1,3 + c(j,i+nres+nnt-1)=xoord(j,i+nres) + enddo + enddo + call int_from_cart1(.false.) + write (iout,*) "Writing conformation, record",ll(islice) + write (iout,*) "Cartesian coordinates" + write (iout,'(8f10.5)') ((c(j,i),j=1,3),i=1,nres) + write (iout,'(8f10.5)') ((c(j,i+nres),j=1,3),i=nnt,nct) + write (iout,*) "Internal coordinates" + write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) + write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) + write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) + write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) + write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) + write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) + write (iout,'(16i5)') nss,(ihpb(k),jhpb(k),k=1,nss) +c write (iout,'(8f10.5)') (rprop(j),j=1,nQ) + write (iout,'(16i5)') iscor + call flush(iout) +#endif + endif + endif + + enddo + 112 continue + close(ientout) +#if (defined(AIX) && !defined(JUBL)) + call xdrfclose_(ixdrf, iret) +#else + call xdrfclose(ixdrf, iret) +#endif + write (iout,'(i10," trajectories found in file.")') ntraj+1 + write (iout,'(a)') "Numbers of steps in trajectories:" + write (iout,'(8i10)') (nstep(i),i=0,ntraj) + write (iout,*) ii," conformations read from file", + & nazwa(:ilen(nazwa)) + do islice=1,nslice + write (iout,*) mm(islice)," conformations read so far, slice", + & islice + write (iout,*) ll(islice), + & " conformations stored so far, slice",islice + enddo + call flush(iout) + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/define_pairs.f b/source/wham/src-NEWSC-NEWCORR/define_pairs.f new file mode 100644 index 0000000..00866a8 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/define_pairs.f @@ -0,0 +1,120 @@ + subroutine define_pairs + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.COMPAR' + include 'COMMON.IOUNITS' + include 'COMMON.TIME1' + include 'COMMON.SBRIDGE' + include 'COMMON.CONTROL' + include 'COMMON.COMPAR' + include 'COMMON.FRAG' + include 'COMMON.CHAIN' + include 'COMMON.HEADER' + include 'COMMON.GEO' + include 'COMMON.CONTACTS1' + include 'COMMON.PEPTCONT' + do j=1,nfrag(1) + length_frag = 0 + do k=1,npiece(j,1) + length_frag=length_frag+ifrag(2,k,j)-ifrag(1,k,j)+1 + enddo + len_frag(j,1)=length_frag + write (iout,*) "Fragment",j," length",len_frag(j,1) + enddo + nfrag(2)=0 + do i=1,nfrag(1) + do j=i+1,nfrag(1) + ind = icant(i,j) + if (istruct(i).le.1 .or. istruct(j).le.1) then + if (istruct(i).le.1) then + ll1=len_frag(i,1) + else + ll1=len_frag(i,1)/2 + endif + if (istruct(j).le.1) then + ll2=len_frag(j,1) + else + ll2=len_frag(j,1)/2 + endif + len_cut=max0(min0(ll1*2/3,ll2*4/5),3) + else + if (istruct(i).eq.2 .or. istruct(i).eq.4) then + ll1=len_frag(i,1)/2 + else + ll1=len_frag(i,1) + endif + if (istruct(j).eq.2 .or. istruct(j).eq.4) then + ll2=len_frag(j,1)/2 + else + ll2=len_frag(j,1) + endif + len_cut=max0(min0(ll1*4/5,ll2)*4/5,3) + endif + write (iout,*) "Fragments",i,j," structure",istruct(i), + & istruct(j)," # contacts", + & ncont_frag_ref(ind),nsccont_frag_ref(ind), + & " lengths",len_frag(i,1),len_frag(j,1), + & " ll1",ll1," ll2",ll2," len_cut",len_cut + if ((istruct(i).eq.1 .or. istruct(j).eq.1) .and. + & nsccont_frag_ref(ind).ge.len_cut ) then + if (istruct(i).eq.1 .and. istruct(j).eq.1) then + write (iout,*) "Adding pair of helices",i,j, + & " based on SC contacts" + else + write (iout,*) "Adding helix+strand/sheet pair",i,j, + & " based on SC contacts" + endif + nfrag(2)=nfrag(2)+1 + if (icont_pair.gt.0) then + write (iout,*) "# SC contacts will be used", + & " in comparison." + isccont(nfrag(2),2)=1 + endif + if (irms_pair.gt.0) then + write (iout,*) "Fragment RMSD will be used", + & " in comparison." + irms(nfrag(2),2)=1 + endif + npiece(nfrag(2),2)=2 + ipiece(1,nfrag(2),2)=i + ipiece(2,nfrag(2),2)=j + ielecont(nfrag(2),2)=0 + n_shift(1,nfrag(2),2)=nshift_pair + n_shift(2,nfrag(2),2)=nshift_pair + nc_fragm(nfrag(2),2)=ncfrac_pair + nc_req_setf(nfrag(2),2)=ncreq_pair + else if ((istruct(i).ge.2 .and. istruct(i).le.4) + & .and. (istruct(j).ge.2 .and. istruct(i).le.4) + & .and. ncont_frag_ref(ind).ge.len_cut ) then + nfrag(2)=nfrag(2)+1 + write (iout,*) "Adding pair strands/sheets",i,j, + & " based on pp contacts" + if (icont_pair.gt.0) then + write (iout,*) "# pp contacts will be used", + & " in comparison." + ielecont(nfrag(2),2)=1 + endif + if (irms_pair.gt.0) then + write (iout,*) "Fragment RMSD will be used", + & " in comparison." + irms(nfrag(2),2)=1 + endif + npiece(nfrag(2),2)=2 + ipiece(1,nfrag(2),2)=i + ipiece(2,nfrag(2),2)=j + ielecont(nfrag(2),2)=1 + isccont(nfrag(2),2)=0 + n_shift(1,nfrag(2),2)=nshift_pair + n_shift(2,nfrag(2),2)=nshift_pair + nc_fragm(nfrag(2),2)=ncfrac_bet + nc_req_setf(nfrag(2),2)=ncreq_bet + endif + enddo + enddo + write (iout,*) "Pairs found" + do i=1,nfrag(2) + write (iout,*) ipiece(1,i,2),ipiece(2,i,2) + enddo + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/elecont.f b/source/wham/src-NEWSC-NEWCORR/elecont.f new file mode 100644 index 0000000..1eff2f1 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/elecont.f @@ -0,0 +1,207 @@ + subroutine elecont(lprint,ncont,icont,ist,ien) + implicit none + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.COMPAR' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.NAMES' + include 'COMMON.LOCAL' + logical lprint + integer i,j,k,ist,ien,iteli,itelj,ind,i1,i2,it1,it2,ic1,ic2 + double precision rri,xi,yi,zi,dxi,dyi,dzi,xmedi,ymedi,zmedi, + & xj,yj,zj,dxj,dyj,dzj,aaa,bbb,ael6i,ael3i,rrmij,rmij,r3ij,r6ij, + & vrmij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,evdwij,el1,el2, + & eesij,ees,evdw,ene + double precision elpp6c(2,2),elpp3c(2,2),ael6c(2,2),ael3c(2,2), + & appc(2,2),bppc(2,2) + double precision elcutoff,elecutoff_14 + integer ncont,icont(2,maxcont) + double precision econt(maxcont) +* +* Load the constants of peptide bond - peptide bond interactions. +* Type 1 - ordinary peptide bond, type 2 - alkylated peptide bond (e.g. +* proline) - determined by averaging ECEPP energy. +* +* as of 7/06/91. +* +c data epp / 0.3045d0, 0.3649d0, 0.3649d0, 0.5743d0/ +c data rpp / 4.5088d0, 4.5395d0, 4.5395d0, 4.4846d0/ + data elpp6c /-0.2379d0,-0.2056d0,-0.2056d0,-0.0610d0/ + data elpp3c / 0.0503d0, 0.0000d0, 0.0000d0, 0.0692d0/ + data elcutoff /-0.3d0/,elecutoff_14 /-0.5d0/ + ees=0.0d0 + evdw=0.0d0 + if (lprint) write (iout,'(a)') + & "Constants of electrostatic interaction energy expression." + do i=1,2 + do j=1,2 + rri=rpp(i,j)**6 + appc(i,j)=epp(i,j)*rri*rri + bppc(i,j)=-2.0*epp(i,j)*rri + ael6c(i,j)=elpp6c(i,j)*4.2**6 + ael3c(i,j)=elpp3c(i,j)*4.2**3 + if (lprint) + & write (iout,'(2i2,4e15.4)') i,j,appc(i,j),bppc(i,j),ael6c(i,j), + & ael3c(i,j) + enddo + enddo + ncont=0 + do 1 i=ist,ien-2 + xi=c(1,i) + yi=c(2,i) + zi=c(3,i) + dxi=c(1,i+1)-c(1,i) + dyi=c(2,i+1)-c(2,i) + dzi=c(3,i+1)-c(3,i) + xmedi=xi+0.5*dxi + ymedi=yi+0.5*dyi + zmedi=zi+0.5*dzi + do 4 j=i+2,ien-1 + ind=ind+1 + iteli=itel(i) + itelj=itel(j) + if (j.eq.i+2 .and. itelj.eq.2) iteli=2 + if (iteli.eq.2 .and. itelj.eq.2) goto 4 + aaa=appc(iteli,itelj) + bbb=bppc(iteli,itelj) + ael6i=ael6c(iteli,itelj) + ael3i=ael3c(iteli,itelj) + dxj=c(1,j+1)-c(1,j) + dyj=c(2,j+1)-c(2,j) + dzj=c(3,j+1)-c(3,j) + xj=c(1,j)+0.5*dxj-xmedi + yj=c(2,j)+0.5*dyj-ymedi + zj=c(3,j)+0.5*dzj-zmedi + rrmij=1.0/(xj*xj+yj*yj+zj*zj) + rmij=sqrt(rrmij) + r3ij=rrmij*rmij + r6ij=r3ij*r3ij + vrmij=vblinv*rmij + cosa=(dxi*dxj+dyi*dyj+dzi*dzj)*vblinv2 + cosb=(xj*dxi+yj*dyi+zj*dzi)*vrmij + cosg=(xj*dxj+yj*dyj+zj*dzj)*vrmij + fac=cosa-3.0*cosb*cosg + ev1=aaa*r6ij*r6ij + ev2=bbb*r6ij + fac3=ael6i*r6ij + fac4=ael3i*r3ij + evdwij=ev1+ev2 + el1=fac3*(4.0+fac*fac-3.0*(cosb*cosb+cosg*cosg)) + el2=fac4*fac + eesij=el1+el2 + if (j.gt.i+2 .and. eesij.le.elcutoff .or. + & j.eq.i+2 .and. eesij.le.elecutoff_14) then + ncont=ncont+1 + icont(1,ncont)=i + icont(2,ncont)=j + econt(ncont)=eesij + endif + ees=ees+eesij + evdw=evdw+evdwij + 4 continue + 1 continue + if (lprint) then + write (iout,*) 'Total average electrostatic energy: ',ees + write (iout,*) 'VDW energy between peptide-group centers: ',evdw + write (iout,*) + write (iout,*) 'Electrostatic contacts before pruning: ' + do i=1,ncont + i1=icont(1,i) + i2=icont(2,i) + it1=itype(i1) + it2=itype(i2) + write (iout,'(i3,2x,a,i4,2x,a,i4,f10.5)') + & i,restyp(it1),i1,restyp(it2),i2,econt(i) + enddo + endif +c For given residues keep only the contacts with the greatest energy. + i=0 + do while (i.lt.ncont) + i=i+1 + ene=econt(i) + ic1=icont(1,i) + ic2=icont(2,i) + j=i + do while (j.lt.ncont) + j=j+1 + if (ic1.eq.icont(1,j).and.iabs(icont(2,j)-ic2).le.2 .or. + & ic2.eq.icont(2,j).and.iabs(icont(1,j)-ic1).le.2) then +c write (iout,*) "i",i," j",j," ic1",ic1," ic2",ic2, +c & " jc1",icont(1,j)," jc2",icont(2,j)," ncont",ncont + if (econt(j).lt.ene .and. icont(2,j).ne.icont(1,j)+2) then + if (ic1.eq.icont(1,j)) then + do k=1,ncont + if (k.ne.i .and. k.ne.j .and. icont(2,k).eq.icont(2,j) + & .and. iabs(icont(1,k)-ic1).le.2 .and. + & econt(k).lt.econt(j) ) goto 21 + enddo + else if (ic2.eq.icont(2,j) ) then + do k=1,ncont + if (k.ne.i .and. k.ne.j .and. icont(1,k).eq.icont(1,j) + & .and. iabs(icont(2,k)-ic2).le.2 .and. + & econt(k).lt.econt(j) ) goto 21 + enddo + endif +c Remove ith contact + do k=i+1,ncont + icont(1,k-1)=icont(1,k) + icont(2,k-1)=icont(2,k) + econt(k-1)=econt(k) + enddo + i=i-1 + ncont=ncont-1 +c write (iout,*) "ncont",ncont +c do k=1,ncont +c write (iout,*) icont(1,k),icont(2,k) +c enddo + goto 20 + else if (econt(j).gt.ene .and. ic2.ne.ic1+2) + & then + if (ic1.eq.icont(1,j)) then + do k=1,ncont + if (k.ne.i .and. k.ne.j .and. icont(2,k).eq.ic2 + & .and. iabs(icont(1,k)-icont(1,j)).le.2 .and. + & econt(k).lt.econt(i) ) goto 21 + enddo + else if (ic2.eq.icont(2,j) ) then + do k=1,ncont + if (k.ne.i .and. k.ne.j .and. icont(1,k).eq.ic1 + & .and. iabs(icont(2,k)-icont(2,j)).le.2 .and. + & econt(k).lt.econt(i) ) goto 21 + enddo + endif +c Remove jth contact + do k=j+1,ncont + icont(1,k-1)=icont(1,k) + icont(2,k-1)=icont(2,k) + econt(k-1)=econt(k) + enddo + ncont=ncont-1 +c write (iout,*) "ncont",ncont +c do k=1,ncont +c write (iout,*) icont(1,k),icont(2,k) +c enddo + j=j-1 + endif + endif + 21 continue + enddo + 20 continue + enddo + if (lprint) then + write (iout,*) + write (iout,*) 'Electrostatic contacts after pruning: ' + do i=1,ncont + i1=icont(1,i) + i2=icont(2,i) + it1=itype(i1) + it2=itype(i2) + write (iout,'(i3,2x,a,i4,2x,a,i4,f10.5)') + & i,restyp(it1),i1,restyp(it2),i2,econt(i) + enddo + endif + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/enecalc1.F b/source/wham/src-NEWSC-NEWCORR/enecalc1.F new file mode 100644 index 0000000..c9f4de8 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/enecalc1.F @@ -0,0 +1,780 @@ + subroutine enecalc(islice,*) + implicit none + include "DIMENSIONS" + include "DIMENSIONS.ZSCOPT" + include "DIMENSIONS.FREE" +#ifdef MPI + include "mpif.h" + integer IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE) + include "COMMON.MPI" +#endif + include "COMMON.CHAIN" + include "COMMON.IOUNITS" + include "COMMON.PROTFILES" + include "COMMON.NAMES" + include "COMMON.VAR" + include "COMMON.SBRIDGE" + include "COMMON.GEO" + include "COMMON.FFIELD" + include "COMMON.ENEPS" + include "COMMON.LOCAL" + include "COMMON.WEIGHTS" + include "COMMON.INTERACT" + include "COMMON.FREE" + include "COMMON.ENERGIES" + include "COMMON.CONTROL" + include "COMMON.TORCNSTR" + character*64 nazwa + character*80 bxname + character*3 liczba + double precision qwolynes + external qwolynes + integer errmsg_count,maxerrmsg_count /100/ + double precision rmsnat,gyrate + external rmsnat,gyrate + double precision tole /1.0d-1/ + integer i,itj,ii,iii,j,k,l,licz + integer ir,ib,ipar,iparm + integer iscor,islice + real*4 csingle(3,maxres2) + double precision energ + integer ilen,iroof + external ilen,iroof + double precision energia(0:max_ene),rmsdev,efree,eini + double precision fT(6),quot,quotl,kfacl,kfac /2.4d0/,T0 /3.0d2/ + double precision tt + integer snk_p(MaxR,MaxT_h,Max_parm) + logical lerr + character*64 bprotfile_temp + call opentmp(islice,ientout,bprotfile_temp) + iii=0 + ii=0 + errmsg_count=0 + write (iout,*) "enecalc: nparmset ",nparmset +#ifdef MPI + do iparm=1,nParmSet + do ib=1,nT_h(iparm) + do i=1,nR(ib,iparm) + snk_p(i,ib,iparm)=0 + enddo + enddo + enddo + do i=indstart(me1),indend(me1) +#else + do iparm=1,nParmSet + do ib=1,nT_h(iparm) + do i=1,nR(ib,iparm) + snk(i,ib,iparm)=0 + enddo + enddo + enddo + do i=1,ntot +#endif + read(ientout,rec=i,err=101) + & ((csingle(l,k),l=1,3),k=1,nres), + & ((csingle(l,k+nres),l=1,3),k=nnt,nct), + & nss,(ihpb(k),jhpb(k),k=1,nss), + & eini,efree,rmsdev,(q(j,iii+1),j=1,nQ),iR,ib,ipar + if (indpdb.gt.0) then + do k=1,nres + do l=1,3 + c(l,k)=csingle(l,k) + enddo + enddo + do k=nnt,nct + do l=1,3 + c(l,k+nres)=csingle(l,k+nres) + enddo + enddo + q(nQ+1,iii+1)=rmsnat(iii+1) + endif + q(nQ+2,iii+1)=gyrate(iii+1) +c fT=T0*beta_h(ib,ipar)*1.987D-3 +c ft=2.0d0/(1.0d0+1.0d0/(T0*beta_h(ib,ipar)*1.987D-3)) + if (rescale_mode.eq.1) then + quot=1.0d0/(T0*beta_h(ib,ipar)*1.987D-3) +#if defined(FUNCTH) + tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3) + ft(6)=(320.0+80.0*dtanh((tt-320.0)/80.0))/320.0 +#elif defined(FUNCT) + ft(6)=quot +#else + ft(6)=1.0d0 +#endif + quotl=1.0d0 + kfacl=1.0d0 + do l=1,5 + quotl=quotl*quot + kfacl=kfacl*kfac + fT(l)=kfacl/(kfacl-1.0d0+quotl) + enddo + else if (rescale_mode.eq.2) then + quot=1.0d0/(T0*beta_h(ib,ipar)*1.987D-3) +#if defined(FUNCTH) + tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3) + ft(6)=(320.0+80.0*dtanh((tt-320.0)/80.0))/320.0 +#elif defined(FUNCT) + ft(6)=quot +#else + ft(6)=1.0d0 +#endif + quotl=1.0d0 + do l=1,5 + quotl=quotl*quot + fT(l)=1.12692801104297249644d0/ + & dlog(dexp(quotl)+dexp(-quotl)) + enddo + else if (rescale_mode.eq.0) then + do l=1,5 + fT(l)=1.0d0 + enddo + else + write (iout,*) "Error in ECECALC: wrong RESCALE_MODE", + & rescale_mode + call flush(iout) + return1 + endif + +c write (iout,*) "T",1.0d0/(beta_h(ib,ipar)*1.987D-3)," T0",T0, +c & " kfac",kfac,"quot",quot," fT",fT + do j=1,2*nres + do k=1,3 + c(k,j)=csingle(k,j) + enddo + enddo + call int_from_cart1(.false.) + ii=ii+1 + do iparm=1,nparmset + + call restore_parm(iparm) +#ifdef DEBUG + write (iout,*) wsc,wscp,welec,wvdwpp,wang,wtor,wscloc, + & wcorr,wcorr5,wcorr6,wturn4,wturn3,wturn6,wel_loc, + & wtor_d,wsccor,wbond +#endif +c write (iout,*) "Calling ETOTAL" + call etotal(energia(0),fT,beta_h(ib,iparm)) +#ifdef DEBUG + write (iout,*) "Conformation",i + call enerprint(energia(0),fT) +c write (iout,'(2i5,21f8.2)') i,iparm,(energia(k),k=1,21) +c write (iout,*) "ftors",ftors +c call intout +#endif + if (energia(0).ge.1.0d20) then + write (iout,*) "NaNs detected in some of the energy", + & " components for conformation",ii+1 + write (iout,*) "The Cartesian geometry is:" + write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) + write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) + write (iout,*) "The internal geometry is:" +c call intout +c call pdbout(ii+1,beta_h(ib,ipar),efree,energia(0),0.0d0,rmsdev) + write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) + write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) + write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) + write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) + write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) + write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) + write (iout,*) "The components of the energy are:" + call enerprint(energia(0),fT) + write (iout,*) + & "This conformation WILL NOT be added to the database." + call flush(iout) + goto 121 + else +#ifdef DEBUG + if (ipar.eq.iparm) write (iout,*) i,iparm, + & 1.0d0/(beta_h(ib,ipar)*1.987D-3),eini,energia(0) +#endif + if (ipar.eq.iparm .and. einicheck.gt.0 .and. + & dabs(eini-energia(0)).gt.tole) then + if (errmsg_count.le.maxerrmsg_count) then + write (iout,'(2a,2e15.5,a,2i8,a,f8.1)') + & "Warning: energy differs remarkably from ", + & " the value read in: ",energia(0),eini," point", + & iii+1,indstart(me1)+iii," T", + & 1.0d0/(1.987D-3*beta_h(ib,ipar)) + errmsg_count=errmsg_count+1 + if (errmsg_count.gt.maxerrmsg_count) + & write (iout,*) "Too many warning messages" + if (einicheck.gt.1) then + write (iout,*) "Calculation stopped." + call flush(iout) +#ifdef MPI + call MPI_Abort(WHAM_COMM,IERROR,ERRCODE) +#endif + call flush(iout) + return1 + endif + endif + endif + potE(iii+1,iparm)=energia(0) + do k=1,21 + enetb(k,iii+1,iparm)=energia(k) + enddo +#ifdef DEBUG + write (iout,'(2i5,f10.1,3e15.5)') i,iii, + & 1.0d0/(beta_h(ib,ipar)*1.987D-3),energia(0),eini,efree + call enerprint(energia(0),fT) + write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) + write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) + write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) + write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) + write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) + write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) + write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) + write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) + write (iout,'(16i5)') nss,(ihpb(k),jhpb(k),k=1,nss) + write (iout,'(8f10.5)') (q(k,iii+1),k=1,nQ) + write (iout,'(f10.5,i10)') rmsdev,iscor + call enerprint(energia(0),fT) + write(liczba,'(bz,i3.3)') me + nazwa="test"//liczba//".pdb" + write (iout,*) "pdb file",nazwa + open (ipdb,file=nazwa,position="append") + call pdbout(ii+1,beta_h(ib,ipar),efree,energia(0),0.0d0,rmsdev) + close(ipdb) +#endif + endif + + enddo ! iparm + + iii=iii+1 + if (q(1,iii).le.0.0d0 .and. indpdb.gt.0) q(1,iii)=qwolynes(0,0) + write (ientout,rec=iii) + & ((csingle(l,k),l=1,3),k=1,nres), + & ((csingle(l,k+nres),l=1,3),k=nnt,nct), + & nss,(ihpb(k),jhpb(k),k=1,nss), + & potE(iii,ipar),efree,rmsdev,(q(k,iii),k=1,nQ),iR,ib,ipar +c write (iout,'(2i5,2e15.5)') ii,iii,potE(iii,ipar),efree +#ifdef MPI + if (separate_parset) then + snk_p(iR,ib,1)=snk_p(iR,ib,1)+1 + else + snk_p(iR,ib,ipar)=snk_p(iR,ib,ipar)+1 + endif +c write (iout,*) "iii",iii," iR",iR," ib",ib," ipar",ipar, +c & " snk",snk_p(iR,ib,ipar) +#else + snk(iR,ib,ipar,islice)=snk(iR,ib,ipar,islice)+1 +#endif + 121 continue + enddo +#ifdef MPI + scount(me)=iii + write (iout,*) "Me",me," scount",scount(me) + call flush(iout) +c Master gathers updated numbers of conformations written by all procs. + call MPI_AllGather( scount(me), 1, MPI_INTEGER, scount(0), 1, + & MPI_INTEGER, WHAM_COMM, IERROR) + indstart(0)=1 + indend(0)=scount(0) + do i=1, Nprocs-1 + indstart(i)=indend(i-1)+1 + indend(i)=indstart(i)+scount(i)-1 + enddo + write (iout,*) + write (iout,*) "Revised conformation counts" + do i=0,nprocs1-1 + write (iout,'(a,i5,a,i7,a,i7,a,i7)') + & "Processor",i," indstart",indstart(i), + & " indend",indend(i)," count",scount(i) + enddo + call flush(iout) + call MPI_AllReduce(snk_p(1,1,1),snk(1,1,1,islice), + & MaxR*MaxT_h*nParmSet, + & MPI_INTEGER,MPI_SUM,WHAM_COMM,IERROR) +#endif + stot(islice)=0 + do iparm=1,nParmSet + do ib=1,nT_h(iparm) + do i=1,nR(ib,iparm) + stot(islice)=stot(islice)+snk(i,ib,iparm,islice) + enddo + enddo + enddo + write (iout,*) "Revised SNK" + do iparm=1,nParmSet + do ib=1,nT_h(iparm) + write (iout,'("Param",i3," Temp",f6.1,3x,32i8)') + & iparm,1.0d0/(1.987D-3*beta_h(ib,iparm)), + & (snk(i,ib,iparm,islice),i=1,nR(ib,iparm)) + write (iout,*) "snk_p",(snk_p(i,ib,iparm),i=1,nR(ib,iparm)) + enddo + enddo + write (iout,'("Total",i10)') stot(islice) + call flush(iout) + return + 101 write (iout,*) "Error in scratchfile." + call flush(iout) + return1 + end +c------------------------------------------------------------------------------ + subroutine write_dbase(islice,*) + implicit none + include "DIMENSIONS" + include "DIMENSIONS.ZSCOPT" + include "DIMENSIONS.FREE" + include "DIMENSIONS.COMPAR" +#ifdef MPI + include "mpif.h" + integer IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE) + include "COMMON.MPI" +#endif + include "COMMON.CONTROL" + include "COMMON.CHAIN" + include "COMMON.IOUNITS" + include "COMMON.PROTFILES" + include "COMMON.NAMES" + include "COMMON.VAR" + include "COMMON.SBRIDGE" + include "COMMON.GEO" + include "COMMON.FFIELD" + include "COMMON.ENEPS" + include "COMMON.LOCAL" + include "COMMON.WEIGHTS" + include "COMMON.INTERACT" + include "COMMON.FREE" + include "COMMON.ENERGIES" + include "COMMON.COMPAR" + include "COMMON.PROT" + character*64 nazwa + character*80 bxname,cxname + character*64 bprotfile_temp + character*3 liczba,licz + character*2 licz2 + integer i,itj,ii,iii,j,k,l + integer ixdrf,iret + integer iscor,islice + double precision rmsdev,efree,eini + real*4 csingle(3,maxres2) + double precision energ + integer ilen,iroof + external ilen,iroof + integer ir,ib,iparm + write (licz2,'(bz,i2.2)') islice + call opentmp(islice,ientout,bprotfile_temp) + write (iout,*) "bprotfile_temp ",bprotfile_temp + call flush(iout) + if (.not.bxfile .and. .not. cxfile .and. indpdb.eq.0 + & .and. ensembles.eq.0) then + close(ientout,status="delete") + return + endif +#ifdef MPI + write (liczba,'(bz,i3.3)') me + if (bxfile .or. cxfile .or. ensembles.gt.0) then + if (.not.separate_parset) then + bxname = prefix(:ilen(prefix))//liczba//".bx" + else + write (licz,'(bz,i3.3)') myparm + bxname = prefix(:ilen(prefix))//liczba//"_par"//licz//".bx" + endif + open (ientin,file=bxname,status="unknown", + & form="unformatted",access="direct",recl=lenrec1) + endif +#else + if (bxfile .or. cxfile .or. ensembles.gt.0) then + if (nslice.eq.1) then + bxname = prefix(:ilen(prefix))//".bx" + else + bxname = prefix(:ilen(prefix))// + & "_slice_"//licz2//".bx" + endif + open (ientin,file=bxname,status="unknown", + & form="unformatted",access="direct",recl=lenrec1) + write (iout,*) "Calculating energies; writing geometry", + & " and energy components to ",bxname(:ilen(bxname)) + endif +#if (defined(AIX) && !defined(JUBL)) + call xdrfopen_(ixdrf,cxname, "w", iret) +#else + call xdrfopen(ixdrf,cxname, "w", iret) +#endif + if (iret.eq.0) then + write (iout,*) "Error opening cxfile ",cxname(:ilen(cxname)) + cxfile=.fale. + endif + endif +#endif + if (indpdb.gt.0) then + if (nslice.eq.1) then +#ifdef MPI + if (.not.separate_parset) then + statname=prefix(:ilen(prefix))//'_'//pot(:ilen(pot)) + & //liczba//'.stat' + else + write (licz,'(bz,i3.3)') myparm + statname=prefix(:ilen(prefix))//'_par'//licz//'_'// + & pot(:ilen(pot))//liczba//'.stat' + endif + +#else + statname=prefix(:ilen(prefix))//'_'//pot(:ilen(pot))//'.stat' +#endif + else +#ifdef MPI + if (.not.separate_parset) then + statname=prefix(:ilen(prefix))//'_'//pot(:ilen(pot))// + & "_slice_"//licz2//liczba//'.stat' + else + write (licz,'(bz,i3.3)') myparm + statname=prefix(:ilen(prefix))//'_'//pot(:ilen(pot))// + & '_par'//licz//"_slice_"//licz2//liczba//'.stat' + endif +#else + statname=prefix(:ilen(prefix))//'_'//pot(:ilen(pot)) + & //"_slice_"//licz2//'.stat' +#endif + endif + open(istat,file=statname,status="unknown") + endif + +#ifdef MPI + do i=1,scount(me) +#else + do i=1,ntot(islice) +#endif + read(ientout,rec=i,err=101) + & ((csingle(l,k),l=1,3),k=1,nres), + & ((csingle(l,k+nres),l=1,3),k=nnt,nct), + & nss,(ihpb(k),jhpb(k),k=1,nss), + & eini,efree,rmsdev,(q(k,i),k=1,nQ),iR,ib,iparm +c write (iout,*) iR,ib,iparm,eini,efree + do j=1,2*nres + do k=1,3 + c(k,j)=csingle(k,j) + enddo + enddo + call int_from_cart1(.false.) + iscore=0 + if (indpdb.gt.0) then + call conf_compar(i,.false.,.true.) + endif + if (bxfile .or.cxfile .or. ensembles.gt.0) write (ientin,rec=i) + & ((csingle(l,k),l=1,3),k=1,nres), + & ((csingle(l,k+nres),l=1,3),k=nnt,nct), + & nss,(ihpb(k),jhpb(k),k=1,nss), +c & potE(i,iparm),-entfac(i),rms_nat,iscore + & potE(i,nparmset),-entfac(i),rms_nat,iscore +c write (iout,'(2i5,3e15.5)') i,me,potE(i,iparm),-entfac(i) +#ifndef MPI + if (cxfile) call cxwrite(ixdrf,csingle,potE(i,nparmset), + & -entfac(i),rms_nat,iscore) +#endif + enddo + close(ientout,status="delete") + close(istat) + if (bxfile .or. cxfile .or. ensembles.gt.0) close(ientin) +#ifdef MPI + call MPI_Barrier(WHAM_COMM,IERROR) + if (me.ne.Master .or. .not.bxfile .and. .not. cxfile + & .and. ensembles.eq.0) return + write (iout,*) + if (bxfile .or. ensembles.gt.0) then + if (nslice.eq.1) then + if (.not.separate_parset) then + bxname = prefix(:ilen(prefix))//".bx" + else + write (licz,'(bz,i3.3)') myparm + bxname = prefix(:ilen(prefix))//"_par"//licz//".bx" + endif + else + if (.not.separate_parset) then + bxname = prefix(:ilen(prefix))//"_slice_"//licz2//".bx" + else + write (licz,'(bz,i3.3)') myparm + bxname = prefix(:ilen(prefix))//"par_"//licz// + & "_slice_"//licz2//".bx" + endif + endif + open (ientout,file=bxname,status="unknown", + & form="unformatted",access="direct",recl=lenrec1) + write (iout,*) "Master is creating binary database ", + & bxname(:ilen(bxname)) + endif + if (cxfile) then + if (nslice.eq.1) then + if (.not.separate_parset) then + cxname = prefix(:ilen(prefix))//".cx" + else + cxname = prefix(:ilen(prefix))//"_par"//licz//".cx" + endif + else + if (.not.separate_parset) then + cxname = prefix(:ilen(prefix))// + & "_slice_"//licz2//".cx" + else + cxname = prefix(:ilen(prefix))//"_par"//licz// + & "_slice_"//licz2//".cx" + endif + endif +#if (defined(AIX) && !defined(JUBL)) + call xdrfopen_(ixdrf,cxname, "w", iret) +#else + call xdrfopen(ixdrf,cxname, "w", iret) +#endif + if (iret.eq.0) then + write (iout,*) "Error opening cxfile ",cxname(:ilen(cxname)) + cxfile=.false. + endif + endif + do j=0,nprocs-1 + write (liczba,'(bz,i3.3)') j + if (separate_parset) then + write (licz,'(bz,i3.3)') myparm + bxname = prefix(:ilen(prefix))//liczba//"_par"//licz//".bx" + else + bxname = prefix(:ilen(prefix))//liczba//".bx" + endif + open (ientin,file=bxname,status="unknown", + & form="unformatted",access="direct",recl=lenrec1) + write (iout,*) "Master is reading conformations from ", + & bxname(:ilen(bxname)) + iii = 0 +c write (iout,*) "j",j," indstart",indstart(j)," indend",indend(j) +c call flush(iout) + do i=indstart(j),indend(j) + iii = iii+1 + read(ientin,rec=iii,err=101) + & ((csingle(l,k),l=1,3),k=1,nres), + & ((csingle(l,k+nres),l=1,3),k=nnt,nct), + & nss,(ihpb(k),jhpb(k),k=1,nss), + & eini,efree,rmsdev,iscor + if (bxfile .or. ensembles.gt.0) then + write (ientout,rec=i) + & ((csingle(l,k),l=1,3),k=1,nres), + & ((csingle(l,k+nres),l=1,3),k=nnt,nct), + & nss,(ihpb(k),jhpb(k),k=1,nss), + & eini,efree,rmsdev,iscor + endif + if(cxfile)call cxwrite(ixdrf,csingle,eini,efree,rmsdev,iscor) +#ifdef DEBUG + do k=1,2*nres + do l=1,3 + c(l,k)=csingle(l,k) + enddo + enddo + call int_from_cart1(.false.) + write (iout,'(2i5,3e15.5)') i,iii,eini,efree + write (iout,*) "The Cartesian geometry is:" + write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) + write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) + write (iout,*) "The internal geometry is:" + write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) + write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) + write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) + write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) + write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) + write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) + write (iout,'(16i5)') nss,(ihpb(k),jhpb(k),k=1,nss) + write (iout,'(f10.5,i5)') rmsdev,iscor +#endif + enddo ! i + write (iout,*) iii," conformations (from",indstart(j)," to", + & indend(j),") read from ", + & bxname(:ilen(bxname)) + close (ientin,status="delete") + enddo ! j + if (bxfile .or. cxfile .or. ensembles.gt.0) close (ientout) +#if (defined(AIX) && !defined(JUBL)) + if (cxfile) call xdrfclose_(ixdrf,cxname,iret) +#else + if (cxfile) call xdrfclose(ixdrf,cxname,iret) +#endif +#endif + return + 101 write (iout,*) "Error in scratchfile." + call flush(iout) + return1 + end +c------------------------------------------------------------------------------- + subroutine cxwrite(ixdrf,csingle,eini,efree,rmsdev,iscor) + implicit none + include "DIMENSIONS" + include "DIMENSIONS.ZSCOPT" + include "DIMENSIONS.FREE" + include "DIMENSIONS.COMPAR" +#ifdef MPI + include "mpif.h" + integer IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE) + include "COMMON.MPI" +#endif + include "COMMON.CONTROL" + include "COMMON.CHAIN" + include "COMMON.IOUNITS" + include "COMMON.PROTFILES" + include "COMMON.NAMES" + include "COMMON.VAR" + include "COMMON.SBRIDGE" + include "COMMON.GEO" + include "COMMON.FFIELD" + include "COMMON.ENEPS" + include "COMMON.LOCAL" + include "COMMON.WEIGHTS" + include "COMMON.INTERACT" + include "COMMON.FREE" + include "COMMON.ENERGIES" + include "COMMON.COMPAR" + include "COMMON.PROT" + integer i,j,itmp,iscor,iret,ixdrf + double precision rmsdev,efree,eini + real*4 csingle(3,maxres2),xoord(3,maxres2+2) + real*4 prec + +c write (iout,*) "cxwrite" +c call flush(iout) + prec=10000.0 + do i=1,nres + do j=1,3 + xoord(j,i)=csingle(j,i) + enddo + enddo + do i=nnt,nct + do j=1,3 + xoord(j,nres+i-nnt+1)=csingle(j,i+nres) + enddo + enddo + + itmp=nres+nct-nnt+1 + +c write (iout,*) "itmp",itmp +c call flush(iout) +#if (defined(AIX) && !defined(JUBL)) + call xdrf3dfcoord_(ixdrf, xoord, itmp, prec, iret) + +c write (iout,*) "xdrf3dfcoord" +c call flush(iout) + call xdrfint_(ixdrf, nss, iret) + do j=1,nss + call xdrfint_(ixdrf, ihpb(j), iret) + call xdrfint_(ixdrf, jhpb(j), iret) + enddo + call xdrffloat_(ixdrf,real(eini),iret) + call xdrffloat_(ixdrf,real(efree),iret) + call xdrffloat_(ixdrf,real(rmsdev),iret) + call xdrfint_(ixdrf,iscor,iret) +#else + call xdrf3dfcoord(ixdrf, xoord, itmp, prec, iret) + + call xdrfint(ixdrf, nss, iret) + do j=1,nss + call xdrfint(ixdrf, ihpb(j), iret) + call xdrfint(ixdrf, jhpb(j), iret) + enddo + call xdrffloat(ixdrf,real(eini),iret) + call xdrffloat(ixdrf,real(efree),iret) + call xdrffloat(ixdrf,real(rmsdev),iret) + call xdrfint(ixdrf,iscor,iret) +#endif + + return + end +c------------------------------------------------------------------------------ + logical function conf_check(ii,iprint) + implicit none + include "DIMENSIONS" + include "DIMENSIONS.ZSCOPT" + include "DIMENSIONS.FREE" +#ifdef MPI + include "mpif.h" + integer IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE) + include "COMMON.MPI" +#endif + include "COMMON.CHAIN" + include "COMMON.IOUNITS" + include "COMMON.PROTFILES" + include "COMMON.NAMES" + include "COMMON.VAR" + include "COMMON.SBRIDGE" + include "COMMON.GEO" + include "COMMON.FFIELD" + include "COMMON.ENEPS" + include "COMMON.LOCAL" + include "COMMON.WEIGHTS" + include "COMMON.INTERACT" + include "COMMON.FREE" + include "COMMON.ENERGIES" + include "COMMON.CONTROL" + include "COMMON.TORCNSTR" + integer j,k,l,ii,itj,iprint + if (.not.check_conf) then + conf_check=.true. + return + endif + call int_from_cart1(.false.) + do j=nnt+1,nct + if (vbld(j).lt.2.0d0 .or. vbld(j).gt.5.0d0) then + if (iprint.gt.0) + & write (iout,*) "Bad CA-CA bond length",j," ",vbld(j), + & " for conformation",ii + if (iprint.gt.1) then + write (iout,*) "The Cartesian geometry is:" + write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) + write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) + write (iout,*) "The internal geometry is:" + write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) + write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) + write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) + write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) + write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) + write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) + endif + if (iprint.gt.0) write (iout,*) + & "This conformation WILL NOT be added to the database." + conf_check=.false. + return + endif + enddo + do j=nnt,nct + itj=itype(j) + if (itype(j).ne.10 .and. (vbld(nres+j)-dsc(itj)).gt.2.0d0) then + if (iprint.gt.0) + & write (iout,*) "Bad CA-SC bond length",j," ",vbld(nres+j), + & " for conformation",ii + if (iprint.gt.1) then + write (iout,*) "The Cartesian geometry is:" + write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) + write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) + write (iout,*) "The internal geometry is:" + write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) + write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) + write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) + write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) + write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) + write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) + endif + if (iprint.gt.0) write (iout,*) + & "This conformation WILL NOT be added to the database." + conf_check=.false. + return + endif + enddo + do j=3,nres + if (theta(j).le.0.0d0) then + if (iprint.gt.0) + & write (iout,*) "Zero theta angle(s) in conformation",ii + if (iprint.gt.1) then + write (iout,*) "The Cartesian geometry is:" + write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) + write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) + write (iout,*) "The internal geometry is:" + write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) + write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) + write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) + write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) + write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) + write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) + endif + if (iprint.gt.0) write (iout,*) + & "This conformation WILL NOT be added to the database." + conf_check=.false. + return + endif + if (theta(j).gt.179.97*deg2rad) theta(j)=179.97*deg2rad + enddo + conf_check=.true. +c write (iout,*) "conf_check passed",ii + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/energy_p_new.F b/source/wham/src-NEWSC-NEWCORR/energy_p_new.F new file mode 100644 index 0000000..0ee066f --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/energy_p_new.F @@ -0,0 +1,9221 @@ + subroutine etotal(energia,fact) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + +#ifndef ISNAN + external proc_proc +#endif +#ifdef WINPGI +cMS$ATTRIBUTES C :: proc_proc +#endif + + include 'COMMON.IOUNITS' + double precision energia(0:max_ene),energia1(0:max_ene+1) +#ifdef MPL + include 'COMMON.INFO' + external d_vadd + integer ready +#endif + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + double precision fact(6) +cd write(iout, '(a,i2)')'Calling etotal ipot=',ipot +cd print *,'nnt=',nnt,' nct=',nct +C +C Compute the side-chain and electrostatic interaction energy +C + goto (101,102,103,104,105,106) ipot +C Lennard-Jones potential. + 101 call elj(evdw,evdw_t) +cd print '(a)','Exit ELJ' + goto 107 +C Lennard-Jones-Kihara potential (shifted). + 102 call eljk(evdw,evdw_t) + goto 107 +C Berne-Pechukas potential (dilated LJ, angular dependence). + 103 call ebp(evdw,evdw_t) + goto 107 +C Gay-Berne potential (shifted LJ, angular dependence). + 104 call egb(evdw,evdw_t) + goto 107 +C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). + 105 call egbv(evdw,evdw_t) + goto 107 +C New SC-SC potential + 106 call emomo(evdw,evdw_p,evdw_m) +C +C Calculate electrostatic (H-bonding) energy of the main chain. +C + 107 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4) +C +C Calculate excluded-volume interaction energy between peptide groups +C and side chains. +C + call escp(evdw2,evdw2_14) +c +c Calculate the bond-stretching energy +c + call ebond(estr) +c write (iout,*) "estr",estr +C +C Calculate the disulfide-bridge and other energy and the contributions +C from other distance constraints. +cd print *,'Calling EHPB' + call edis(ehpb) +cd print *,'EHPB exitted succesfully.' +C +C Calculate the virtual-bond-angle energy. +C + call ebend(ebe) +cd print *,'Bend energy finished.' +C +C Calculate the SC local energy. +C + call esc(escloc) +cd print *,'SCLOC energy finished.' +C +C Calculate the virtual-bond torsional energy. +C +cd print *,'nterm=',nterm + call etor(etors,edihcnstr,fact(1)) +C +C 6/23/01 Calculate double-torsional energy +C + call etor_d(etors_d,fact(2)) +C +C 21/5/07 Calculate local sicdechain correlation energy +C + call eback_sc_corr(esccor) +C +C 12/1/95 Multi-body terms +C + n_corr=0 + n_corr1=0 + if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 + & .or. wturn6.gt.0.0d0) then +c print *,"calling multibody_eello" + call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1) +c write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1 +c print *,ecorr,ecorr5,ecorr6,eturn6 + endif + if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then + call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) + endif +c write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t +#ifdef SPLITELE + etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees + & +wvdwpp*evdw1 + & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc + & +wstrain*ehpb+nss*ebr+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5 + & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4 + & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6 + & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d + & +wbond*estr+wsccor*fact(1)*esccor +#else + etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2 + & +welec*fact(1)*(ees+evdw1) + & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc + & +wstrain*ehpb+nss*ebr+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5 + & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4 + & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6 + & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d + & +wbond*estr+wsccor*fact(1)*esccor +#endif + energia(0)=etot + energia(1)=evdw +#ifdef SCP14 + energia(2)=evdw2-evdw2_14 + energia(17)=evdw2_14 +#else + energia(2)=evdw2 + energia(17)=0.0d0 +#endif +#ifdef SPLITELE + energia(3)=ees + energia(16)=evdw1 +#else + energia(3)=ees+evdw1 + energia(16)=0.0d0 +#endif + energia(4)=ecorr + energia(5)=ecorr5 + energia(6)=ecorr6 + energia(7)=eel_loc + energia(8)=eello_turn3 + energia(9)=eello_turn4 + energia(10)=eturn6 + energia(11)=ebe + energia(12)=escloc + energia(13)=etors + energia(14)=etors_d + energia(15)=ehpb + energia(18)=estr + energia(19)=esccor + energia(20)=edihcnstr + energia(21)=evdw_t +c detecting NaNQ +#ifdef ISNAN +#ifdef AIX + if (isnan(etot).ne.0) energia(0)=1.0d+99 +#else + if (isnan(etot)) energia(0)=1.0d+99 +#endif +#else + i=0 +#ifdef WINPGI + idumm=proc_proc(etot,i) +#else + call proc_proc(etot,i) +#endif + if(i.eq.1)energia(0)=1.0d+99 +#endif +#ifdef MPL +c endif +#endif + if (calc_grad) then +C +C Sum up the components of the Cartesian gradient. +C +#ifdef SPLITELE + do i=1,nct + do j=1,3 + gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+ + & welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+ + & wbond*gradb(j,i)+ + & wstrain*ghpbc(j,i)+ + & wcorr*fact(3)*gradcorr(j,i)+ + & wel_loc*fact(2)*gel_loc(j,i)+ + & wturn3*fact(2)*gcorr3_turn(j,i)+ + & wturn4*fact(3)*gcorr4_turn(j,i)+ + & wcorr5*fact(4)*gradcorr5(j,i)+ + & wcorr6*fact(5)*gradcorr6(j,i)+ + & wturn6*fact(5)*gcorr6_turn(j,i)+ + & wsccor*fact(2)*gsccorc(j,i) + gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ + & wbond*gradbx(j,i)+ + & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ + & wsccor*fact(2)*gsccorx(j,i) + enddo +#else + do i=1,nct + do j=1,3 + gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+ + & welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+ + & wbond*gradb(j,i)+ + & wcorr*fact(3)*gradcorr(j,i)+ + & wel_loc*fact(2)*gel_loc(j,i)+ + & wturn3*fact(2)*gcorr3_turn(j,i)+ + & wturn4*fact(3)*gcorr4_turn(j,i)+ + & wcorr5*fact(4)*gradcorr5(j,i)+ + & wcorr6*fact(5)*gradcorr6(j,i)+ + & wturn6*fact(5)*gcorr6_turn(j,i)+ + & wsccor*fact(2)*gsccorc(j,i) + gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ + & wbond*gradbx(j,i)+ + & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ + & wsccor*fact(1)*gsccorx(j,i) + enddo +#endif + enddo + + + do i=1,nres-3 + gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i) + & +wcorr5*fact(4)*g_corr5_loc(i) + & +wcorr6*fact(5)*g_corr6_loc(i) + & +wturn4*fact(3)*gel_loc_turn4(i) + & +wturn3*fact(2)*gel_loc_turn3(i) + & +wturn6*fact(5)*gel_loc_turn6(i) + & +wel_loc*fact(2)*gel_loc_loc(i) + & +wsccor*fact(1)*gsccor_loc(i) + enddo + endif + return + end +C------------------------------------------------------------------------ + subroutine enerprint(energia,fact) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + double precision energia(0:max_ene),fact(6) + etot=energia(0) + evdw=energia(1)+fact(6)*energia(21) +#ifdef SCP14 + evdw2=energia(2)+energia(17) +#else + evdw2=energia(2) +#endif + ees=energia(3) +#ifdef SPLITELE + evdw1=energia(16) +#endif + ecorr=energia(4) + ecorr5=energia(5) + ecorr6=energia(6) + eel_loc=energia(7) + eello_turn3=energia(8) + eello_turn4=energia(9) + eello_turn6=energia(10) + ebe=energia(11) + escloc=energia(12) + etors=energia(13) + etors_d=energia(14) + ehpb=energia(15) + esccor=energia(19) + edihcnstr=energia(20) + estr=energia(18) +#ifdef SPLITELE + write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1, + & wvdwpp, + & estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1), + & etors_d,wtor_d*fact(2),ehpb,wstrain, + & ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5), + & eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2), + & eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5), + & esccor,wsccor*fact(1),edihcnstr,ebr*nss,etot + 10 format (/'Virtual-chain energies:'// + & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ + & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ + & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/ + & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ + & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ + & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ + & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ + & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ + & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ + & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6, + & ' (SS bridges & dist. cnstr.)'/ + & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ + & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ + & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ + & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ + & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ + & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ + & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ + & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ + & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ + & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ + & 'ETOT= ',1pE16.6,' (total)') +#else + write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond, + & ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2, + & ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4), + & ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2), + & eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3), + & eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor, + & edihcnstr,ebr*nss,etot + 10 format (/'Virtual-chain energies:'// + & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ + & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ + & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ + & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ + & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ + & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ + & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ + & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ + & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6, + & ' (SS bridges & dist. cnstr.)'/ + & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ + & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ + & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ + & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ + & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ + & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ + & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ + & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ + & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ + & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ + & 'ETOT= ',1pE16.6,' (total)') +#endif + return + end +C----------------------------------------------------------------------- + subroutine elj(evdw,evdw_t) +C +C This subroutine calculates the interaction energy of nonbonded side chains +C assuming the LJ potential of interaction. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include "DIMENSIONS.COMPAR" + parameter (accur=1.0d-10) + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.TORSION' + include 'COMMON.ENEPS' + include 'COMMON.SBRIDGE' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.CONTACTS' + dimension gg(3) + integer icant + external icant +cd print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon + do i=1,210 + do j=1,2 + eneps_temp(j,i)=0.0d0 + enddo + enddo + evdw=0.0D0 + evdw_t=0.0d0 + do i=iatsc_s,iatsc_e + itypi=itype(i) + itypi1=itype(i+1) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) +C Change 12/1/95 + num_conti=0 +C +C Calculate SC interaction energy. +C + do iint=1,nint_gr(i) +cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), +cd & 'iend=',iend(i,iint) + do j=istart(i,iint),iend(i,iint) + itypj=itype(j) + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi +C Change 12/1/95 to calculate four-body interactions + rij=xj*xj+yj*yj+zj*zj + rrij=1.0D0/rij +c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj + eps0ij=eps(itypi,itypj) + fac=rrij**expon2 + e1=fac*fac*aa(itypi,itypj) + e2=fac*bb(itypi,itypj) + evdwij=e1+e2 + ij=icant(itypi,itypj) + eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij) + eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij +cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) +cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj) +cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)') +cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), +cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm, +cd & (c(k,i),k=1,3),(c(k,j),k=1,3) + if (bb(itypi,itypj).gt.0.0d0) then + evdw=evdw+evdwij + else + evdw_t=evdw_t+evdwij + endif + if (calc_grad) then +C +C Calculate the components of the gradient in DC and X +C + fac=-rrij*(e1+evdwij) + gg(1)=xj*fac + gg(2)=yj*fac + gg(3)=zj*fac + do k=1,3 + gvdwx(k,i)=gvdwx(k,i)-gg(k) + gvdwx(k,j)=gvdwx(k,j)+gg(k) + enddo + do k=i,j-1 + do l=1,3 + gvdwc(l,k)=gvdwc(l,k)+gg(l) + enddo + enddo + endif +C +C 12/1/95, revised on 5/20/97 +C +C Calculate the contact function. The ith column of the array JCONT will +C contain the numbers of atoms that make contacts with the atom I (of numbers +C greater than I). The arrays FACONT and GACONT will contain the values of +C the contact function and its derivative. +C +C Uncomment next line, if the correlation interactions include EVDW explicitly. +c if (j.gt.i+1 .and. evdwij.le.0.0D0) then +C Uncomment next line, if the correlation interactions are contact function only + if (j.gt.i+1.and. eps0ij.gt.0.0D0) then + rij=dsqrt(rij) + sigij=sigma(itypi,itypj) + r0ij=rs0(itypi,itypj) +C +C Check whether the SC's are not too far to make a contact. +C + rcut=1.5d0*r0ij + call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont) +C Add a new contact, if the SC's are close enough, but not too close (r.< +c! om = omega, sqom = om^2 + sqom1 = om1 * om1 + sqom2 = om2 * om2 + sqom12 = om12 * om12 + +c! now we calculate EGB - Gey-Berne +c! It will be summed up in evdwij and saved in evdw + sigsq = 1.0D0 / sigsq + sig = sig0ij * dsqrt(sigsq) +c! rij_shift = 1.0D0 / rij - sig + sig0ij + rij_shift = Rtail - sig + sig0ij +c write (2,*) "Rtal",Rtail," sig",sig," sigsq",sigsq, +c & " sig0ij",sig0ij +c write (2,*) "rij_shift",rij_shift + IF (rij_shift.le.0.0D0) THEN + evdw = 1.0D20 + RETURN + END IF + sigder = -sig * sigsq + rij_shift = 1.0D0 / rij_shift + fac = rij_shift**expon + c1 = fac * fac * aa(itypi,itypj) +#ifdef SCALREP +! Scale down the repulsive term for 1,4 interactions. + if (iabs(j-i).le.4) c1 = 0.01d0 * c1 +#endif +c! c1 = 0.0d0 + c2 = fac * bb(itypi,itypj) +c! c2 = 0.0d0 +c write (2,*) "eps1",eps1," eps2rt",eps2rt," eps3rt",eps3rt, +c & " c1",c1," c2",c2 + evdwij = eps1 * eps2rt * eps3rt * ( c1 + c2 ) + eps2der = eps3rt * evdwij + eps3der = eps2rt * evdwij +c! evdwij = 4.0d0 * eps2rt * eps3rt * evdwij + evdwij = eps2rt * eps3rt * evdwij +c! evdwij = 0.0d0 +c! write (*,*) "Gey Berne = ", evdwij +#ifdef TSCSC + IF (bb(itypi,itypj).gt.0) THEN + evdw_p = evdw_p + evdwij + ELSE + evdw_m = evdw_m + evdwij + END IF +#else + evdw = evdw + & + evdwij +#endif +c!------------------------------------------------------------------- +c! Calculate some components of GGB + c1 = c1 * eps1 * eps2rt**2 * eps3rt**2 + fac = -expon * (c1 + evdwij) * rij_shift + sigder = fac * sigder +c! fac = rij * fac +c! Calculate distance derivative +c! gg(1) = xj * fac +c! gg(2) = yj * fac +c! gg(3) = zj * fac + gg(1) = fac + gg(2) = fac + gg(3) = fac +c! write (*,*) "gg(1) = ", gg(1) +c! write (*,*) "gg(2) = ", gg(2) +c! write (*,*) "gg(3) = ", gg(3) +c! The angular derivatives of GGB are brought together in sc_grad +c!------------------------------------------------------------------- +c! Fcav +c! +c! Catch gly-gly interactions to skip calculation of something that +c! does not exist + + IF (itypi.eq.10.and.itypj.eq.10) THEN + Fcav = 0.0d0 + dFdR = 0.0d0 + dCAVdOM1 = 0.0d0 + dCAVdOM2 = 0.0d0 + dCAVdOM12 = 0.0d0 + ELSE + +c! we are not 2 glycines, so we calculate Fcav (and maybe more) + fac = chis1 * sqom1 + chis2 * sqom2 + & - 2.0d0 * chis12 * om1 * om2 * om12 +c! we will use pom later in Gcav, so dont mess with it! + pom = 1.0d0 - chis1 * chis2 * sqom12 + + Lambf = (1.0d0 - (fac / pom)) + Lambf = dsqrt(Lambf) + + + sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0) +c! write (*,*) "sparrow = ", sparrow + Chif = Rtail * sparrow + ChiLambf = Chif * Lambf + eagle = dsqrt(ChiLambf) + bat = ChiLambf ** 11.0d0 + + top = b1 * ( eagle + b2 * ChiLambf - b3 ) + bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0) + botsq = bot * bot + +c! write (*,*) "sig1 = ",sig1 +c! write (*,*) "sig2 = ",sig2 +c! write (*,*) "Rtail = ",Rtail +c! write (*,*) "sparrow = ",sparrow +c! write (*,*) "Chis1 = ", chis1 +c! write (*,*) "Chis2 = ", chis2 +c! write (*,*) "Chis12 = ", chis12 +c! write (*,*) "om1 = ", om1 +c! write (*,*) "om2 = ", om2 +c! write (*,*) "om12 = ", om12 +c! write (*,*) "sqom1 = ", sqom1 +c! write (*,*) "sqom2 = ", sqom2 +c! write (*,*) "sqom12 = ", sqom12 +c! write (*,*) "Lambf = ",Lambf +c! write (*,*) "b1 = ",b1 +c! write (*,*) "b2 = ",b2 +c! write (*,*) "b3 = ",b3 +c! write (*,*) "b4 = ",b4 +c! write (*,*) "top = ",top +c! write (*,*) "bot = ",bot + Fcav = top / bot +c! Fcav = 0.0d0 +c! write (*,*) "Fcav = ", Fcav +c!------------------------------------------------------------------- +c! derivative of Fcav is Gcav... +c!--------------------------------------------------- + + dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf)) + dbot = 12.0d0 * b4 * bat * Lambf + dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow +c! dFdR = 0.0d0 +c! write (*,*) "dFcav/dR = ", dFdR + + dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif)) + dbot = 12.0d0 * b4 * bat * Chif + eagle = Lambf * pom + dFdOM1 = -(chis1 * om1 - chis12 * om2 * om12) / (eagle) + dFdOM2 = -(chis2 * om2 - chis12 * om1 * om12) / (eagle) + dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) + & * (chis2 * om2 * om12 - om1) / (eagle * pom) + + dFdL = ((dtop * bot - top * dbot) / botsq) +c! dFdL = 0.0d0 + dCAVdOM1 = dFdL * ( dFdOM1 ) + dCAVdOM2 = dFdL * ( dFdOM2 ) + dCAVdOM12 = dFdL * ( dFdOM12 ) +c! write (*,*) "dFcav/dOM1 = ", dCAVdOM1 +c! write (*,*) "dFcav/dOM2 = ", dCAVdOM2 +c! write (*,*) "dFcav/dOM12 = ", dCAVdOM12 +c! write (*,*) "" +c!------------------------------------------------------------------- +c! Finally, add the distance derivatives of GB and Fcav to gvdwc +c! Pom is used here to project the gradient vector into +c! cartesian coordinates and at the same time contains +c! dXhb/dXsc derivative (for charged amino acids +c! location of hydrophobic centre of interaction is not +c! the same as geometric centre of side chain, this +c! derivative takes that into account) +c! derivatives of omega angles will be added in sc_grad + + DO k= 1, 3 + ertail(k) = Rtail_distance(k)/Rtail + END DO + erdxi = scalar( ertail(1), dC_norm(1,i+nres) ) + erdxj = scalar( ertail(1), dC_norm(1,j+nres) ) + facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres) + facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres) + DO k = 1, 3 +c! write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i) +c! write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j) + pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres)) + gvdwx(k,i) = gvdwx(k,i) + & - (( dFdR + gg(k) ) * pom) +c! & - ( dFdR * pom ) + pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres)) + gvdwx(k,j) = gvdwx(k,j) + & + (( dFdR + gg(k) ) * pom) +c! & + ( dFdR * pom ) + + gvdwc(k,i) = gvdwc(k,i) + & - (( dFdR + gg(k) ) * ertail(k)) +c! & - ( dFdR * ertail(k)) + + gvdwc(k,j) = gvdwc(k,j) + & + (( dFdR + gg(k) ) * ertail(k)) +c! & + ( dFdR * ertail(k)) + + gg(k) = 0.0d0 +c! write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i) +c! write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j) + END DO + +c!------------------------------------------------------------------- +c! Compute head-head and head-tail energies for each state + + isel = iabs(Qi) + iabs(Qj) + IF (isel.eq.0) THEN +c! No charges - do nothing + eheadtail = 0.0d0 + + ELSE IF (isel.eq.4) THEN +c! Calculate dipole-dipole interactions + CALL edd(ecl) + eheadtail = ECL + + ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN +c! Charge-nonpolar interactions + CALL eqn(epol) + eheadtail = epol + + ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN +c! Nonpolar-charge interactions + CALL enq(epol) + eheadtail = epol + + ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN +c! Charge-dipole interactions + CALL eqd(ecl, elj, epol) + eheadtail = ECL + elj + epol + + ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN +c! Dipole-charge interactions + CALL edq(ecl, elj, epol) + eheadtail = ECL + elj + epol + + ELSE IF ((isel.eq.2.and. + & iabs(Qi).eq.1).and. + & nstate(itypi,itypj).eq.1) THEN +c! Same charge-charge interaction ( +/+ or -/- ) + CALL eqq(Ecl,Egb,Epol,Fisocav,Elj) + eheadtail = ECL + Egb + Epol + Fisocav + Elj + + ELSE IF ((isel.eq.2.and. + & iabs(Qi).eq.1).and. + & nstate(itypi,itypj).ne.1) THEN +c! Different charge-charge interaction ( +/- or -/+ ) + CALL energy_quad + & (istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad) + END IF + END IF ! this endif ends the "catch the gly-gly" at the beggining of Fcav +c! write (*,*) "evdw = ", evdw +c! write (*,*) "Fcav = ", Fcav +c! write (*,*) "eheadtail = ", eheadtail + evdw = evdw + & + Fcav + & + eheadtail + + IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') + & restyp(itype(i)),i,restyp(itype(j)),j, + & 1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj, + & Equad,evdwij+Fcav+eheadtail,evdw +c IF (energy_dec) write (*,'(2(1x,a3,i3),3f6.2,9f16.7)') +c & restyp(itype(i)),i,restyp(itype(j)),j, +c & 1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj, +c & Equad,evdwij+Fcav+eheadtail,evdw +#IFDEF CHECK_MOMO + evdw = 0.0d0 + END DO ! troll +#ENDIF + +c!------------------------------------------------------------------- +c! As all angular derivatives are done, now we sum them up, +c! then transform and project into cartesian vectors and add to gvdwc +c! We call sc_grad always, with the exception of +/- interaction. +c! This is because energy_quad subroutine needs to handle +c! this job in his own way. +c! This IS probably not very efficient and SHOULD be optimised +c! but it will require major restructurization of emomo +c! so it will be left as it is for now +c! write (*,*) 'troll1, nstate =', nstate (itypi,itypj) + IF (nstate(itypi,itypj).eq.1) THEN +#ifdef TSCSC + IF (bb(itypi,itypj).gt.0) THEN + CALL sc_grad + ELSE + CALL sc_grad_T + END IF +#else + CALL sc_grad +#endif + END IF +c!------------------------------------------------------------------- +c! NAPISY KONCOWE + END DO ! j + END DO ! iint + END DO ! i + if (energy_dec) write (iout,*) "evdw before exiting emomo:",evdw +c write (iout,*) "Number of loop steps in EGB:",ind +c energy_dec=.false. + RETURN + END SUBROUTINE emomo +c! END OF MOMO + + +C----------------------------------------------------------------------------- + + + SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj) + IMPLICIT NONE + INCLUDE 'DIMENSIONS' + INCLUDE 'DIMENSIONS.ZSCOPT' + INCLUDE 'COMMON.CALC' + INCLUDE 'COMMON.CHAIN' + INCLUDE 'COMMON.CONTROL' + INCLUDE 'COMMON.DERIV' + INCLUDE 'COMMON.EMP' + INCLUDE 'COMMON.GEO' + INCLUDE 'COMMON.INTERACT' + INCLUDE 'COMMON.IOUNITS' + INCLUDE 'COMMON.LOCAL' + INCLUDE 'COMMON.NAMES' + INCLUDE 'COMMON.VAR' + double precision scalar, facd3, facd4, federmaus, adler +c! Epol and Gpol analytical parameters + alphapol1 = alphapol(itypi,itypj) + alphapol2 = alphapol(itypj,itypi) +c! Fisocav and Gisocav analytical parameters + al1 = alphiso(1,itypi,itypj) + al2 = alphiso(2,itypi,itypj) + al3 = alphiso(3,itypi,itypj) + al4 = alphiso(4,itypi,itypj) + csig = (1.0d0 + & / dsqrt(sigiso1(itypi, itypj)**2.0d0 + & + sigiso2(itypi,itypj)**2.0d0)) +c! + pis = sig0head(itypi,itypj) + eps_head = epshead(itypi,itypj) + Rhead_sq = Rhead * Rhead +c! R1 - distance between head of ith side chain and tail of jth sidechain +c! R2 - distance between head of jth side chain and tail of ith sidechain + R1 = 0.0d0 + R2 = 0.0d0 + DO k = 1, 3 +c! Calculate head-to-tail distances needed by Epol + R1=R1+(ctail(k,2)-chead(k,1))**2 + R2=R2+(chead(k,2)-ctail(k,1))**2 + END DO +c! Pitagoras + R1 = dsqrt(R1) + R2 = dsqrt(R2) + +c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) +c! & +dhead(1,1,itypi,itypj))**2)) +c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) +c! & +dhead(2,1,itypi,itypj))**2)) + +c!------------------------------------------------------------------- +c! Coulomb electrostatic interaction + Ecl = (332.0d0 * Qij) / Rhead +c! derivative of Ecl is Gcl... + dGCLdR = (-332.0d0 * Qij ) / Rhead_sq + dGCLdOM1 = 0.0d0 + dGCLdOM2 = 0.0d0 + dGCLdOM12 = 0.0d0 +c!------------------------------------------------------------------- +c! Generalised Born Solvent Polarization +c! Charged head polarizes the solvent + ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq)) + Fgb = sqrt( ( Rhead_sq ) + a12sq * ee) + Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb +c! Derivative of Egb is Ggb... + dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb) + dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) ) + & / ( 2.0d0 * Fgb ) + dGGBdR = dGGBdFGB * dFGBdR +c!------------------------------------------------------------------- +c! Fisocav - isotropic cavity creation term +c! or "how much energy it costs to put charged head in water" + pom = Rhead * csig + top = al1 * (dsqrt(pom) + al2 * pom - al3) + bot = (1.0d0 + al4 * pom**12.0d0) + botsq = bot * bot + FisoCav = top / bot +c! write (*,*) "Rhead = ",Rhead +c! write (*,*) "csig = ",csig +c! write (*,*) "pom = ",pom +c! write (*,*) "al1 = ",al1 +c! write (*,*) "al2 = ",al2 +c! write (*,*) "al3 = ",al3 +c! write (*,*) "al4 = ",al4 +c! write (*,*) "top = ",top +c! write (*,*) "bot = ",bot +c! Derivative of Fisocav is GCV... + dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2) + dbot = 12.0d0 * al4 * pom ** 11.0d0 + dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig +c!------------------------------------------------------------------- +c! Epol +c! Polarization energy - charged heads polarize hydrophobic "neck" + MomoFac1 = (1.0d0 - chi1 * sqom2) + MomoFac2 = (1.0d0 - chi2 * sqom1) + RR1 = ( R1 * R1 ) / MomoFac1 + RR2 = ( R2 * R2 ) / MomoFac2 + ee1 = exp(-( RR1 / (4.0d0 * a12sq) )) + ee2 = exp(-( RR2 / (4.0d0 * a12sq) )) + fgb1 = sqrt( RR1 + a12sq * ee1 ) + fgb2 = sqrt( RR2 + a12sq * ee2 ) + epol = 332.0d0 * eps_inout_fac * ( + & (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 )) +c! epol = 0.0d0 +c write (*,*) "eps_inout_fac = ",eps_inout_fac +c write (*,*) "alphapol1 = ", alphapol1 +c write (*,*) "alphapol2 = ", alphapol2 +c write (*,*) "fgb1 = ", fgb1 +c write (*,*) "fgb2 = ", fgb2 +c write (*,*) "epol = ", epol +c! derivative of Epol is Gpol... + dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) + & / (fgb1 ** 5.0d0) + dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) + & / (fgb2 ** 5.0d0) + dFGBdR1 = ( (R1 / MomoFac1) + & * ( 2.0d0 - (0.5d0 * ee1) ) ) + & / ( 2.0d0 * fgb1 ) + dFGBdR2 = ( (R2 / MomoFac2) + & * ( 2.0d0 - (0.5d0 * ee2) ) ) + & / ( 2.0d0 * fgb2 ) + dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) + & * ( 2.0d0 - 0.5d0 * ee1) ) + & / ( 2.0d0 * fgb1 ) + dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) + & * ( 2.0d0 - 0.5d0 * ee2) ) + & / ( 2.0d0 * fgb2 ) + dPOLdR1 = dPOLdFGB1 * dFGBdR1 +c! dPOLdR1 = 0.0d0 + dPOLdR2 = dPOLdFGB2 * dFGBdR2 +c! dPOLdR2 = 0.0d0 + dPOLdOM1 = dPOLdFGB2 * dFGBdOM1 +c! dPOLdOM1 = 0.0d0 + dPOLdOM2 = dPOLdFGB1 * dFGBdOM2 +c! dPOLdOM2 = 0.0d0 +c!------------------------------------------------------------------- +c! Elj +c! Lennard-Jones 6-12 interaction between heads + pom = (pis / Rhead)**6.0d0 + Elj = 4.0d0 * eps_head * pom * (pom-1.0d0) +c! derivative of Elj is Glj + dGLJdR = 4.0d0 * eps_head + & * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) + & + (( 6.0d0*pis**6.0d0) /(Rhead**7.0d0))) +c!------------------------------------------------------------------- +c! Return the results +c! These things do the dRdX derivatives, that is +c! allow us to change what we see from function that changes with +c! distance to function that changes with LOCATION (of the interaction +c! site) + DO k = 1, 3 + erhead(k) = Rhead_distance(k)/Rhead + erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1) + erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2) + END DO + + erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) + erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) + bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) ) + federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres)) + eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) ) + adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) ) + facd1 = d1 * vbld_inv(i+nres) + facd2 = d2 * vbld_inv(j+nres) + facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres) + facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres) + +c! Now we add appropriate partial derivatives (one in each dimension) + DO k = 1, 3 + hawk = (erhead_tail(k,1) + + & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres))) + condor = (erhead_tail(k,2) + + & facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))) + + pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) + gvdwx(k,i) = gvdwx(k,i) + & - dGCLdR * pom + & - dGGBdR * pom + & - dGCVdR * pom + & - dPOLdR1 * hawk + & - dPOLdR2 * (erhead_tail(k,2) + & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) + & - dGLJdR * pom + + pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) + gvdwx(k,j) = gvdwx(k,j) + & + dGCLdR * pom + & + dGGBdR * pom + & + dGCVdR * pom + & + dPOLdR1 * (erhead_tail(k,1) + & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) + & + dPOLdR2 * condor + & + dGLJdR * pom + + gvdwc(k,i) = gvdwc(k,i) + & - dGCLdR * erhead(k) + & - dGGBdR * erhead(k) + & - dGCVdR * erhead(k) + & - dPOLdR1 * erhead_tail(k,1) + & - dPOLdR2 * erhead_tail(k,2) + & - dGLJdR * erhead(k) + + gvdwc(k,j) = gvdwc(k,j) + & + dGCLdR * erhead(k) + & + dGGBdR * erhead(k) + & + dGCVdR * erhead(k) + & + dPOLdR1 * erhead_tail(k,1) + & + dPOLdR2 * erhead_tail(k,2) + & + dGLJdR * erhead(k) + + END DO + RETURN + END SUBROUTINE eqq +c!------------------------------------------------------------------- + SUBROUTINE energy_quad + &(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad) + IMPLICIT NONE + INCLUDE 'DIMENSIONS' + INCLUDE 'DIMENSIONS.ZSCOPT' + INCLUDE 'COMMON.CALC' + INCLUDE 'COMMON.CHAIN' + INCLUDE 'COMMON.CONTROL' + INCLUDE 'COMMON.DERIV' + INCLUDE 'COMMON.EMP' + INCLUDE 'COMMON.GEO' + INCLUDE 'COMMON.INTERACT' + INCLUDE 'COMMON.IOUNITS' + INCLUDE 'COMMON.LOCAL' + INCLUDE 'COMMON.NAMES' + INCLUDE 'COMMON.VAR' + double precision scalar + double precision ener(4) + double precision dcosom1(3),dcosom2(3) +c! used in Epol derivatives + double precision facd3, facd4 + double precision federmaus, adler +c! Epol and Gpol analytical parameters + alphapol1 = alphapol(itypi,itypj) + alphapol2 = alphapol(itypj,itypi) +c! Fisocav and Gisocav analytical parameters + al1 = alphiso(1,itypi,itypj) + al2 = alphiso(2,itypi,itypj) + al3 = alphiso(3,itypi,itypj) + al4 = alphiso(4,itypi,itypj) + csig = (1.0d0 + & / dsqrt(sigiso1(itypi, itypj)**2.0d0 + & + sigiso2(itypi,itypj)**2.0d0)) +c! + w1 = wqdip(1,itypi,itypj) + w2 = wqdip(2,itypi,itypj) + pis = sig0head(itypi,itypj) + eps_head = epshead(itypi,itypj) +c! First things first: +c! We need to do sc_grad's job with GB and Fcav + eom1 = + & eps2der * eps2rt_om1 + & - 2.0D0 * alf1 * eps3der + & + sigder * sigsq_om1 + & + dCAVdOM1 + eom2 = + & eps2der * eps2rt_om2 + & + 2.0D0 * alf2 * eps3der + & + sigder * sigsq_om2 + & + dCAVdOM2 + eom12 = + & evdwij * eps1_om12 + & + eps2der * eps2rt_om12 + & - 2.0D0 * alf12 * eps3der + & + sigder *sigsq_om12 + & + dCAVdOM12 +c! now some magical transformations to project gradient into +c! three cartesian vectors + DO k = 1, 3 + dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k)) + dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k)) + gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k) +c! this acts on hydrophobic center of interaction + gvdwx(k,i)= gvdwx(k,i) - gg(k) + & + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) + & + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv + gvdwx(k,j)= gvdwx(k,j) + gg(k) + & + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) + & + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv +c! this acts on Calpha + gvdwc(k,i)=gvdwc(k,i)-gg(k) + gvdwc(k,j)=gvdwc(k,j)+gg(k) + END DO +c! sc_grad is done, now we will compute + eheadtail = 0.0d0 + eom1 = 0.0d0 + eom2 = 0.0d0 + eom12 = 0.0d0 + +c! ENERGY DEBUG +c! ii = 1 +c! jj = 1 +c! d1 = dhead(1, 1, itypi, itypj) +c! d2 = dhead(2, 1, itypi, itypj) +c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) +c! & +dhead(1,ii,itypi,itypj))**2)) +c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) +c! & +dhead(2,jj,itypi,itypj))**2)) +c! Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2)) +c! END OF ENERGY DEBUG +c************************************************************* + DO istate = 1, nstate(itypi,itypj) +c************************************************************* + IF (istate.ne.1) THEN + IF (istate.lt.3) THEN + ii = 1 + ELSE + ii = 2 + END IF + jj = istate/ii + d1 = dhead(1,ii,itypi,itypj) + d2 = dhead(2,jj,itypi,itypj) + DO k = 1,3 + chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres) + chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres) + Rhead_distance(k) = chead(k,2) - chead(k,1) + END DO +c! pitagoras (root of sum of squares) + Rhead = dsqrt( + & (Rhead_distance(1)*Rhead_distance(1)) + & + (Rhead_distance(2)*Rhead_distance(2)) + & + (Rhead_distance(3)*Rhead_distance(3))) + END IF + Rhead_sq = Rhead * Rhead + +c! R1 - distance between head of ith side chain and tail of jth sidechain +c! R2 - distance between head of jth side chain and tail of ith sidechain + R1 = 0.0d0 + R2 = 0.0d0 + DO k = 1, 3 +c! Calculate head-to-tail distances + R1=R1+(ctail(k,2)-chead(k,1))**2 + R2=R2+(chead(k,2)-ctail(k,1))**2 + END DO +c! Pitagoras + R1 = dsqrt(R1) + R2 = dsqrt(R2) + +c! ENERGY DEBUG +c! write (*,*) "istate = ", istate +c! write (*,*) "ii = ", ii +c! write (*,*) "jj = ", jj +c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) +c! & +dhead(1,ii,itypi,itypj))**2)) +c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) +c! & +dhead(2,jj,itypi,itypj))**2)) +c! Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2)) +c! Rhead_sq = Rhead * Rhead +c! write (*,*) "d1 = ",d1 +c! write (*,*) "d2 = ",d2 +c! write (*,*) "R1 = ",R1 +c! write (*,*) "R2 = ",R2 +c! write (*,*) "Rhead = ",Rhead +c! END OF ENERGY DEBUG + +c!------------------------------------------------------------------- +c! Coulomb electrostatic interaction + Ecl = (332.0d0 * Qij) / (Rhead * eps_in) +c! Ecl = 0.0d0 +c! write (*,*) "Ecl = ", Ecl +c! derivative of Ecl is Gcl... + dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in) +c! dGCLdR = 0.0d0 + dGCLdOM1 = 0.0d0 + dGCLdOM2 = 0.0d0 + dGCLdOM12 = 0.0d0 +c!------------------------------------------------------------------- +c! Generalised Born Solvent Polarization + ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq)) + Fgb = sqrt( ( Rhead_sq ) + a12sq * ee) + Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb +c! Egb = 0.0d0 +c! write (*,*) "a1*a2 = ", a12sq +c! write (*,*) "Rhead = ", Rhead +c! write (*,*) "Rhead_sq = ", Rhead_sq +c! write (*,*) "ee = ", ee +c! write (*,*) "Fgb = ", Fgb +c! write (*,*) "fac = ", eps_inout_fac +c! write (*,*) "Qij = ", Qij +c! write (*,*) "Egb = ", Egb +c! Derivative of Egb is Ggb... +c! dFGBdR is used by Quad's later... + dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb) + dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) ) + & / ( 2.0d0 * Fgb ) + dGGBdR = dGGBdFGB * dFGBdR +c! dGGBdR = 0.0d0 +c!------------------------------------------------------------------- +c! Fisocav - isotropic cavity creation term + pom = Rhead * csig + top = al1 * (dsqrt(pom) + al2 * pom - al3) + bot = (1.0d0 + al4 * pom**12.0d0) + botsq = bot * bot + FisoCav = top / bot +c! FisoCav = 0.0d0 +c! write (*,*) "pom = ",pom +c! write (*,*) "al1 = ",al1 +c! write (*,*) "al2 = ",al2 +c! write (*,*) "al3 = ",al3 +c! write (*,*) "al4 = ",al4 +c! write (*,*) "top = ",top +c! write (*,*) "bot = ",bot +c! write (*,*) "Fisocav = ", Fisocav + +c! Derivative of Fisocav is GCV... + dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2) + dbot = 12.0d0 * al4 * pom ** 11.0d0 + dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig +c! dGCVdR = 0.0d0 +c!------------------------------------------------------------------- +c! Polarization energy +c! Epol + MomoFac1 = (1.0d0 - chi1 * sqom2) + MomoFac2 = (1.0d0 - chi2 * sqom1) + RR1 = ( R1 * R1 ) / MomoFac1 + RR2 = ( R2 * R2 ) / MomoFac2 + ee1 = exp(-( RR1 / (4.0d0 * a12sq) )) + ee2 = exp(-( RR2 / (4.0d0 * a12sq) )) + fgb1 = sqrt( RR1 + a12sq * ee1 ) + fgb2 = sqrt( RR2 + a12sq * ee2 ) + epol = 332.0d0 * eps_inout_fac * ( + & (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 )) +c! epol = 0.0d0 +c! derivative of Epol is Gpol... + dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) + & / (fgb1 ** 5.0d0) + dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) + & / (fgb2 ** 5.0d0) + dFGBdR1 = ( (R1 / MomoFac1) + & * ( 2.0d0 - (0.5d0 * ee1) ) ) + & / ( 2.0d0 * fgb1 ) + dFGBdR2 = ( (R2 / MomoFac2) + & * ( 2.0d0 - (0.5d0 * ee2) ) ) + & / ( 2.0d0 * fgb2 ) + dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) + & * ( 2.0d0 - 0.5d0 * ee1) ) + & / ( 2.0d0 * fgb1 ) + dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) + & * ( 2.0d0 - 0.5d0 * ee2) ) + & / ( 2.0d0 * fgb2 ) + dPOLdR1 = dPOLdFGB1 * dFGBdR1 +c! dPOLdR1 = 0.0d0 + dPOLdR2 = dPOLdFGB2 * dFGBdR2 +c! dPOLdR2 = 0.0d0 + dPOLdOM1 = dPOLdFGB2 * dFGBdOM1 +c! dPOLdOM1 = 0.0d0 + dPOLdOM2 = dPOLdFGB1 * dFGBdOM2 +c! dPOLdOM2 = 0.0d0 +c!------------------------------------------------------------------- +c! Elj + pom = (pis / Rhead)**6.0d0 + Elj = 4.0d0 * eps_head * pom * (pom-1.0d0) +c! Elj = 0.0d0 +c! derivative of Elj is Glj + dGLJdR = 4.0d0 * eps_head + & * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) + & + (( 6.0d0*pis**6.0d0) /(Rhead**7.0d0))) +c! dGLJdR = 0.0d0 +c!------------------------------------------------------------------- +c! Equad + IF (Wqd.ne.0.0d0) THEN + Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0) + & - 37.5d0 * ( sqom1 + sqom2 ) + & + 157.5d0 * ( sqom1 * sqom2 ) + & - 45.0d0 * om1*om2*om12 + fac = -( Wqd / (2.0d0 * Fgb**5.0d0) ) + Equad = fac * Beta1 +c! Equad = 0.0d0 +c! derivative of Equad... + dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR +c! dQUADdR = 0.0d0 + dQUADdOM1 = fac + & * (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12) +c! dQUADdOM1 = 0.0d0 + dQUADdOM2 = fac + & * (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12) +c! dQUADdOM2 = 0.0d0 + dQUADdOM12 = fac + & * ( 6.0d0*om12 - 45.0d0*om1*om2 ) +c! dQUADdOM12 = 0.0d0 + ELSE + Beta1 = 0.0d0 + Equad = 0.0d0 + END IF +c!------------------------------------------------------------------- +c! Return the results +c! Angular stuff + eom1 = dPOLdOM1 + dQUADdOM1 + eom2 = dPOLdOM2 + dQUADdOM2 + eom12 = dQUADdOM12 +c! now some magical transformations to project gradient into +c! three cartesian vectors + DO k = 1, 3 + dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k)) + dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k)) + tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k) + END DO +c! Radial stuff + DO k = 1, 3 + erhead(k) = Rhead_distance(k)/Rhead + erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1) + erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2) + END DO + erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) + erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) + bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) ) + federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres)) + eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) ) + adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) ) + facd1 = d1 * vbld_inv(i+nres) + facd2 = d2 * vbld_inv(j+nres) + facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres) + facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres) +c! Throw the results into gheadtail which holds gradients +c! for each micro-state + DO k = 1, 3 + hawk = erhead_tail(k,1) + + & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)) + condor = erhead_tail(k,2) + + & facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)) + + pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) +c! this acts on hydrophobic center of interaction + gheadtail(k,1,1) = gheadtail(k,1,1) + & - dGCLdR * pom + & - dGGBdR * pom + & - dGCVdR * pom + & - dPOLdR1 * hawk + & - dPOLdR2 * (erhead_tail(k,2) + & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) + & - dGLJdR * pom + & - dQUADdR * pom + & - tuna(k) + & + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) + & + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv + + pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) +c! this acts on hydrophobic center of interaction + gheadtail(k,2,1) = gheadtail(k,2,1) + & + dGCLdR * pom + & + dGGBdR * pom + & + dGCVdR * pom + & + dPOLdR1 * (erhead_tail(k,1) + & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) + & + dPOLdR2 * condor + & + dGLJdR * pom + & + dQUADdR * pom + & + tuna(k) + & + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) + & + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv + +c! this acts on Calpha + gheadtail(k,3,1) = gheadtail(k,3,1) + & - dGCLdR * erhead(k) + & - dGGBdR * erhead(k) + & - dGCVdR * erhead(k) + & - dPOLdR1 * erhead_tail(k,1) + & - dPOLdR2 * erhead_tail(k,2) + & - dGLJdR * erhead(k) + & - dQUADdR * erhead(k) + & - tuna(k) + +c! this acts on Calpha + gheadtail(k,4,1) = gheadtail(k,4,1) + & + dGCLdR * erhead(k) + & + dGGBdR * erhead(k) + & + dGCVdR * erhead(k) + & + dPOLdR1 * erhead_tail(k,1) + & + dPOLdR2 * erhead_tail(k,2) + & + dGLJdR * erhead(k) + & + dQUADdR * erhead(k) + & + tuna(k) + END DO +c! write(*,*) "ECL = ", Ecl +c! write(*,*) "Egb = ", Egb +c! write(*,*) "Epol = ", Epol +c! write(*,*) "Fisocav = ", Fisocav +c! write(*,*) "Elj = ", Elj +c! write(*,*) "Equad = ", Equad +c! write(*,*) "wstate = ", wstate(istate,itypi,itypj) +c! write(*,*) "eheadtail = ", eheadtail +c! write(*,*) "TROLL = ", dexp(-betaT * ener(istate)) +c! write(*,*) "dGCLdR = ", dGCLdR +c! write(*,*) "dGGBdR = ", dGGBdR +c! write(*,*) "dGCVdR = ", dGCVdR +c! write(*,*) "dPOLdR1 = ", dPOLdR1 +c! write(*,*) "dPOLdR2 = ", dPOLdR2 +c! write(*,*) "dGLJdR = ", dGLJdR +c! write(*,*) "dQUADdR = ", dQUADdR +c! write(*,*) "tuna(",k,") = ", tuna(k) + ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad + eheadtail = eheadtail + & + wstate(istate, itypi, itypj) + & * dexp(-betaT * ener(istate)) +c! foreach cartesian dimension + DO k = 1, 3 +c! foreach of two gvdwx and gvdwc + DO l = 1, 4 + gheadtail(k,l,2) = gheadtail(k,l,2) + & + wstate( istate, itypi, itypj ) + & * dexp(-betaT * ener(istate)) + & * gheadtail(k,l,1) + gheadtail(k,l,1) = 0.0d0 + END DO + END DO + END DO +c! Here ended the gigantic DO istate = 1, 4, which starts +c! at the beggining of the subroutine + + DO k = 1, 3 + DO l = 1, 4 + gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail + END DO + gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2) + gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2) + gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2) + gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2) + DO l = 1, 4 + gheadtail(k,l,1) = 0.0d0 + gheadtail(k,l,2) = 0.0d0 + END DO + END DO + eheadtail = (-dlog(eheadtail)) / betaT + dPOLdOM1 = 0.0d0 + dPOLdOM2 = 0.0d0 + dQUADdOM1 = 0.0d0 + dQUADdOM2 = 0.0d0 + dQUADdOM12 = 0.0d0 + RETURN + END SUBROUTINE energy_quad + + +c!------------------------------------------------------------------- + + + SUBROUTINE eqn(Epol) + IMPLICIT NONE + INCLUDE 'DIMENSIONS' + INCLUDE 'DIMENSIONS.ZSCOPT' + INCLUDE 'COMMON.CALC' + INCLUDE 'COMMON.CHAIN' + INCLUDE 'COMMON.CONTROL' + INCLUDE 'COMMON.DERIV' + INCLUDE 'COMMON.EMP' + INCLUDE 'COMMON.GEO' + INCLUDE 'COMMON.INTERACT' + INCLUDE 'COMMON.IOUNITS' + INCLUDE 'COMMON.LOCAL' + INCLUDE 'COMMON.NAMES' + INCLUDE 'COMMON.VAR' + double precision scalar, facd4, federmaus + alphapol1 = alphapol(itypi,itypj) +c! R1 - distance between head of ith side chain and tail of jth sidechain + R1 = 0.0d0 + DO k = 1, 3 +c! Calculate head-to-tail distances + R1=R1+(ctail(k,2)-chead(k,1))**2 + END DO +c! Pitagoras + R1 = dsqrt(R1) + +c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) +c! & +dhead(1,1,itypi,itypj))**2)) +c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) +c! & +dhead(2,1,itypi,itypj))**2)) +c-------------------------------------------------------------------- +c Polarization energy +c Epol + MomoFac1 = (1.0d0 - chi1 * sqom2) + RR1 = R1 * R1 / MomoFac1 + ee1 = exp(-( RR1 / (4.0d0 * a12sq) )) + fgb1 = sqrt( RR1 + a12sq * ee1) + epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0) +c! epol = 0.0d0 +c!------------------------------------------------------------------ +c! derivative of Epol is Gpol... + dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) + & / (fgb1 ** 5.0d0) + dFGBdR1 = ( (R1 / MomoFac1) + & * ( 2.0d0 - (0.5d0 * ee1) ) ) + & / ( 2.0d0 * fgb1 ) + dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) + & * (2.0d0 - 0.5d0 * ee1) ) + & / (2.0d0 * fgb1) + dPOLdR1 = dPOLdFGB1 * dFGBdR1 +c! dPOLdR1 = 0.0d0 + dPOLdOM1 = 0.0d0 + dPOLdOM2 = dPOLdFGB1 * dFGBdOM2 +c! dPOLdOM2 = 0.0d0 +c!------------------------------------------------------------------- +c! Return the results +c! (see comments in Eqq) + DO k = 1, 3 + erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1) + END DO + bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) ) + federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres)) + facd1 = d1 * vbld_inv(i+nres) + facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres) + + DO k = 1, 3 + hawk = (erhead_tail(k,1) + + & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres))) + + gvdwx(k,i) = gvdwx(k,i) + & - dPOLdR1 * hawk + gvdwx(k,j) = gvdwx(k,j) + & + dPOLdR1 * (erhead_tail(k,1) + & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) + + gvdwc(k,i) = gvdwc(k,i) + & - dPOLdR1 * erhead_tail(k,1) + gvdwc(k,j) = gvdwc(k,j) + & + dPOLdR1 * erhead_tail(k,1) + + END DO + RETURN + END SUBROUTINE eqn + + +c!------------------------------------------------------------------- + + + + SUBROUTINE enq(Epol) + IMPLICIT NONE + INCLUDE 'DIMENSIONS' + INCLUDE 'DIMENSIONS.ZSCOPT' + INCLUDE 'COMMON.CALC' + INCLUDE 'COMMON.CHAIN' + INCLUDE 'COMMON.CONTROL' + INCLUDE 'COMMON.DERIV' + INCLUDE 'COMMON.EMP' + INCLUDE 'COMMON.GEO' + INCLUDE 'COMMON.INTERACT' + INCLUDE 'COMMON.IOUNITS' + INCLUDE 'COMMON.LOCAL' + INCLUDE 'COMMON.NAMES' + INCLUDE 'COMMON.VAR' + double precision scalar, facd3, adler + alphapol2 = alphapol(itypj,itypi) +c! R2 - distance between head of jth side chain and tail of ith sidechain + R2 = 0.0d0 + DO k = 1, 3 +c! Calculate head-to-tail distances + R2=R2+(chead(k,2)-ctail(k,1))**2 + END DO +c! Pitagoras + R2 = dsqrt(R2) + +c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) +c! & +dhead(1,1,itypi,itypj))**2)) +c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) +c! & +dhead(2,1,itypi,itypj))**2)) +c------------------------------------------------------------------------ +c Polarization energy + MomoFac2 = (1.0d0 - chi2 * sqom1) + RR2 = R2 * R2 / MomoFac2 + ee2 = exp(-(RR2 / (4.0d0 * a12sq))) + fgb2 = sqrt(RR2 + a12sq * ee2) + epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 ) +c! epol = 0.0d0 +c!------------------------------------------------------------------- +c! derivative of Epol is Gpol... + dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) + & / (fgb2 ** 5.0d0) + dFGBdR2 = ( (R2 / MomoFac2) + & * ( 2.0d0 - (0.5d0 * ee2) ) ) + & / (2.0d0 * fgb2) + dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) + & * (2.0d0 - 0.5d0 * ee2) ) + & / (2.0d0 * fgb2) + dPOLdR2 = dPOLdFGB2 * dFGBdR2 +c! dPOLdR2 = 0.0d0 + dPOLdOM1 = dPOLdFGB2 * dFGBdOM1 +c! dPOLdOM1 = 0.0d0 + dPOLdOM2 = 0.0d0 +c!------------------------------------------------------------------- +c! Return the results +c! (See comments in Eqq) + DO k = 1, 3 + erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2) + END DO + eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) ) + adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) ) + facd2 = d2 * vbld_inv(j+nres) + facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres) + DO k = 1, 3 + condor = (erhead_tail(k,2) + & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))) + + gvdwx(k,i) = gvdwx(k,i) + & - dPOLdR2 * (erhead_tail(k,2) + & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) + gvdwx(k,j) = gvdwx(k,j) + & + dPOLdR2 * condor + + gvdwc(k,i) = gvdwc(k,i) + & - dPOLdR2 * erhead_tail(k,2) + gvdwc(k,j) = gvdwc(k,j) + & + dPOLdR2 * erhead_tail(k,2) + + END DO + RETURN + END SUBROUTINE enq + + +c!------------------------------------------------------------------- + + + SUBROUTINE eqd(Ecl,Elj,Epol) + IMPLICIT NONE + INCLUDE 'DIMENSIONS' + INCLUDE 'DIMENSIONS.ZSCOPT' + INCLUDE 'COMMON.CALC' + INCLUDE 'COMMON.CHAIN' + INCLUDE 'COMMON.CONTROL' + INCLUDE 'COMMON.DERIV' + INCLUDE 'COMMON.EMP' + INCLUDE 'COMMON.GEO' + INCLUDE 'COMMON.INTERACT' + INCLUDE 'COMMON.IOUNITS' + INCLUDE 'COMMON.LOCAL' + INCLUDE 'COMMON.NAMES' + INCLUDE 'COMMON.VAR' + double precision scalar, facd4, federmaus + alphapol1 = alphapol(itypi,itypj) + w1 = wqdip(1,itypi,itypj) + w2 = wqdip(2,itypi,itypj) + pis = sig0head(itypi,itypj) + eps_head = epshead(itypi,itypj) +c!------------------------------------------------------------------- +c! R1 - distance between head of ith side chain and tail of jth sidechain + R1 = 0.0d0 + DO k = 1, 3 +c! Calculate head-to-tail distances + R1=R1+(ctail(k,2)-chead(k,1))**2 + END DO +c! Pitagoras + R1 = dsqrt(R1) + +c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) +c! & +dhead(1,1,itypi,itypj))**2)) +c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) +c! & +dhead(2,1,itypi,itypj))**2)) + +c!------------------------------------------------------------------- +c! ecl + sparrow = w1 * Qi * om1 + hawk = w2 * Qi * Qi * (1.0d0 - sqom2) + Ecl = sparrow / Rhead**2.0d0 + & - hawk / Rhead**4.0d0 +c!------------------------------------------------------------------- +c! derivative of ecl is Gcl +c! dF/dr part + dGCLdR = - 2.0d0 * sparrow / Rhead**3.0d0 + & + 4.0d0 * hawk / Rhead**5.0d0 +c! dF/dom1 + dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0) +c! dF/dom2 + dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0) +c-------------------------------------------------------------------- +c Polarization energy +c Epol + MomoFac1 = (1.0d0 - chi1 * sqom2) + RR1 = R1 * R1 / MomoFac1 + ee1 = exp(-( RR1 / (4.0d0 * a12sq) )) + fgb1 = sqrt( RR1 + a12sq * ee1) + epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0) +c! epol = 0.0d0 +c!------------------------------------------------------------------ +c! derivative of Epol is Gpol... + dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) + & / (fgb1 ** 5.0d0) + dFGBdR1 = ( (R1 / MomoFac1) + & * ( 2.0d0 - (0.5d0 * ee1) ) ) + & / ( 2.0d0 * fgb1 ) + dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) + & * (2.0d0 - 0.5d0 * ee1) ) + & / (2.0d0 * fgb1) + dPOLdR1 = dPOLdFGB1 * dFGBdR1 +c! dPOLdR1 = 0.0d0 + dPOLdOM1 = 0.0d0 + dPOLdOM2 = dPOLdFGB1 * dFGBdOM2 +c! dPOLdOM2 = 0.0d0 +c!------------------------------------------------------------------- +c! Elj + pom = (pis / Rhead)**6.0d0 + Elj = 4.0d0 * eps_head * pom * (pom-1.0d0) +c! derivative of Elj is Glj + dGLJdR = 4.0d0 * eps_head + & * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) + & + (( 6.0d0*pis**6.0d0) /(Rhead**7.0d0))) +c!------------------------------------------------------------------- +c! Return the results + DO k = 1, 3 + erhead(k) = Rhead_distance(k)/Rhead + erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1) + END DO + + erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) + erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) + bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) ) + federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres)) + facd1 = d1 * vbld_inv(i+nres) + facd2 = d2 * vbld_inv(j+nres) + facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres) + + DO k = 1, 3 + hawk = (erhead_tail(k,1) + + & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres))) + + pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) + gvdwx(k,i) = gvdwx(k,i) + & - dGCLdR * pom + & - dPOLdR1 * hawk + & - dGLJdR * pom + + pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) + gvdwx(k,j) = gvdwx(k,j) + & + dGCLdR * pom + & + dPOLdR1 * (erhead_tail(k,1) + & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) + & + dGLJdR * pom + + + gvdwc(k,i) = gvdwc(k,i) + & - dGCLdR * erhead(k) + & - dPOLdR1 * erhead_tail(k,1) + & - dGLJdR * erhead(k) + + gvdwc(k,j) = gvdwc(k,j) + & + dGCLdR * erhead(k) + & + dPOLdR1 * erhead_tail(k,1) + & + dGLJdR * erhead(k) + + END DO + RETURN + END SUBROUTINE eqd + + +c!------------------------------------------------------------------- + + + SUBROUTINE edq(Ecl,Elj,Epol) + IMPLICIT NONE + INCLUDE 'DIMENSIONS' + INCLUDE 'DIMENSIONS.ZSCOPT' + INCLUDE 'COMMON.CALC' + INCLUDE 'COMMON.CHAIN' + INCLUDE 'COMMON.CONTROL' + INCLUDE 'COMMON.DERIV' + INCLUDE 'COMMON.EMP' + INCLUDE 'COMMON.GEO' + INCLUDE 'COMMON.INTERACT' + INCLUDE 'COMMON.IOUNITS' + INCLUDE 'COMMON.LOCAL' + INCLUDE 'COMMON.NAMES' + INCLUDE 'COMMON.VAR' + double precision scalar, facd3, adler + alphapol2 = alphapol(itypj,itypi) + w1 = wqdip(1,itypi,itypj) + w2 = wqdip(2,itypi,itypj) + pis = sig0head(itypi,itypj) + eps_head = epshead(itypi,itypj) +c!------------------------------------------------------------------- +c! R2 - distance between head of jth side chain and tail of ith sidechain + R2 = 0.0d0 + DO k = 1, 3 +c! Calculate head-to-tail distances + R2=R2+(chead(k,2)-ctail(k,1))**2 + END DO +c! Pitagoras + R2 = dsqrt(R2) + +c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) +c! & +dhead(1,1,itypi,itypj))**2)) +c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) +c! & +dhead(2,1,itypi,itypj))**2)) + + +c!------------------------------------------------------------------- +c! ecl + sparrow = w1 * Qi * om1 + hawk = w2 * Qi * Qi * (1.0d0 - sqom2) + ECL = sparrow / Rhead**2.0d0 + & - hawk / Rhead**4.0d0 +c!------------------------------------------------------------------- +c! derivative of ecl is Gcl +c! dF/dr part + dGCLdR = - 2.0d0 * sparrow / Rhead**3.0d0 + & + 4.0d0 * hawk / Rhead**5.0d0 +c! dF/dom1 + dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0) +c! dF/dom2 + dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0) +c-------------------------------------------------------------------- +c Polarization energy +c Epol + MomoFac2 = (1.0d0 - chi2 * sqom1) + RR2 = R2 * R2 / MomoFac2 + ee2 = exp(-(RR2 / (4.0d0 * a12sq))) + fgb2 = sqrt(RR2 + a12sq * ee2) + epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 ) +c! epol = 0.0d0 +c! derivative of Epol is Gpol... + dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) + & / (fgb2 ** 5.0d0) + dFGBdR2 = ( (R2 / MomoFac2) + & * ( 2.0d0 - (0.5d0 * ee2) ) ) + & / (2.0d0 * fgb2) + dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) + & * (2.0d0 - 0.5d0 * ee2) ) + & / (2.0d0 * fgb2) + dPOLdR2 = dPOLdFGB2 * dFGBdR2 +c! dPOLdR2 = 0.0d0 + dPOLdOM1 = dPOLdFGB2 * dFGBdOM1 +c! dPOLdOM1 = 0.0d0 + dPOLdOM2 = 0.0d0 +c!------------------------------------------------------------------- +c! Elj + pom = (pis / Rhead)**6.0d0 + Elj = 4.0d0 * eps_head * pom * (pom-1.0d0) +c! derivative of Elj is Glj + dGLJdR = 4.0d0 * eps_head + & * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) + & + (( 6.0d0*pis**6.0d0) /(Rhead**7.0d0))) +c!------------------------------------------------------------------- +c! Return the results +c! (see comments in Eqq) + DO k = 1, 3 + erhead(k) = Rhead_distance(k)/Rhead + erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2) + END DO + erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) + erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) + eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) ) + adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) ) + facd1 = d1 * vbld_inv(i+nres) + facd2 = d2 * vbld_inv(j+nres) + facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres) + + DO k = 1, 3 + condor = (erhead_tail(k,2) + & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))) + + pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) + gvdwx(k,i) = gvdwx(k,i) + & - dGCLdR * pom + & - dPOLdR2 * (erhead_tail(k,2) + & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) + & - dGLJdR * pom + + pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) + gvdwx(k,j) = gvdwx(k,j) + & + dGCLdR * pom + & + dPOLdR2 * condor + & + dGLJdR * pom + + + gvdwc(k,i) = gvdwc(k,i) + & - dGCLdR * erhead(k) + & - dPOLdR2 * erhead_tail(k,2) + & - dGLJdR * erhead(k) + + gvdwc(k,j) = gvdwc(k,j) + & + dGCLdR * erhead(k) + & + dPOLdR2 * erhead_tail(k,2) + & + dGLJdR * erhead(k) + + END DO + RETURN + END SUBROUTINE edq + + +C-------------------------------------------------------------------- + + + SUBROUTINE edd(ECL) + IMPLICIT NONE + INCLUDE 'DIMENSIONS' + INCLUDE 'DIMENSIONS.ZSCOPT' + INCLUDE 'COMMON.CALC' + INCLUDE 'COMMON.CHAIN' + INCLUDE 'COMMON.CONTROL' + INCLUDE 'COMMON.DERIV' + INCLUDE 'COMMON.EMP' + INCLUDE 'COMMON.GEO' + INCLUDE 'COMMON.INTERACT' + INCLUDE 'COMMON.IOUNITS' + INCLUDE 'COMMON.LOCAL' + INCLUDE 'COMMON.NAMES' + INCLUDE 'COMMON.VAR' + double precision scalar +c! csig = sigiso(itypi,itypj) + w1 = wqdip(1,itypi,itypj) + w2 = wqdip(2,itypi,itypj) +c!------------------------------------------------------------------- +c! ECL + fac = (om12 - 3.0d0 * om1 * om2) + c1 = (w1 / (Rhead**3.0d0)) * fac + c2 = (w2 / Rhead ** 6.0d0) + & * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2)) + ECL = c1 - c2 +c! write (*,*) "w1 = ", w1 +c! write (*,*) "w2 = ", w2 +c! write (*,*) "om1 = ", om1 +c! write (*,*) "om2 = ", om2 +c! write (*,*) "om12 = ", om12 +c! write (*,*) "fac = ", fac +c! write (*,*) "c1 = ", c1 +c! write (*,*) "c2 = ", c2 +c! write (*,*) "Ecl = ", Ecl +c! write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0) +c! write (*,*) "c2_2 = ", +c! & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2)) +c!------------------------------------------------------------------- +c! dervative of ECL is GCL... +c! dECL/dr + c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0) + c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) + & * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2)) + dGCLdR = c1 - c2 +c! dECL/dom1 + c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0) + c2 = (-6.0d0 * w2) / (Rhead**6.0d0) + & * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 ) + dGCLdOM1 = c1 - c2 +c! dECL/dom2 + c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0) + c2 = (-6.0d0 * w2) / (Rhead**6.0d0) + & * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 ) + dGCLdOM2 = c1 - c2 +c! dECL/dom12 + c1 = w1 / (Rhead ** 3.0d0) + c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0 + dGCLdOM12 = c1 - c2 +c!------------------------------------------------------------------- +c! Return the results +c! (see comments in Eqq) + DO k= 1, 3 + erhead(k) = Rhead_distance(k)/Rhead + END DO + erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) + erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) + facd1 = d1 * vbld_inv(i+nres) + facd2 = d2 * vbld_inv(j+nres) + DO k = 1, 3 + + pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) + gvdwx(k,i) = gvdwx(k,i) + & - dGCLdR * pom + pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) + gvdwx(k,j) = gvdwx(k,j) + & + dGCLdR * pom + + gvdwc(k,i) = gvdwc(k,i) + & - dGCLdR * erhead(k) + gvdwc(k,j) = gvdwc(k,j) + & + dGCLdR * erhead(k) + END DO + RETURN + END SUBROUTINE edd + + +c!------------------------------------------------------------------- + + + SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol) + IMPLICIT NONE +c! maxres + INCLUDE 'DIMENSIONS' +c! itypi, itypj, i, j, k, l, chead, + INCLUDE 'COMMON.CALC' +c! c, nres, dc_norm + INCLUDE 'COMMON.CHAIN' +c! gradc, gradx + INCLUDE 'COMMON.DERIV' +c! electrostatic gradients-specific variables + INCLUDE 'COMMON.EMP' +c! wquad, dhead, alphiso, alphasur, rborn, epsintab + INCLUDE 'COMMON.INTERACT' +c! io for debug, disable it in final builds + INCLUDE 'COMMON.IOUNITS' +c!------------------------------------------------------------------- +c! Variable Init + +c! what amino acid is the aminoacid j'th? + itypj = itype(j) +c! 1/(Gas Constant * Thermostate temperature) = BetaT +c! ENABLE THIS LINE WHEN USING CHECKGRAD!!! + BetaT = 1.0d0 / (298 * 1.987d-3) +c! Gay-berne var's + sig0ij = sigma( itypi,itypj ) + chi1 = chi( itypi, itypj ) + chi2 = chi( itypj, itypi ) + chi12 = chi1 * chi2 + chip1 = chipp( itypi, itypj ) + chip2 = chipp( itypj, itypi ) + chip12 = chip1 * chip2 +c! write (2,*) "elgrad types",itypi,itypj, +c! & " chi1",chi1," chi2",chi2," chi12",chi12, +c! & " chip1",chip1," chip2",chip2," chip12",chip12 +c! not used by momo potential, but needed by sc_angular which is shared +c! by all energy_potential subroutines + alf1 = 0.0d0 + alf2 = 0.0d0 + alf12 = 0.0d0 +c! location, location, location + xj = c( 1, nres+j ) - xi + yj = c( 2, nres+j ) - yi + zj = c( 3, nres+j ) - zi + dxj = dc_norm( 1, nres+j ) + dyj = dc_norm( 2, nres+j ) + dzj = dc_norm( 3, nres+j ) +c! distance from center of chain(?) to polar/charged head +c! write (*,*) "istate = ", 1 +c! write (*,*) "ii = ", 1 +c! write (*,*) "jj = ", 1 + d1 = dhead(1, 1, itypi, itypj) + d2 = dhead(2, 1, itypi, itypj) +c! ai*aj from Fgb + a12sq = rborn(itypi,itypj) * rborn(itypj,itypi) +c! a12sq = a12sq * a12sq +c! charge of amino acid itypi is... + Qi = icharge(itypi) + Qj = icharge(itypj) + Qij = Qi * Qj +c! chis1,2,12 + chis1 = chis(itypi,itypj) + chis2 = chis(itypj,itypi) + chis12 = chis1 * chis2 + sig1 = sigmap1(itypi,itypj) + sig2 = sigmap2(itypi,itypj) +c! write (*,*) "sig1 = ", sig1 +c! write (*,*) "sig2 = ", sig2 +c! alpha factors from Fcav/Gcav + b1 = alphasur(1,itypi,itypj) + b2 = alphasur(2,itypi,itypj) + b3 = alphasur(3,itypi,itypj) + b4 = alphasur(4,itypi,itypj) +c! used to determine whether we want to do quadrupole calculations + wqd = wquad(itypi, itypj) +c! used by Fgb + eps_in = epsintab(itypi,itypj) + eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out)) +c! write (*,*) "eps_inout_fac = ", eps_inout_fac +c!------------------------------------------------------------------- +c! tail location and distance calculations + Rtail = 0.0d0 + DO k = 1, 3 + ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i) + ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j) + END DO +c! tail distances will be themselves usefull elswhere +c1 (in Gcav, for example) + Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 ) + Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 ) + Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 ) + Rtail = dsqrt( + & (Rtail_distance(1)*Rtail_distance(1)) + & + (Rtail_distance(2)*Rtail_distance(2)) + & + (Rtail_distance(3)*Rtail_distance(3))) +c!------------------------------------------------------------------- +c! Calculate location and distance between polar heads +c! distance between heads +c! for each one of our three dimensional space... + DO k = 1,3 +c! location of polar head is computed by taking hydrophobic centre +c! and moving by a d1 * dc_norm vector +c! see unres publications for very informative images + chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres) + chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres) +c! distance +c! Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres)) +c! Rsc(k) = Rsc_distance(k) * Rsc_distance(k) + Rhead_distance(k) = chead(k,2) - chead(k,1) + END DO +c! pitagoras (root of sum of squares) + Rhead = dsqrt( + & (Rhead_distance(1)*Rhead_distance(1)) + & + (Rhead_distance(2)*Rhead_distance(2)) + & + (Rhead_distance(3)*Rhead_distance(3))) +c!------------------------------------------------------------------- +c! zero everything that should be zero'ed + Egb = 0.0d0 + ECL = 0.0d0 + Elj = 0.0d0 + Equad = 0.0d0 + Epol = 0.0d0 + eheadtail = 0.0d0 + dGCLdOM1 = 0.0d0 + dGCLdOM2 = 0.0d0 + dGCLdOM12 = 0.0d0 + dPOLdOM1 = 0.0d0 + dPOLdOM2 = 0.0d0 + RETURN + END SUBROUTINE elgrad_init +c!------------------------------------------------------------------- + subroutine sc_angular +C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2, +C om12. Called by ebp, egb, and egbv. + implicit none + include 'COMMON.CALC' + include 'COMMON.IOUNITS' + erij(1)=xj*rij + erij(2)=yj*rij + erij(3)=zj*rij + om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) + om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) + om12=dxi*dxj+dyi*dyj+dzi*dzj +c! om1 = 0.0d0 +c! om2 = 0.0d0 +c! om12 = 0.0d0 + chiom12=chi12*om12 +C Calculate eps1(om12) and its derivative in om12 + faceps1=1.0D0-om12*chiom12 + faceps1_inv=1.0D0/faceps1 + eps1=dsqrt(faceps1_inv) +c write (2,*) "chi1",chi1," chi2",chi2," chi12",chi12 +c write (2,*) "fsceps1",faceps1," faceps1_inv",faceps1_inv, +c & " eps1",eps1 +C Following variable is eps1*deps1/dom12 + eps1_om12=faceps1_inv*chiom12 +c diagnostics only +c faceps1_inv=om12 +c eps1=om12 +c eps1_om12=1.0d0 +c write (iout,*) "om12",om12," eps1",eps1 +C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2, +C and om12. + om1om2=om1*om2 + chiom1=chi1*om1 + chiom2=chi2*om2 + facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12 + sigsq=1.0D0-facsig*faceps1_inv +c write (2,*) "om1",om1," om2",om2," om1om2",om1om2, +c & " chiom1",chiom1, +c & " chiom2",chiom2," facsig",facsig," sigsq",sigsq + sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv + sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv + sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2 +c diagnostics only +c sigsq=1.0d0 +c sigsq_om1=0.0d0 +c sigsq_om2=0.0d0 +c sigsq_om12=0.0d0 +c write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12 +c write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv, +c & " eps1",eps1 +C Calculate eps2 and its derivatives in om1, om2, and om12. + chipom1=chip1*om1 + chipom2=chip2*om2 + chipom12=chip12*om12 + facp=1.0D0-om12*chipom12 + facp_inv=1.0D0/facp + facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12 +c write (iout,*) "chipom1",chipom1," chipom2",chipom2, +c & " chipom12",chipom12," facp",facp," facp_inv",facp_inv +C Following variable is the square root of eps2 + eps2rt=1.0D0-facp1*facp_inv +C Following three variables are the derivatives of the square root of eps +C in om1, om2, and om12. + eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv + eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv + eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2 +C Evaluate the "asymmetric" factor in the VDW constant, eps3 +c! Note that THIS is 0 in emomo, so we should probably move it out of sc_angular +c! Or frankly, we should restructurize the whole energy section + eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12 +c write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt +c write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2, +c & " eps2rt_om12",eps2rt_om12 +C Calculate whole angle-dependent part of epsilon and contributions +C to its derivatives + return + end +C---------------------------------------------------------------------------- + subroutine sc_grad + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.CALC' + double precision dcosom1(3),dcosom2(3) + eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 + eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 + eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 + & -2.0D0*alf12*eps3der+sigder*sigsq_om12 + do k=1,3 + dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) + dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k)) + enddo + do k=1,3 + gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k) + enddo + do k=1,3 + gvdwx(k,i)=gvdwx(k,i)-gg(k) + & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) + & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv + gvdwx(k,j)=gvdwx(k,j)+gg(k) + & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) + & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv + enddo +C +C Calculate the components of the gradient in DC and X +C + do k=i,j-1 + do l=1,3 + gvdwc(l,k)=gvdwc(l,k)+gg(l) + enddo + enddo + return + end +c------------------------------------------------------------------------------ + subroutine vec_and_deriv + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.VECTORS' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2) +C Compute the local reference systems. For reference system (i), the +C X-axis points from CA(i) to CA(i+1), the Y axis is in the +C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane. + do i=1,nres-1 +c if (i.eq.nres-1 .or. itel(i+1).eq.0) then + if (i.eq.nres-1) then +C Case of the last full residue +C Compute the Z-axis + call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i)) + costh=dcos(pi-theta(nres)) + fac=1.0d0/dsqrt(1.0d0-costh*costh) + do k=1,3 + uz(k,i)=fac*uz(k,i) + enddo + if (calc_grad) then +C Compute the derivatives of uz + uzder(1,1,1)= 0.0d0 + uzder(2,1,1)=-dc_norm(3,i-1) + uzder(3,1,1)= dc_norm(2,i-1) + uzder(1,2,1)= dc_norm(3,i-1) + uzder(2,2,1)= 0.0d0 + uzder(3,2,1)=-dc_norm(1,i-1) + uzder(1,3,1)=-dc_norm(2,i-1) + uzder(2,3,1)= dc_norm(1,i-1) + uzder(3,3,1)= 0.0d0 + uzder(1,1,2)= 0.0d0 + uzder(2,1,2)= dc_norm(3,i) + uzder(3,1,2)=-dc_norm(2,i) + uzder(1,2,2)=-dc_norm(3,i) + uzder(2,2,2)= 0.0d0 + uzder(3,2,2)= dc_norm(1,i) + uzder(1,3,2)= dc_norm(2,i) + uzder(2,3,2)=-dc_norm(1,i) + uzder(3,3,2)= 0.0d0 + endif +C Compute the Y-axis + facy=fac + do k=1,3 + uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i)) + enddo + if (calc_grad) then +C Compute the derivatives of uy + do j=1,3 + do k=1,3 + uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) + & -dc_norm(k,i)*dc_norm(j,i-1) + uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i) + enddo + uyder(j,j,1)=uyder(j,j,1)-costh + uyder(j,j,2)=1.0d0+uyder(j,j,2) + enddo + do j=1,2 + do k=1,3 + do l=1,3 + uygrad(l,k,j,i)=uyder(l,k,j) + uzgrad(l,k,j,i)=uzder(l,k,j) + enddo + enddo + enddo + call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i)) + call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i)) + call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i)) + call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i)) + endif + else +C Other residues +C Compute the Z-axis + call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i)) + costh=dcos(pi-theta(i+2)) + fac=1.0d0/dsqrt(1.0d0-costh*costh) + do k=1,3 + uz(k,i)=fac*uz(k,i) + enddo + if (calc_grad) then +C Compute the derivatives of uz + uzder(1,1,1)= 0.0d0 + uzder(2,1,1)=-dc_norm(3,i+1) + uzder(3,1,1)= dc_norm(2,i+1) + uzder(1,2,1)= dc_norm(3,i+1) + uzder(2,2,1)= 0.0d0 + uzder(3,2,1)=-dc_norm(1,i+1) + uzder(1,3,1)=-dc_norm(2,i+1) + uzder(2,3,1)= dc_norm(1,i+1) + uzder(3,3,1)= 0.0d0 + uzder(1,1,2)= 0.0d0 + uzder(2,1,2)= dc_norm(3,i) + uzder(3,1,2)=-dc_norm(2,i) + uzder(1,2,2)=-dc_norm(3,i) + uzder(2,2,2)= 0.0d0 + uzder(3,2,2)= dc_norm(1,i) + uzder(1,3,2)= dc_norm(2,i) + uzder(2,3,2)=-dc_norm(1,i) + uzder(3,3,2)= 0.0d0 + endif +C Compute the Y-axis + facy=fac + do k=1,3 + uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i)) + enddo + if (calc_grad) then +C Compute the derivatives of uy + do j=1,3 + do k=1,3 + uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) + & -dc_norm(k,i)*dc_norm(j,i+1) + uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i) + enddo + uyder(j,j,1)=uyder(j,j,1)-costh + uyder(j,j,2)=1.0d0+uyder(j,j,2) + enddo + do j=1,2 + do k=1,3 + do l=1,3 + uygrad(l,k,j,i)=uyder(l,k,j) + uzgrad(l,k,j,i)=uzder(l,k,j) + enddo + enddo + enddo + call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i)) + call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i)) + call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i)) + call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i)) + endif + endif + enddo + if (calc_grad) then + do i=1,nres-1 + vbld_inv_temp(1)=vbld_inv(i+1) + if (i.lt.nres-1) then + vbld_inv_temp(2)=vbld_inv(i+2) + else + vbld_inv_temp(2)=vbld_inv(i) + endif + do j=1,2 + do k=1,3 + do l=1,3 + uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i) + uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i) + enddo + enddo + enddo + enddo + endif + return + end +C----------------------------------------------------------------------------- + subroutine vec_and_deriv_test + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.VECTORS' + dimension uyder(3,3,2),uzder(3,3,2) +C Compute the local reference systems. For reference system (i), the +C X-axis points from CA(i) to CA(i+1), the Y axis is in the +C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane. + do i=1,nres-1 + if (i.eq.nres-1) then +C Case of the last full residue +C Compute the Z-axis + call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i)) + costh=dcos(pi-theta(nres)) + fac=1.0d0/dsqrt(1.0d0-costh*costh) +c write (iout,*) 'fac',fac, +c & 1.0d0/dsqrt(scalar(uz(1,i),uz(1,i))) + fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i))) + do k=1,3 + uz(k,i)=fac*uz(k,i) + enddo +C Compute the derivatives of uz + uzder(1,1,1)= 0.0d0 + uzder(2,1,1)=-dc_norm(3,i-1) + uzder(3,1,1)= dc_norm(2,i-1) + uzder(1,2,1)= dc_norm(3,i-1) + uzder(2,2,1)= 0.0d0 + uzder(3,2,1)=-dc_norm(1,i-1) + uzder(1,3,1)=-dc_norm(2,i-1) + uzder(2,3,1)= dc_norm(1,i-1) + uzder(3,3,1)= 0.0d0 + uzder(1,1,2)= 0.0d0 + uzder(2,1,2)= dc_norm(3,i) + uzder(3,1,2)=-dc_norm(2,i) + uzder(1,2,2)=-dc_norm(3,i) + uzder(2,2,2)= 0.0d0 + uzder(3,2,2)= dc_norm(1,i) + uzder(1,3,2)= dc_norm(2,i) + uzder(2,3,2)=-dc_norm(1,i) + uzder(3,3,2)= 0.0d0 +C Compute the Y-axis + do k=1,3 + uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i)) + enddo + facy=fac + facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))* + & (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2- + & scalar(dc_norm(1,i),dc_norm(1,i-1))**2)) + do k=1,3 +c uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i)) + uy(k,i)= +c & facy*( + & dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i)) + & -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i) +c & ) + enddo +c write (iout,*) 'facy',facy, +c & 1.0d0/dsqrt(scalar(uy(1,i),uy(1,i))) + facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i))) + do k=1,3 + uy(k,i)=facy*uy(k,i) + enddo +C Compute the derivatives of uy + do j=1,3 + do k=1,3 + uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) + & -dc_norm(k,i)*dc_norm(j,i-1) + uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i) + enddo +c uyder(j,j,1)=uyder(j,j,1)-costh +c uyder(j,j,2)=1.0d0+uyder(j,j,2) + uyder(j,j,1)=uyder(j,j,1) + & -scalar(dc_norm(1,i),dc_norm(1,i-1)) + uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i)) + & +uyder(j,j,2) + enddo + do j=1,2 + do k=1,3 + do l=1,3 + uygrad(l,k,j,i)=uyder(l,k,j) + uzgrad(l,k,j,i)=uzder(l,k,j) + enddo + enddo + enddo + call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i)) + call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i)) + call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i)) + call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i)) + else +C Other residues +C Compute the Z-axis + call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i)) + costh=dcos(pi-theta(i+2)) + fac=1.0d0/dsqrt(1.0d0-costh*costh) + fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i))) + do k=1,3 + uz(k,i)=fac*uz(k,i) + enddo +C Compute the derivatives of uz + uzder(1,1,1)= 0.0d0 + uzder(2,1,1)=-dc_norm(3,i+1) + uzder(3,1,1)= dc_norm(2,i+1) + uzder(1,2,1)= dc_norm(3,i+1) + uzder(2,2,1)= 0.0d0 + uzder(3,2,1)=-dc_norm(1,i+1) + uzder(1,3,1)=-dc_norm(2,i+1) + uzder(2,3,1)= dc_norm(1,i+1) + uzder(3,3,1)= 0.0d0 + uzder(1,1,2)= 0.0d0 + uzder(2,1,2)= dc_norm(3,i) + uzder(3,1,2)=-dc_norm(2,i) + uzder(1,2,2)=-dc_norm(3,i) + uzder(2,2,2)= 0.0d0 + uzder(3,2,2)= dc_norm(1,i) + uzder(1,3,2)= dc_norm(2,i) + uzder(2,3,2)=-dc_norm(1,i) + uzder(3,3,2)= 0.0d0 +C Compute the Y-axis + facy=fac + facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))* + & (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2- + & scalar(dc_norm(1,i),dc_norm(1,i+1))**2)) + do k=1,3 +c uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i)) + uy(k,i)= +c & facy*( + & dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i)) + & -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i) +c & ) + enddo +c write (iout,*) 'facy',facy, +c & 1.0d0/dsqrt(scalar(uy(1,i),uy(1,i))) + facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i))) + do k=1,3 + uy(k,i)=facy*uy(k,i) + enddo +C Compute the derivatives of uy + do j=1,3 + do k=1,3 + uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) + & -dc_norm(k,i)*dc_norm(j,i+1) + uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i) + enddo +c uyder(j,j,1)=uyder(j,j,1)-costh +c uyder(j,j,2)=1.0d0+uyder(j,j,2) + uyder(j,j,1)=uyder(j,j,1) + & -scalar(dc_norm(1,i),dc_norm(1,i+1)) + uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i)) + & +uyder(j,j,2) + enddo + do j=1,2 + do k=1,3 + do l=1,3 + uygrad(l,k,j,i)=uyder(l,k,j) + uzgrad(l,k,j,i)=uzder(l,k,j) + enddo + enddo + enddo + call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i)) + call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i)) + call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i)) + call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i)) + endif + enddo + do i=1,nres-1 + do j=1,2 + do k=1,3 + do l=1,3 + uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i) + uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i) + enddo + enddo + enddo + enddo + return + end +C----------------------------------------------------------------------------- + subroutine check_vecgrad + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.VECTORS' + dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres) + dimension uyt(3,maxres),uzt(3,maxres) + dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3) + double precision delta /1.0d-7/ + call vec_and_deriv +cd do i=1,nres +crc write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i) +crc write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i) +crc write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i) +cd write(iout,'(2i5,2(3f10.5,5x))') i,1, +cd & (dc_norm(if90,i),if90=1,3) +cd write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3) +cd write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3) +cd write(iout,'(a)') +cd enddo + do i=1,nres + do j=1,2 + do k=1,3 + do l=1,3 + uygradt(l,k,j,i)=uygrad(l,k,j,i) + uzgradt(l,k,j,i)=uzgrad(l,k,j,i) + enddo + enddo + enddo + enddo + call vec_and_deriv + do i=1,nres + do j=1,3 + uyt(j,i)=uy(j,i) + uzt(j,i)=uz(j,i) + enddo + enddo + do i=1,nres +cd write (iout,*) 'i=',i + do k=1,3 + erij(k)=dc_norm(k,i) + enddo + do j=1,3 + do k=1,3 + dc_norm(k,i)=erij(k) + enddo + dc_norm(j,i)=dc_norm(j,i)+delta +c fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))) +c do k=1,3 +c dc_norm(k,i)=dc_norm(k,i)/fac +c enddo +c write (iout,*) (dc_norm(k,i),k=1,3) +c write (iout,*) (erij(k),k=1,3) + call vec_and_deriv + do k=1,3 + uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta + uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta + uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta + uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta + enddo +c write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)') +c & j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3), +c & (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3) + enddo + do k=1,3 + dc_norm(k,i)=erij(k) + enddo +cd do k=1,3 +cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)') +cd & k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3), +cd & (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3) +cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)') +cd & k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3), +cd & (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3) +cd write (iout,'(a)') +cd enddo + enddo + return + end +C-------------------------------------------------------------------------- + subroutine set_matrices + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VECTORS' + include 'COMMON.FFIELD' + double precision auxvec(2),auxmat(2,2) +C +C Compute the virtual-bond-torsional-angle dependent quantities needed +C to calculate the el-loc multibody terms of various order. +C +#ifdef NEWCORR + do i=3,nres+1 + if (i.gt. nnt+2 .and. i.lt.nct+2) then + iti = itortyp(itype(i-2)) + else + iti=ntortyp+1 + endif + if (i.gt. nnt+1 .and. i.lt.nct+1) then + iti1 = itortyp(itype(i-1)) + else + iti1=ntortyp+1 + endif + b1(1,i-2)=bnew1(1,1,iti)*sin(theta(i-1)/2.0) + & +bnew1(2,1,iti)*sin(theta(i-1)) + & +bnew1(3,1,iti)*cos(theta(i-1)/2.0) + b2(1,i-2)=bnew2(1,1,iti)*sin(theta(i-1)/2.0) + & +bnew2(2,1,iti)*sin(theta(i-1)) + & +bnew2(3,1,iti)*cos(theta(i-1)/2.0) + b1(2,i-2)=bnew1(1,2,iti) + b2(2,i-2)=bnew2(1,2,iti) + EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1)) + EE(1,2,i-2)=eeold(1,2,iti) + EE(2,1,i-2)=eeold(2,1,iti) + EE(2,2,i-2)=eeold(2,2,iti) + b1tilde(1,i-2)=b1(1,i-2) + b1tilde(2,i-2)=-b1(2,i-2) + enddo +#endif + do i=3,nres+1 + if (i .lt. nres+1) then + sin1=dsin(phi(i)) + cos1=dcos(phi(i)) + sintab(i-2)=sin1 + costab(i-2)=cos1 + obrot(1,i-2)=cos1 + obrot(2,i-2)=sin1 + sin2=dsin(2*phi(i)) + cos2=dcos(2*phi(i)) + sintab2(i-2)=sin2 + costab2(i-2)=cos2 + obrot2(1,i-2)=cos2 + obrot2(2,i-2)=sin2 + Ug(1,1,i-2)=-cos1 + Ug(1,2,i-2)=-sin1 + Ug(2,1,i-2)=-sin1 + Ug(2,2,i-2)= cos1 + Ug2(1,1,i-2)=-cos2 + Ug2(1,2,i-2)=-sin2 + Ug2(2,1,i-2)=-sin2 + Ug2(2,2,i-2)= cos2 + else + costab(i-2)=1.0d0 + sintab(i-2)=0.0d0 + obrot(1,i-2)=1.0d0 + obrot(2,i-2)=0.0d0 + obrot2(1,i-2)=0.0d0 + obrot2(2,i-2)=0.0d0 + Ug(1,1,i-2)=1.0d0 + Ug(1,2,i-2)=0.0d0 + Ug(2,1,i-2)=0.0d0 + Ug(2,2,i-2)=1.0d0 + Ug2(1,1,i-2)=0.0d0 + Ug2(1,2,i-2)=0.0d0 + Ug2(2,1,i-2)=0.0d0 + Ug2(2,2,i-2)=0.0d0 + endif + if (i .gt. 3 .and. i .lt. nres+1) then + obrot_der(1,i-2)=-sin1 + obrot_der(2,i-2)= cos1 + Ugder(1,1,i-2)= sin1 + Ugder(1,2,i-2)=-cos1 + Ugder(2,1,i-2)=-cos1 + Ugder(2,2,i-2)=-sin1 + dwacos2=cos2+cos2 + dwasin2=sin2+sin2 + obrot2_der(1,i-2)=-dwasin2 + obrot2_der(2,i-2)= dwacos2 + Ug2der(1,1,i-2)= dwasin2 + Ug2der(1,2,i-2)=-dwacos2 + Ug2der(2,1,i-2)=-dwacos2 + Ug2der(2,2,i-2)=-dwasin2 + else + obrot_der(1,i-2)=0.0d0 + obrot_der(2,i-2)=0.0d0 + Ugder(1,1,i-2)=0.0d0 + Ugder(1,2,i-2)=0.0d0 + Ugder(2,1,i-2)=0.0d0 + Ugder(2,2,i-2)=0.0d0 + obrot2_der(1,i-2)=0.0d0 + obrot2_der(2,i-2)=0.0d0 + Ug2der(1,1,i-2)=0.0d0 + Ug2der(1,2,i-2)=0.0d0 + Ug2der(2,1,i-2)=0.0d0 + Ug2der(2,2,i-2)=0.0d0 + endif + if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then + iti = itortyp(itype(i-2)) + else + iti=ntortyp+1 + endif + if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then + iti1 = itortyp(itype(i-1)) + else + iti1=ntortyp+1 + endif +cd write (iout,*) '*******i',i,' iti1',iti +cd write (iout,*) 'b1',b1(:,iti) +cd write (iout,*) 'b2',b2(:,iti) +cd write (iout,*) 'Ug',Ug(:,:,i-2) + if (i .gt. iatel_s+2) then + call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2)) + call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2)) + call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2)) + call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2)) + call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2)) + call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2)) + call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2)) + else + do k=1,2 + Ub2(k,i-2)=0.0d0 + Ctobr(k,i-2)=0.0d0 + Dtobr2(k,i-2)=0.0d0 + do l=1,2 + EUg(l,k,i-2)=0.0d0 + CUg(l,k,i-2)=0.0d0 + DUg(l,k,i-2)=0.0d0 + DtUg2(l,k,i-2)=0.0d0 + enddo + enddo + endif + call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2)) + call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2)) + call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2)) + call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2)) + call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2)) + call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2)) + call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2)) + do k=1,2 + muder(k,i-2)=Ub2der(k,i-2) + enddo + if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then + iti1 = itortyp(itype(i-1)) + else + iti1=ntortyp+1 + endif + do k=1,2 + mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1) + enddo +C Vectors and matrices dependent on a single virtual-bond dihedral. + call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1)) + call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2)) + call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2)) + call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2)) + call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2)) + call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2)) + call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2)) + call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2)) + call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2)) +cd write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2), +cd & ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2) + enddo +C Matrices dependent on two consecutive virtual-bond dihedrals. +C The order of matrices is from left to right. + do i=2,nres-1 + call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i)) + call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i)) + call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i)) + call transpose2(DtUg2(1,1,i-1),auxmat(1,1)) + call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i)) + call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i)) + call transpose2(DtUg2der(1,1,i-1),auxmat(1,1)) + call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i)) + enddo +cd do i=1,nres +cd iti = itortyp(itype(i)) +cd write (iout,*) i +cd do j=1,2 +cd write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)') +cd & (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2) +cd enddo +cd enddo + return + end +C-------------------------------------------------------------------------- + subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4) +C +C This subroutine calculates the average interaction energy and its gradient +C in the virtual-bond vectors between non-adjacent peptide groups, based on +C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715. +C The potential depends both on the distance of peptide-group centers and on +C the orientation of the CA-CA virtual bonds. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.CONTROL' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VECTORS' + include 'COMMON.FFIELD' + dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3), + & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3) + double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4), + & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4) + common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1 +c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions + double precision scal_el /0.5d0/ +C 12/13/98 +C 13-go grudnia roku pamietnego... + double precision unmat(3,3) /1.0d0,0.0d0,0.0d0, + & 0.0d0,1.0d0,0.0d0, + & 0.0d0,0.0d0,1.0d0/ +cd write(iout,*) 'In EELEC' +cd do i=1,nloctyp +cd write(iout,*) 'Type',i +cd write(iout,*) 'B1',B1(:,i) +cd write(iout,*) 'B2',B2(:,i) +cd write(iout,*) 'CC',CC(:,:,i) +cd write(iout,*) 'DD',DD(:,:,i) +cd write(iout,*) 'EE',EE(:,:,i) +cd enddo +cd call check_vecgrad +cd stop + if (icheckgrad.eq.1) then + do i=1,nres-1 + fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i))) + do k=1,3 + dc_norm(k,i)=dc(k,i)*fac + enddo +c write (iout,*) 'i',i,' fac',fac + enddo + endif + if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 + & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. + & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then +cd if (wel_loc.gt.0.0d0) then + if (icheckgrad.eq.1) then + call vec_and_deriv_test + else + call vec_and_deriv + endif + call set_matrices + endif +cd do i=1,nres-1 +cd write (iout,*) 'i=',i +cd do k=1,3 +cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i) +cd enddo +cd do k=1,3 +cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)') +cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3) +cd enddo +cd enddo + num_conti_hb=0 + ees=0.0D0 + evdw1=0.0D0 + eel_loc=0.0d0 + eello_turn3=0.0d0 + eello_turn4=0.0d0 + ind=0 + do i=1,nres + num_cont_hb(i)=0 + enddo +cd print '(a)','Enter EELEC' +cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e + do i=1,nres + gel_loc_loc(i)=0.0d0 + gcorr_loc(i)=0.0d0 + enddo + do i=iatel_s,iatel_e + if (itel(i).eq.0) goto 1215 + dxi=dc(1,i) + dyi=dc(2,i) + dzi=dc(3,i) + dx_normi=dc_norm(1,i) + dy_normi=dc_norm(2,i) + dz_normi=dc_norm(3,i) + xmedi=c(1,i)+0.5d0*dxi + ymedi=c(2,i)+0.5d0*dyi + zmedi=c(3,i)+0.5d0*dzi + num_conti=0 +c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i) + do j=ielstart(i),ielend(i) + if (itel(j).eq.0) goto 1216 + ind=ind+1 + iteli=itel(i) + itelj=itel(j) + if (j.eq.i+2 .and. itelj.eq.2) iteli=2 + aaa=app(iteli,itelj) + bbb=bpp(iteli,itelj) +C Diagnostics only!!! +c aaa=0.0D0 +c bbb=0.0D0 +c ael6i=0.0D0 +c ael3i=0.0D0 +C End diagnostics + ael6i=ael6(iteli,itelj) + ael3i=ael3(iteli,itelj) + dxj=dc(1,j) + dyj=dc(2,j) + dzj=dc(3,j) + dx_normj=dc_norm(1,j) + dy_normj=dc_norm(2,j) + dz_normj=dc_norm(3,j) + xj=c(1,j)+0.5D0*dxj-xmedi + yj=c(2,j)+0.5D0*dyj-ymedi + zj=c(3,j)+0.5D0*dzj-zmedi + rij=xj*xj+yj*yj+zj*zj + rrmij=1.0D0/rij + rij=dsqrt(rij) + rmij=1.0D0/rij + r3ij=rrmij*rmij + r6ij=r3ij*r3ij + cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj + cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij + cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij + fac=cosa-3.0D0*cosb*cosg + ev1=aaa*r6ij*r6ij +c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions + if (j.eq.i+2) ev1=scal_el*ev1 + ev2=bbb*r6ij + fac3=ael6i*r6ij + fac4=ael3i*r3ij + evdwij=ev1+ev2 + el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)) + el2=fac4*fac + eesij=el1+el2 +c write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij +C 12/26/95 - for the evaluation of multi-body H-bonding interactions + ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg) + ees=ees+eesij + evdw1=evdw1+evdwij +cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)') +cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i, +cd & 1.0D0/dsqrt(rrmij),evdwij,eesij, +cd & xmedi,ymedi,zmedi,xj,yj,zj +C +C Calculate contributions to the Cartesian gradient. +C +#ifdef SPLITELE + facvdw=-6*rrmij*(ev1+evdwij) + facel=-3*rrmij*(el1+eesij) + fac1=fac + erij(1)=xj*rmij + erij(2)=yj*rmij + erij(3)=zj*rmij + if (calc_grad) then +* +* Radial derivatives. First process both termini of the fragment (i,j) +* + ggg(1)=facel*xj + ggg(2)=facel*yj + ggg(3)=facel*zj + do k=1,3 + ghalf=0.5D0*ggg(k) + gelc(k,i)=gelc(k,i)+ghalf + gelc(k,j)=gelc(k,j)+ghalf + enddo +* +* Loop over residues i+1 thru j-1. +* + do k=i+1,j-1 + do l=1,3 + gelc(l,k)=gelc(l,k)+ggg(l) + enddo + enddo + ggg(1)=facvdw*xj + ggg(2)=facvdw*yj + ggg(3)=facvdw*zj + do k=1,3 + ghalf=0.5D0*ggg(k) + gvdwpp(k,i)=gvdwpp(k,i)+ghalf + gvdwpp(k,j)=gvdwpp(k,j)+ghalf + enddo +* +* Loop over residues i+1 thru j-1. +* + do k=i+1,j-1 + do l=1,3 + gvdwpp(l,k)=gvdwpp(l,k)+ggg(l) + enddo + enddo +#else + facvdw=ev1+evdwij + facel=el1+eesij + fac1=fac + fac=-3*rrmij*(facvdw+facvdw+facel) + erij(1)=xj*rmij + erij(2)=yj*rmij + erij(3)=zj*rmij + if (calc_grad) then +* +* Radial derivatives. First process both termini of the fragment (i,j) +* + ggg(1)=fac*xj + ggg(2)=fac*yj + ggg(3)=fac*zj + do k=1,3 + ghalf=0.5D0*ggg(k) + gelc(k,i)=gelc(k,i)+ghalf + gelc(k,j)=gelc(k,j)+ghalf + enddo +* +* Loop over residues i+1 thru j-1. +* + do k=i+1,j-1 + do l=1,3 + gelc(l,k)=gelc(l,k)+ggg(l) + enddo + enddo +#endif +* +* Angular part +* + ecosa=2.0D0*fac3*fac1+fac4 + fac4=-3.0D0*fac4 + fac3=-6.0D0*fac3 + ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4) + ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4) + do k=1,3 + dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb) + dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg) + enddo +cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3), +cd & (dcosg(k),k=1,3) + do k=1,3 + ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k) + enddo + do k=1,3 + ghalf=0.5D0*ggg(k) + gelc(k,i)=gelc(k,i)+ghalf + & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) + & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) + gelc(k,j)=gelc(k,j)+ghalf + & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) + & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) + enddo + do k=i+1,j-1 + do l=1,3 + gelc(l,k)=gelc(l,k)+ggg(l) + enddo + enddo + endif + + IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 + & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 + & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN +C +C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction +C energy of a peptide unit is assumed in the form of a second-order +C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al. +C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms +C are computed for EVERY pair of non-contiguous peptide groups. +C + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + kkk=0 + do k=1,2 + do l=1,2 + kkk=kkk+1 + muij(kkk)=mu(k,i)*mu(l,j) + enddo + enddo +cd write (iout,*) 'EELEC: i',i,' j',j +cd write (iout,*) 'j',j,' j1',j1,' j2',j2 +cd write(iout,*) 'muij',muij + ury=scalar(uy(1,i),erij) + urz=scalar(uz(1,i),erij) + vry=scalar(uy(1,j),erij) + vrz=scalar(uz(1,j),erij) + a22=scalar(uy(1,i),uy(1,j))-3*ury*vry + a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz + a32=scalar(uz(1,i),uy(1,j))-3*urz*vry + a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz +C For diagnostics only +cd a22=1.0d0 +cd a23=1.0d0 +cd a32=1.0d0 +cd a33=1.0d0 + fac=dsqrt(-ael6i)*r3ij +cd write (2,*) 'fac=',fac +C For diagnostics only +cd fac=1.0d0 + a22=a22*fac + a23=a23*fac + a32=a32*fac + a33=a33*fac +cd write (iout,'(4i5,4f10.5)') +cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33 +cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij +cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3), +cd & (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3) +cd write (iout,'(4f10.5)') +cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)), +cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j)) +cd write (iout,'(4f10.5)') ury,urz,vry,vrz +cd write (iout,'(2i3,9f10.5/)') i,j, +cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij + if (calc_grad) then +C Derivatives of the elements of A in virtual-bond vectors + call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1)) +cd do k=1,3 +cd do l=1,3 +cd erder(k,l)=0.0d0 +cd enddo +cd enddo + do k=1,3 + uryg(k,1)=scalar(erder(1,k),uy(1,i)) + uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1)) + uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1)) + urzg(k,1)=scalar(erder(1,k),uz(1,i)) + urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1)) + urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1)) + vryg(k,1)=scalar(erder(1,k),uy(1,j)) + vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1)) + vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1)) + vrzg(k,1)=scalar(erder(1,k),uz(1,j)) + vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1)) + vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1)) + enddo +cd do k=1,3 +cd do l=1,3 +cd uryg(k,l)=0.0d0 +cd urzg(k,l)=0.0d0 +cd vryg(k,l)=0.0d0 +cd vrzg(k,l)=0.0d0 +cd enddo +cd enddo +C Compute radial contributions to the gradient + facr=-3.0d0*rrmij + a22der=a22*facr + a23der=a23*facr + a32der=a32*facr + a33der=a33*facr +cd a22der=0.0d0 +cd a23der=0.0d0 +cd a32der=0.0d0 +cd a33der=0.0d0 + agg(1,1)=a22der*xj + agg(2,1)=a22der*yj + agg(3,1)=a22der*zj + agg(1,2)=a23der*xj + agg(2,2)=a23der*yj + agg(3,2)=a23der*zj + agg(1,3)=a32der*xj + agg(2,3)=a32der*yj + agg(3,3)=a32der*zj + agg(1,4)=a33der*xj + agg(2,4)=a33der*yj + agg(3,4)=a33der*zj +C Add the contributions coming from er + fac3=-3.0d0*fac + do k=1,3 + agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury) + agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury) + agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz) + agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz) + enddo + do k=1,3 +C Derivatives in DC(i) + ghalf1=0.5d0*agg(k,1) + ghalf2=0.5d0*agg(k,2) + ghalf3=0.5d0*agg(k,3) + ghalf4=0.5d0*agg(k,4) + aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) + & -3.0d0*uryg(k,2)*vry)+ghalf1 + aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) + & -3.0d0*uryg(k,2)*vrz)+ghalf2 + aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) + & -3.0d0*urzg(k,2)*vry)+ghalf3 + aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) + & -3.0d0*urzg(k,2)*vrz)+ghalf4 +C Derivatives in DC(i+1) + aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) + & -3.0d0*uryg(k,3)*vry)+agg(k,1) + aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) + & -3.0d0*uryg(k,3)*vrz)+agg(k,2) + aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) + & -3.0d0*urzg(k,3)*vry)+agg(k,3) + aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) + & -3.0d0*urzg(k,3)*vrz)+agg(k,4) +C Derivatives in DC(j) + aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) + & -3.0d0*vryg(k,2)*ury)+ghalf1 + aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) + & -3.0d0*vrzg(k,2)*ury)+ghalf2 + aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) + & -3.0d0*vryg(k,2)*urz)+ghalf3 + aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) + & -3.0d0*vrzg(k,2)*urz)+ghalf4 +C Derivatives in DC(j+1) or DC(nres-1) + aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) + & -3.0d0*vryg(k,3)*ury) + aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) + & -3.0d0*vrzg(k,3)*ury) + aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) + & -3.0d0*vryg(k,3)*urz) + aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) + & -3.0d0*vrzg(k,3)*urz) +cd aggi(k,1)=ghalf1 +cd aggi(k,2)=ghalf2 +cd aggi(k,3)=ghalf3 +cd aggi(k,4)=ghalf4 +C Derivatives in DC(i+1) +cd aggi1(k,1)=agg(k,1) +cd aggi1(k,2)=agg(k,2) +cd aggi1(k,3)=agg(k,3) +cd aggi1(k,4)=agg(k,4) +C Derivatives in DC(j) +cd aggj(k,1)=ghalf1 +cd aggj(k,2)=ghalf2 +cd aggj(k,3)=ghalf3 +cd aggj(k,4)=ghalf4 +C Derivatives in DC(j+1) +cd aggj1(k,1)=0.0d0 +cd aggj1(k,2)=0.0d0 +cd aggj1(k,3)=0.0d0 +cd aggj1(k,4)=0.0d0 + if (j.eq.nres-1 .and. i.lt.j-2) then + do l=1,4 + aggj1(k,l)=aggj1(k,l)+agg(k,l) +cd aggj1(k,l)=agg(k,l) + enddo + endif + enddo + endif +c goto 11111 +C Check the loc-el terms by numerical integration + acipa(1,1)=a22 + acipa(1,2)=a23 + acipa(2,1)=a32 + acipa(2,2)=a33 + a22=-a22 + a23=-a23 + do l=1,2 + do k=1,3 + agg(k,l)=-agg(k,l) + aggi(k,l)=-aggi(k,l) + aggi1(k,l)=-aggi1(k,l) + aggj(k,l)=-aggj(k,l) + aggj1(k,l)=-aggj1(k,l) + enddo + enddo + if (j.lt.nres-1) then + a22=-a22 + a32=-a32 + do l=1,3,2 + do k=1,3 + agg(k,l)=-agg(k,l) + aggi(k,l)=-aggi(k,l) + aggi1(k,l)=-aggi1(k,l) + aggj(k,l)=-aggj(k,l) + aggj1(k,l)=-aggj1(k,l) + enddo + enddo + else + a22=-a22 + a23=-a23 + a32=-a32 + a33=-a33 + do l=1,4 + do k=1,3 + agg(k,l)=-agg(k,l) + aggi(k,l)=-aggi(k,l) + aggi1(k,l)=-aggi1(k,l) + aggj(k,l)=-aggj(k,l) + aggj1(k,l)=-aggj1(k,l) + enddo + enddo + endif + ENDIF ! WCORR +11111 continue + IF (wel_loc.gt.0.0d0) THEN +C Contribution to the local-electrostatic energy coming from the i-j pair + eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) + & +a33*muij(4) +cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij +cd write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) + eel_loc=eel_loc+eel_loc_ij +C Partial derivatives in virtual-bond dihedral angles gamma + if (calc_grad) then + if (i.gt.1) + & gel_loc_loc(i-1)=gel_loc_loc(i-1)+ + & a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) + & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j) + gel_loc_loc(j-1)=gel_loc_loc(j-1)+ + & a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) + & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j) +cd call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij) +cd write(iout,*) 'agg ',agg +cd write(iout,*) 'aggi ',aggi +cd write(iout,*) 'aggi1',aggi1 +cd write(iout,*) 'aggj ',aggj +cd write(iout,*) 'aggj1',aggj1 + +C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2) + do l=1,3 + ggg(l)=agg(l,1)*muij(1)+ + & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4) + enddo + do k=i+2,j2 + do l=1,3 + gel_loc(l,k)=gel_loc(l,k)+ggg(l) + enddo + enddo +C Remaining derivatives of eello + do l=1,3 + gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+ + & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4) + gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+ + & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4) + gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+ + & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4) + gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+ + & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4) + enddo + endif + ENDIF + if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then +C Contributions from turns + a_temp(1,1)=a22 + a_temp(1,2)=a23 + a_temp(2,1)=a32 + a_temp(2,2)=a33 + call eturn34(i,j,eello_turn3,eello_turn4) + endif +C Change 12/26/95 to calculate four-body contributions to H-bonding energy + if (j.gt.i+1 .and. num_conti.le.maxconts) then +C +C Calculate the contact function. The ith column of the array JCONT will +C contain the numbers of atoms that make contacts with the atom I (of numbers +C greater than I). The arrays FACONT and GACONT will contain the values of +C the contact function and its derivative. +c r0ij=1.02D0*rpp(iteli,itelj) +c r0ij=1.11D0*rpp(iteli,itelj) + r0ij=2.20D0*rpp(iteli,itelj) +c r0ij=1.55D0*rpp(iteli,itelj) + call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont) + if (fcont.gt.0.0D0) then + num_conti=num_conti+1 + if (num_conti.gt.maxconts) then + write (iout,*) 'WARNING - max. # of contacts exceeded;', + & ' will skip next contacts for this conf.' + else + jcont_hb(num_conti,i)=j + IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. + & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN +C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el +C terms. + d_cont(num_conti,i)=rij +cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij +C --- Electrostatic-interaction matrix --- + a_chuj(1,1,num_conti,i)=a22 + a_chuj(1,2,num_conti,i)=a23 + a_chuj(2,1,num_conti,i)=a32 + a_chuj(2,2,num_conti,i)=a33 +C --- Gradient of rij + do kkk=1,3 + grij_hb_cont(kkk,num_conti,i)=erij(kkk) + enddo +c if (i.eq.1) then +c a_chuj(1,1,num_conti,i)=-0.61d0 +c a_chuj(1,2,num_conti,i)= 0.4d0 +c a_chuj(2,1,num_conti,i)= 0.65d0 +c a_chuj(2,2,num_conti,i)= 0.50d0 +c else if (i.eq.2) then +c a_chuj(1,1,num_conti,i)= 0.0d0 +c a_chuj(1,2,num_conti,i)= 0.0d0 +c a_chuj(2,1,num_conti,i)= 0.0d0 +c a_chuj(2,2,num_conti,i)= 0.0d0 +c endif +C --- and its gradients +cd write (iout,*) 'i',i,' j',j +cd do kkk=1,3 +cd write (iout,*) 'iii 1 kkk',kkk +cd write (iout,*) agg(kkk,:) +cd enddo +cd do kkk=1,3 +cd write (iout,*) 'iii 2 kkk',kkk +cd write (iout,*) aggi(kkk,:) +cd enddo +cd do kkk=1,3 +cd write (iout,*) 'iii 3 kkk',kkk +cd write (iout,*) aggi1(kkk,:) +cd enddo +cd do kkk=1,3 +cd write (iout,*) 'iii 4 kkk',kkk +cd write (iout,*) aggj(kkk,:) +cd enddo +cd do kkk=1,3 +cd write (iout,*) 'iii 5 kkk',kkk +cd write (iout,*) aggj1(kkk,:) +cd enddo + kkll=0 + do k=1,2 + do l=1,2 + kkll=kkll+1 + do m=1,3 + a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll) + a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll) + a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll) + a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll) + a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll) +c do mm=1,5 +c a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0 +c enddo + enddo + enddo + enddo + ENDIF + IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN +C Calculate contact energies + cosa4=4.0D0*cosa + wij=cosa-3.0D0*cosb*cosg + cosbg1=cosb+cosg + cosbg2=cosb-cosg +c fac3=dsqrt(-ael6i)/r0ij**3 + fac3=dsqrt(-ael6i)*r3ij + ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1) + ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2) +c ees0mij=0.0D0 + ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) + ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) +C Diagnostics. Comment out or remove after debugging! +c ees0p(num_conti,i)=0.5D0*fac3*ees0pij +c ees0m(num_conti,i)=0.5D0*fac3*ees0mij +c ees0m(num_conti,i)=0.0D0 +C End diagnostics. +c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij, +c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont + facont_hb(num_conti,i)=fcont + if (calc_grad) then +C Angular derivatives of the contact function + ees0pij1=fac3/ees0pij + ees0mij1=fac3/ees0mij + fac3p=-3.0D0*fac3*rrmij + ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij) + ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij) +c ees0mij1=0.0D0 + ecosa1= ees0pij1*( 1.0D0+0.5D0*wij) + ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1) + ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1) + ecosa2= ees0mij1*(-1.0D0+0.5D0*wij) + ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2) + ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2) + ecosap=ecosa1+ecosa2 + ecosbp=ecosb1+ecosb2 + ecosgp=ecosg1+ecosg2 + ecosam=ecosa1-ecosa2 + ecosbm=ecosb1-ecosb2 + ecosgm=ecosg1-ecosg2 +C Diagnostics +c ecosap=ecosa1 +c ecosbp=ecosb1 +c ecosgp=ecosg1 +c ecosam=0.0D0 +c ecosbm=0.0D0 +c ecosgm=0.0D0 +C End diagnostics + fprimcont=fprimcont/rij +cd facont_hb(num_conti,i)=1.0D0 +C Following line is for diagnostics. +cd fprimcont=0.0D0 + do k=1,3 + dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb) + dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg) + enddo + do k=1,3 + gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k) + gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k) + enddo + gggp(1)=gggp(1)+ees0pijp*xj + gggp(2)=gggp(2)+ees0pijp*yj + gggp(3)=gggp(3)+ees0pijp*zj + gggm(1)=gggm(1)+ees0mijp*xj + gggm(2)=gggm(2)+ees0mijp*yj + gggm(3)=gggm(3)+ees0mijp*zj +C Derivatives due to the contact function + gacont_hbr(1,num_conti,i)=fprimcont*xj + gacont_hbr(2,num_conti,i)=fprimcont*yj + gacont_hbr(3,num_conti,i)=fprimcont*zj + do k=1,3 + ghalfp=0.5D0*gggp(k) + ghalfm=0.5D0*gggm(k) + gacontp_hb1(k,num_conti,i)=ghalfp + & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) + & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) + gacontp_hb2(k,num_conti,i)=ghalfp + & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) + & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) + gacontp_hb3(k,num_conti,i)=gggp(k) + gacontm_hb1(k,num_conti,i)=ghalfm + & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) + & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) + gacontm_hb2(k,num_conti,i)=ghalfm + & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) + & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) + gacontm_hb3(k,num_conti,i)=gggm(k) + enddo + endif +C Diagnostics. Comment out or remove after debugging! +cdiag do k=1,3 +cdiag gacontp_hb1(k,num_conti,i)=0.0D0 +cdiag gacontp_hb2(k,num_conti,i)=0.0D0 +cdiag gacontp_hb3(k,num_conti,i)=0.0D0 +cdiag gacontm_hb1(k,num_conti,i)=0.0D0 +cdiag gacontm_hb2(k,num_conti,i)=0.0D0 +cdiag gacontm_hb3(k,num_conti,i)=0.0D0 +cdiag enddo + ENDIF ! wcorr + endif ! num_conti.le.maxconts + endif ! fcont.gt.0 + endif ! j.gt.i+1 + 1216 continue + enddo ! j + num_cont_hb(i)=num_conti + 1215 continue + enddo ! i +cd do i=1,nres +cd write (iout,'(i3,3f10.5,5x,3f10.5)') +cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i) +cd enddo +c 12/7/99 Adam eello_turn3 will be considered as a separate energy term +ccc eel_loc=eel_loc+eello_turn3 + return + end +C----------------------------------------------------------------------------- + subroutine eturn34(i,j,eello_turn3,eello_turn4) +C Third- and fourth-order contributions from turns + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VECTORS' + include 'COMMON.FFIELD' + dimension ggg(3) + double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2), + & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2), + & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2) + double precision agg(3,4),aggi(3,4),aggi1(3,4), + & aggj(3,4),aggj1(3,4),a_temp(2,2) + common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2 + if (j.eq.i+2) then +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C Third-order contributions +C +C (i+2)o----(i+3) +C | | +C | | +C (i+1)o----i +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +cd call checkint_turn3(i,a_temp,eello_turn3_num) + call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1)) + call transpose2(auxmat(1,1),auxmat1(1,1)) + call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1)) + eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) +cd write (2,*) 'i,',i,' j',j,'eello_turn3', +cd & 0.5d0*(pizda(1,1)+pizda(2,2)), +cd & ' eello_turn3_num',4*eello_turn3_num + if (calc_grad) then +C Derivatives in gamma(i) + call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1)) + call transpose2(auxmat2(1,1),pizda(1,1)) + call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1)) + gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2)) +C Derivatives in gamma(i+1) + call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1)) + call transpose2(auxmat2(1,1),pizda(1,1)) + call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1)) + gel_loc_turn3(i+1)=gel_loc_turn3(i+1) + & +0.5d0*(pizda(1,1)+pizda(2,2)) +C Cartesian derivatives + do l=1,3 + a_temp(1,1)=aggi(l,1) + a_temp(1,2)=aggi(l,2) + a_temp(2,1)=aggi(l,3) + a_temp(2,2)=aggi(l,4) + call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1)) + gcorr3_turn(l,i)=gcorr3_turn(l,i) + & +0.5d0*(pizda(1,1)+pizda(2,2)) + a_temp(1,1)=aggi1(l,1) + a_temp(1,2)=aggi1(l,2) + a_temp(2,1)=aggi1(l,3) + a_temp(2,2)=aggi1(l,4) + call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1)) + gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) + & +0.5d0*(pizda(1,1)+pizda(2,2)) + a_temp(1,1)=aggj(l,1) + a_temp(1,2)=aggj(l,2) + a_temp(2,1)=aggj(l,3) + a_temp(2,2)=aggj(l,4) + call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1)) + gcorr3_turn(l,j)=gcorr3_turn(l,j) + & +0.5d0*(pizda(1,1)+pizda(2,2)) + a_temp(1,1)=aggj1(l,1) + a_temp(1,2)=aggj1(l,2) + a_temp(2,1)=aggj1(l,3) + a_temp(2,2)=aggj1(l,4) + call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1)) + gcorr3_turn(l,j1)=gcorr3_turn(l,j1) + & +0.5d0*(pizda(1,1)+pizda(2,2)) + enddo + endif + else if (j.eq.i+3) then +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C Fourth-order contributions +C +C (i+3)o----(i+4) +C / | +C (i+2)o | +C \ | +C (i+1)o----i +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +cd call checkint_turn4(i,a_temp,eello_turn4_num) + iti1=itortyp(itype(i+1)) + iti2=itortyp(itype(i+2)) + iti3=itortyp(itype(i+3)) + call transpose2(EUg(1,1,i+1),e1t(1,1)) + call transpose2(Eug(1,1,i+2),e2t(1,1)) + call transpose2(Eug(1,1,i+3),e3t(1,1)) + call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1)) + call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1)) + s1=scalar2(b1(1,iti2),auxvec(1)) + call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1)) + call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) + s2=scalar2(b1(1,iti1),auxvec(1)) + call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1)) + call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) + s3=0.5d0*(pizda(1,1)+pizda(2,2)) + eello_turn4=eello_turn4-(s1+s2+s3) +cd write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3), +cd & ' eello_turn4_num',8*eello_turn4_num +C Derivatives in gamma(i) + if (calc_grad) then + call transpose2(EUgder(1,1,i+1),e1tder(1,1)) + call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1)) + s1=scalar2(b1(1,iti2),auxvec(1)) + call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1)) + s3=0.5d0*(pizda(1,1)+pizda(2,2)) + gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) +C Derivatives in gamma(i+1) + call transpose2(EUgder(1,1,i+2),e2tder(1,1)) + call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1)) + s2=scalar2(b1(1,iti1),auxvec(1)) + call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1)) + call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1)) + s3=0.5d0*(pizda(1,1)+pizda(2,2)) + gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) +C Derivatives in gamma(i+2) + call transpose2(EUgder(1,1,i+3),e3tder(1,1)) + call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1)) + s1=scalar2(b1(1,iti2),auxvec(1)) + call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1)) + s2=scalar2(b1(1,iti1),auxvec(1)) + call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1)) + call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1)) + s3=0.5d0*(pizda(1,1)+pizda(2,2)) + gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) +C Cartesian derivatives +C Derivatives of this turn contributions in DC(i+2) + if (j.lt.nres-1) then + do l=1,3 + a_temp(1,1)=agg(l,1) + a_temp(1,2)=agg(l,2) + a_temp(2,1)=agg(l,3) + a_temp(2,2)=agg(l,4) + call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1)) + call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1)) + s1=scalar2(b1(1,iti2),auxvec(1)) + call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1)) + call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) + s2=scalar2(b1(1,iti1),auxvec(1)) + call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1)) + call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) + s3=0.5d0*(pizda(1,1)+pizda(2,2)) + ggg(l)=-(s1+s2+s3) + gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3) + enddo + endif +C Remaining derivatives of this turn contribution + do l=1,3 + a_temp(1,1)=aggi(l,1) + a_temp(1,2)=aggi(l,2) + a_temp(2,1)=aggi(l,3) + a_temp(2,2)=aggi(l,4) + call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1)) + call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1)) + s1=scalar2(b1(1,iti2),auxvec(1)) + call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1)) + call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) + s2=scalar2(b1(1,iti1),auxvec(1)) + call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1)) + call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) + s3=0.5d0*(pizda(1,1)+pizda(2,2)) + gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) + a_temp(1,1)=aggi1(l,1) + a_temp(1,2)=aggi1(l,2) + a_temp(2,1)=aggi1(l,3) + a_temp(2,2)=aggi1(l,4) + call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1)) + call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1)) + s1=scalar2(b1(1,iti2),auxvec(1)) + call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1)) + call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) + s2=scalar2(b1(1,iti1),auxvec(1)) + call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1)) + call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) + s3=0.5d0*(pizda(1,1)+pizda(2,2)) + gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) + a_temp(1,1)=aggj(l,1) + a_temp(1,2)=aggj(l,2) + a_temp(2,1)=aggj(l,3) + a_temp(2,2)=aggj(l,4) + call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1)) + call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1)) + s1=scalar2(b1(1,iti2),auxvec(1)) + call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1)) + call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) + s2=scalar2(b1(1,iti1),auxvec(1)) + call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1)) + call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) + s3=0.5d0*(pizda(1,1)+pizda(2,2)) + gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) + a_temp(1,1)=aggj1(l,1) + a_temp(1,2)=aggj1(l,2) + a_temp(2,1)=aggj1(l,3) + a_temp(2,2)=aggj1(l,4) + call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1)) + call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1)) + s1=scalar2(b1(1,iti2),auxvec(1)) + call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1)) + call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) + s2=scalar2(b1(1,iti1),auxvec(1)) + call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1)) + call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) + s3=0.5d0*(pizda(1,1)+pizda(2,2)) + gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) + enddo + endif + endif + return + end +C----------------------------------------------------------------------------- + subroutine vecpr(u,v,w) + implicit real*8(a-h,o-z) + dimension u(3),v(3),w(3) + w(1)=u(2)*v(3)-u(3)*v(2) + w(2)=-u(1)*v(3)+u(3)*v(1) + w(3)=u(1)*v(2)-u(2)*v(1) + return + end +C----------------------------------------------------------------------------- + subroutine unormderiv(u,ugrad,unorm,ungrad) +C This subroutine computes the derivatives of a normalized vector u, given +C the derivatives computed without normalization conditions, ugrad. Returns +C ungrad. + implicit none + double precision u(3),ugrad(3,3),unorm,ungrad(3,3) + double precision vec(3) + double precision scalar + integer i,j +c write (2,*) 'ugrad',ugrad +c write (2,*) 'u',u + do i=1,3 + vec(i)=scalar(ugrad(1,i),u(1)) + enddo +c write (2,*) 'vec',vec + do i=1,3 + do j=1,3 + ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm + enddo + enddo +c write (2,*) 'ungrad',ungrad + return + end +C----------------------------------------------------------------------------- + subroutine escp(evdw2,evdw2_14) +C +C This subroutine calculates the excluded-volume interaction energy between +C peptide-group centers and side chains and its gradient in virtual-bond and +C side-chain vectors. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.IOUNITS' + dimension ggg(3) + evdw2=0.0D0 + evdw2_14=0.0d0 +cd print '(a)','Enter ESCP' +c write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e, +c & ' scal14',scal14 + do i=iatscp_s,iatscp_e + iteli=itel(i) +c write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i), +c & " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i)) + if (iteli.eq.0) goto 1225 + xi=0.5D0*(c(1,i)+c(1,i+1)) + yi=0.5D0*(c(2,i)+c(2,i+1)) + zi=0.5D0*(c(3,i)+c(3,i+1)) + + do iint=1,nscp_gr(i) + + do j=iscpstart(i,iint),iscpend(i,iint) + itypj=itype(j) +C Uncomment following three lines for SC-p interactions +c xj=c(1,nres+j)-xi +c yj=c(2,nres+j)-yi +c zj=c(3,nres+j)-zi +C Uncomment following three lines for Ca-p interactions + xj=c(1,j)-xi + yj=c(2,j)-yi + zj=c(3,j)-zi + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + fac=rrij**expon2 + e1=fac*fac*aad(itypj,iteli) + e2=fac*bad(itypj,iteli) + if (iabs(j-i) .le. 2) then + e1=scal14*e1 + e2=scal14*e2 + evdw2_14=evdw2_14+e1+e2 + endif + evdwij=e1+e2 +c write (iout,*) i,j,evdwij + evdw2=evdw2+evdwij + if (calc_grad) then +C +C Calculate contributions to the gradient in the virtual-bond and SC vectors. +C + fac=-(evdwij+e1)*rrij + ggg(1)=xj*fac + ggg(2)=yj*fac + ggg(3)=zj*fac + if (j.lt.i) then +cd write (iout,*) 'ji' + do k=1,3 + ggg(k)=-ggg(k) +C Uncomment following line for SC-p interactions +c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) + enddo + endif + do k=1,3 + gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) + enddo + kstart=min0(i+1,j) + kend=max0(i-1,j-1) +cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend +cd write (iout,*) ggg(1),ggg(2),ggg(3) + do k=kstart,kend + do l=1,3 + gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) + enddo + enddo + endif + enddo + enddo ! iint + 1225 continue + enddo ! i + do i=1,nct + do j=1,3 + gvdwc_scp(j,i)=expon*gvdwc_scp(j,i) + gradx_scp(j,i)=expon*gradx_scp(j,i) + enddo + enddo +C****************************************************************************** +C +C N O T E !!! +C +C To save time the factor EXPON has been extracted from ALL components +C of GVDWC and GRADX. Remember to multiply them by this factor before further +C use! +C +C****************************************************************************** + return + end +C-------------------------------------------------------------------------- + subroutine edis(ehpb) +C +C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + dimension ggg(3) + ehpb=0.0D0 +cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr +cd write(iout,*)'link_start=',link_start,' link_end=',link_end + if (link_end.eq.0) return + do i=link_start,link_end +C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a +C CA-CA distance used in regularization of structure. + ii=ihpb(i) + jj=jhpb(i) +C iii and jjj point to the residues for which the distance is assigned. + if (ii.gt.nres) then + iii=ii-nres + jjj=jj-nres + else + iii=ii + jjj=jj + endif +c write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj, +c & dhpb(i),dhpb1(i),forcon(i) +C 24/11/03 AL: SS bridges handled separately because of introducing a specific +C distance and angle dependent SS bond potential. + if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then + call ssbond_ene(iii,jjj,eij) + ehpb=ehpb+2*eij +cd write (iout,*) "eij",eij + else if (ii.gt.nres .and. jj.gt.nres) then +c Restraints from contact prediction + dd=dist(ii,jj) + if (dhpb1(i).gt.0.0d0) then + ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) + fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd +c write (iout,*) "beta nmr", +c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) + else + dd=dist(ii,jj) + rdis=dd-dhpb(i) +C Get the force constant corresponding to this distance. + waga=forcon(i) +C Calculate the contribution to energy. + ehpb=ehpb+waga*rdis*rdis +c write (iout,*) "beta reg",dd,waga*rdis*rdis +C +C Evaluate gradient. +C + fac=waga*rdis/dd + endif + do j=1,3 + ggg(j)=fac*(c(j,jj)-c(j,ii)) + enddo + do j=1,3 + ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) + ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) + enddo + do k=1,3 + ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k) + ghpbc(k,iii)=ghpbc(k,iii)-ggg(k) + enddo + else +C Calculate the distance between the two points and its difference from the +C target distance. + dd=dist(ii,jj) + if (dhpb1(i).gt.0.0d0) then + ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) + fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd +c write (iout,*) "alph nmr", +c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) + else + rdis=dd-dhpb(i) +C Get the force constant corresponding to this distance. + waga=forcon(i) +C Calculate the contribution to energy. + ehpb=ehpb+waga*rdis*rdis +c write (iout,*) "alpha reg",dd,waga*rdis*rdis +C +C Evaluate gradient. +C + fac=waga*rdis/dd + endif +cd print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd, +cd & ' waga=',waga,' fac=',fac + do j=1,3 + ggg(j)=fac*(c(j,jj)-c(j,ii)) + enddo +cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3) +C If this is a SC-SC distance, we need to calculate the contributions to the +C Cartesian gradient in the SC vectors (ghpbx). + if (iii.lt.ii) then + do j=1,3 + ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) + ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) + enddo + endif + do k=1,3 + ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k) + ghpbc(k,iii)=ghpbc(k,iii)-ggg(k) + enddo + endif + enddo + ehpb=0.5D0*ehpb + return + end +C-------------------------------------------------------------------------- + subroutine ssbond_ene(i,j,eij) +C +C Calculate the distance and angle dependent SS-bond potential energy +C using a free-energy function derived based on RHF/6-31G** ab initio +C calculations of diethyl disulfide. +C +C A. Liwo and U. Kozlowska, 11/24/03 +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + double precision erij(3),dcosom1(3),dcosom2(3),gg(3) + itypi=itype(i) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) + dxi=dc_norm(1,nres+i) + dyi=dc_norm(2,nres+i) + dzi=dc_norm(3,nres+i) + dsci_inv=dsc_inv(itypi) + itypj=itype(j) + dscj_inv=dsc_inv(itypj) + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + rij=dsqrt(rrij) + erij(1)=xj*rij + erij(2)=yj*rij + erij(3)=zj*rij + om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) + om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) + om12=dxi*dxj+dyi*dyj+dzi*dzj + do k=1,3 + dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) + dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k)) + enddo + rij=1.0d0/rij + deltad=rij-d0cm + deltat1=1.0d0-om1 + deltat2=1.0d0+om2 + deltat12=om2-om1+2.0d0 + cosphi=om12-om1*om2 + eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) + & +akct*deltad*deltat12 + & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi +c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth, +c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2, +c & " deltat12",deltat12," eij",eij + ed=2*akcm*deltad+akct*deltat12 + pom1=akct*deltad + pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi + eom1=-2*akth*deltat1-pom1-om2*pom2 + eom2= 2*akth*deltat2+pom1-om1*pom2 + eom12=pom2 + do k=1,3 + gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k) + enddo + do k=1,3 + ghpbx(k,i)=ghpbx(k,i)-gg(k) + & +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv + ghpbx(k,j)=ghpbx(k,j)+gg(k) + & +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv + enddo +C +C Calculate the components of the gradient in DC and X +C + do k=i,j-1 + do l=1,3 + ghpbc(l,k)=ghpbc(l,k)+gg(l) + enddo + enddo + return + end +C-------------------------------------------------------------------------- + subroutine ebond(estr) +c +c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds +c + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + double precision u(3),ud(3) + estr=0.0d0 + do i=nnt+1,nct + diff = vbld(i)-vbldp0 +c write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff + estr=estr+diff*diff + do j=1,3 + gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i) + enddo + enddo + estr=0.5d0*AKP*estr +c +c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included +c + do i=nnt,nct + iti=itype(i) + if (iti.ne.10) then + nbi=nbondterm(iti) + if (nbi.eq.1) then + diff=vbld(i+nres)-vbldsc0(1,iti) +c write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff, +c & AKSC(1,iti),AKSC(1,iti)*diff*diff + estr=estr+0.5d0*AKSC(1,iti)*diff*diff + do j=1,3 + gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres) + enddo + else + do j=1,nbi + diff=vbld(i+nres)-vbldsc0(j,iti) + ud(j)=aksc(j,iti)*diff + u(j)=abond0(j,iti)+0.5d0*ud(j)*diff + enddo + uprod=u(1) + do j=2,nbi + uprod=uprod*u(j) + enddo + usum=0.0d0 + usumsqder=0.0d0 + do j=1,nbi + uprod1=1.0d0 + uprod2=1.0d0 + do k=1,nbi + if (k.ne.j) then + uprod1=uprod1*u(k) + uprod2=uprod2*u(k)*u(k) + endif + enddo + usum=usum+uprod1 + usumsqder=usumsqder+ud(j)*uprod2 + enddo +c write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti), +c & AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi) + estr=estr+uprod/usum + do j=1,3 + gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres) + enddo + endif + endif + enddo + return + end +#ifdef CRYST_THETA +C-------------------------------------------------------------------------- + subroutine ebend(etheta) +C +C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral +C angles gamma and its derivatives in consecutive thetas and gammas. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + common /calcthet/ term1,term2,termm,diffak,ratak, + & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, + & delthe0,sig0inv,sigtc,sigsqtc,delthec,it + double precision y(2),z(2) + delta=0.02d0*pi + time11=dexp(-2*time) + time12=1.0d0 + etheta=0.0D0 +c write (iout,*) "nres",nres +c write (*,'(a,i2)') 'EBEND ICG=',icg +c write (iout,*) ithet_start,ithet_end + do i=ithet_start,ithet_end +C Zero the energy function and its derivative at 0 or pi. + call splinthet(theta(i),0.5d0*delta,ss,ssd) + it=itype(i-1) +c if (i.gt.ithet_start .and. +c & (itel(i-1).eq.0 .or. itel(i-2).eq.0)) goto 1215 +c if (i.gt.3 .and. (i.le.4 .or. itel(i-3).ne.0)) then +c phii=phi(i) +c y(1)=dcos(phii) +c y(2)=dsin(phii) +c else +c y(1)=0.0D0 +c y(2)=0.0D0 +c endif +c if (i.lt.nres .and. itel(i).ne.0) then +c phii1=phi(i+1) +c z(1)=dcos(phii1) +c z(2)=dsin(phii1) +c else +c z(1)=0.0D0 +c z(2)=0.0D0 +c endif + if (i.gt.3) then +#ifdef OSF + phii=phi(i) + icrc=0 + call proc_proc(phii,icrc) + if (icrc.eq.1) phii=150.0 +#else + phii=phi(i) +#endif + y(1)=dcos(phii) + y(2)=dsin(phii) + else + y(1)=0.0D0 + y(2)=0.0D0 + endif + if (i.lt.nres) then +#ifdef OSF + phii1=phi(i+1) + icrc=0 + call proc_proc(phii1,icrc) + if (icrc.eq.1) phii1=150.0 + phii1=pinorm(phii1) + z(1)=cos(phii1) +#else + phii1=phi(i+1) + z(1)=dcos(phii1) +#endif + z(2)=dsin(phii1) + else + z(1)=0.0D0 + z(2)=0.0D0 + endif +C Calculate the "mean" value of theta from the part of the distribution +C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2). +C In following comments this theta will be referred to as t_c. + thet_pred_mean=0.0d0 + do k=1,2 + athetk=athet(k,it) + bthetk=bthet(k,it) + thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k) + enddo +c write (iout,*) "thet_pred_mean",thet_pred_mean + dthett=thet_pred_mean*ssd + thet_pred_mean=thet_pred_mean*ss+a0thet(it) +c write (iout,*) "thet_pred_mean",thet_pred_mean +C Derivatives of the "mean" values in gamma1 and gamma2. + dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss + dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss + if (theta(i).gt.pi-delta) then + call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0, + & E_tc0) + call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0) + call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1) + call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai, + & E_theta) + call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0, + & E_tc) + else if (theta(i).lt.delta) then + call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0) + call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1) + call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai, + & E_theta) + call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0) + call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0, + & E_tc) + else + call theteng(theta(i),thet_pred_mean,theta0(it),ethetai, + & E_theta,E_tc) + endif + etheta=etheta+ethetai +c write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i), +c & rad2deg*phii,rad2deg*phii1,ethetai + if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1 + if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2 + gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett) + 1215 continue + enddo +C Ufff.... We've done all this!!! + return + end +C--------------------------------------------------------------------------- + subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta, + & E_tc) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /calcthet/ term1,term2,termm,diffak,ratak, + & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, + & delthe0,sig0inv,sigtc,sigsqtc,delthec,it +C Calculate the contributions to both Gaussian lobes. +C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time) +C The "polynomial part" of the "standard deviation" of this part of +C the distribution. + sig=polthet(3,it) + do j=2,0,-1 + sig=sig*thet_pred_mean+polthet(j,it) + enddo +C Derivative of the "interior part" of the "standard deviation of the" +C gamma-dependent Gaussian lobe in t_c. + sigtc=3*polthet(3,it) + do j=2,1,-1 + sigtc=sigtc*thet_pred_mean+j*polthet(j,it) + enddo + sigtc=sig*sigtc +C Set the parameters of both Gaussian lobes of the distribution. +C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc) + fac=sig*sig+sigc0(it) + sigcsq=fac+fac + sigc=1.0D0/sigcsq +C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c + sigsqtc=-4.0D0*sigcsq*sigtc +c print *,i,sig,sigtc,sigsqtc +C Following variable (sigtc) is d[sigma(t_c)]/dt_c + sigtc=-sigtc/(fac*fac) +C Following variable is sigma(t_c)**(-2) + sigcsq=sigcsq*sigcsq + sig0i=sig0(it) + sig0inv=1.0D0/sig0i**2 + delthec=thetai-thet_pred_mean + delthe0=thetai-theta0i + term1=-0.5D0*sigcsq*delthec*delthec + term2=-0.5D0*sig0inv*delthe0*delthe0 +C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and +C NaNs in taking the logarithm. We extract the largest exponent which is added +C to the energy (this being the log of the distribution) at the end of energy +C term evaluation for this virtual-bond angle. + if (term1.gt.term2) then + termm=term1 + term2=dexp(term2-termm) + term1=1.0d0 + else + termm=term2 + term1=dexp(term1-termm) + term2=1.0d0 + endif +C The ratio between the gamma-independent and gamma-dependent lobes of +C the distribution is a Gaussian function of thet_pred_mean too. + diffak=gthet(2,it)-thet_pred_mean + ratak=diffak/gthet(3,it)**2 + ak=dexp(gthet(1,it)-0.5D0*diffak*ratak) +C Let's differentiate it in thet_pred_mean NOW. + aktc=ak*ratak +C Now put together the distribution terms to make complete distribution. + termexp=term1+ak*term2 + termpre=sigc+ak*sig0i +C Contribution of the bending energy from this theta is just the -log of +C the sum of the contributions from the two lobes and the pre-exponential +C factor. Simple enough, isn't it? + ethetai=(-dlog(termexp)-termm+dlog(termpre)) +C NOW the derivatives!!! +C 6/6/97 Take into account the deformation. + E_theta=(delthec*sigcsq*term1 + & +ak*delthe0*sig0inv*term2)/termexp + E_tc=((sigtc+aktc*sig0i)/termpre + & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ + & aktc*term2)/termexp) + return + end +c----------------------------------------------------------------------------- + subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /calcthet/ term1,term2,termm,diffak,ratak, + & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, + & delthe0,sig0inv,sigtc,sigsqtc,delthec,it + delthec=thetai-thet_pred_mean + delthe0=thetai-theta0i +C "Thank you" to MAPLE (probably spared one day of hand-differentiation). + t3 = thetai-thet_pred_mean + t6 = t3**2 + t9 = term1 + t12 = t3*sigcsq + t14 = t12+t6*sigsqtc + t16 = 1.0d0 + t21 = thetai-theta0i + t23 = t21**2 + t26 = term2 + t27 = t21*t26 + t32 = termexp + t40 = t32**2 + E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 + & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 + & *(-t12*t9-ak*sig0inv*t27) + return + end +#else +C-------------------------------------------------------------------------- + subroutine ebend(etheta) +C +C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral +C angles gamma and its derivatives in consecutive thetas and gammas. +C ab initio-derived potentials from +c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203 +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + double precision coskt(mmaxtheterm),sinkt(mmaxtheterm), + & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle), + & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble), + & sinph1ph2(maxdouble,maxdouble) + logical lprn /.false./, lprn1 /.false./ + etheta=0.0D0 +c write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1) + do i=ithet_start,ithet_end + dethetai=0.0d0 + dephii=0.0d0 + dephii1=0.0d0 + theti2=0.5d0*theta(i) + ityp2=ithetyp(itype(i-1)) + do k=1,nntheterm + coskt(k)=dcos(k*theti2) + sinkt(k)=dsin(k*theti2) + enddo + if (i.gt.3) then +#ifdef OSF + phii=phi(i) + if (phii.ne.phii) phii=150.0 +#else + phii=phi(i) +#endif + ityp1=ithetyp(itype(i-2)) + do k=1,nsingle + cosph1(k)=dcos(k*phii) + sinph1(k)=dsin(k*phii) + enddo + else + phii=0.0d0 + ityp1=nthetyp+1 + do k=1,nsingle + cosph1(k)=0.0d0 + sinph1(k)=0.0d0 + enddo + endif + if (i.lt.nres) then +#ifdef OSF + phii1=phi(i+1) + if (phii1.ne.phii1) phii1=150.0 + phii1=pinorm(phii1) +#else + phii1=phi(i+1) +#endif + ityp3=ithetyp(itype(i)) + do k=1,nsingle + cosph2(k)=dcos(k*phii1) + sinph2(k)=dsin(k*phii1) + enddo + else + phii1=0.0d0 + ityp3=nthetyp+1 + do k=1,nsingle + cosph2(k)=0.0d0 + sinph2(k)=0.0d0 + enddo + endif +c write (iout,*) "i",i," ityp1",itype(i-2),ityp1, +c & " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3 +c call flush(iout) + ethetai=aa0thet(ityp1,ityp2,ityp3) + do k=1,ndouble + do l=1,k-1 + ccl=cosph1(l)*cosph2(k-l) + ssl=sinph1(l)*sinph2(k-l) + scl=sinph1(l)*cosph2(k-l) + csl=cosph1(l)*sinph2(k-l) + cosph1ph2(l,k)=ccl-ssl + cosph1ph2(k,l)=ccl+ssl + sinph1ph2(l,k)=scl+csl + sinph1ph2(k,l)=scl-csl + enddo + enddo + if (lprn) then + write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2, + & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1 + write (iout,*) "coskt and sinkt" + do k=1,nntheterm + write (iout,*) k,coskt(k),sinkt(k) + enddo + endif + do k=1,ntheterm + ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k) + dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3) + & *coskt(k) + if (lprn) + & write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3), + & " ethetai",ethetai + enddo + if (lprn) then + write (iout,*) "cosph and sinph" + do k=1,nsingle + write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k) + enddo + write (iout,*) "cosph1ph2 and sinph2ph2" + do k=2,ndouble + do l=1,k-1 + write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l), + & sinph1ph2(l,k),sinph1ph2(k,l) + enddo + enddo + write(iout,*) "ethetai",ethetai + endif + do m=1,ntheterm2 + do k=1,nsingle + aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k) + & +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k) + & +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k) + & +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k) + ethetai=ethetai+sinkt(m)*aux + dethetai=dethetai+0.5d0*m*aux*coskt(m) + dephii=dephii+k*sinkt(m)*( + & ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)- + & bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)) + dephii1=dephii1+k*sinkt(m)*( + & eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)- + & ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k)) + if (lprn) + & write (iout,*) "m",m," k",k," bbthet", + & bbthet(k,m,ityp1,ityp2,ityp3)," ccthet", + & ccthet(k,m,ityp1,ityp2,ityp3)," ddthet", + & ddthet(k,m,ityp1,ityp2,ityp3)," eethet", + & eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai + enddo + enddo + if (lprn) + & write(iout,*) "ethetai",ethetai + do m=1,ntheterm3 + do k=2,ndouble + do l=1,k-1 + aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+ + & ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+ + & ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+ + & ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l) + ethetai=ethetai+sinkt(m)*aux + dethetai=dethetai+0.5d0*m*coskt(m)*aux + dephii=dephii+l*sinkt(m)*( + & -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)- + & ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+ + & ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+ + & ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)) + dephii1=dephii1+(k-l)*sinkt(m)*( + & -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+ + & ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+ + & ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)- + & ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)) + if (lprn) then + write (iout,*) "m",m," k",k," l",l," ffthet", + & ffthet(l,k,m,ityp1,ityp2,ityp3), + & ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet", + & ggthet(l,k,m,ityp1,ityp2,ityp3), + & ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai + write (iout,*) cosph1ph2(l,k)*sinkt(m), + & cosph1ph2(k,l)*sinkt(m), + & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m) + endif + enddo + enddo + enddo +10 continue + if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') + & i,theta(i)*rad2deg,phii*rad2deg, + & phii1*rad2deg,ethetai + etheta=etheta+ethetai + if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii + if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1 + gloc(nphi+i-2,icg)=wang*dethetai + enddo + return + end +#endif +#ifdef CRYST_SC +c----------------------------------------------------------------------------- + subroutine esc(escloc) +C Calculate the local energy of a side chain and its derivatives in the +C corresponding virtual-bond valence angles THETA and the spherical angles +C ALPHA and OMEGA. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3), + & ddersc0(3),ddummy(3),xtemp(3),temp(3) + common /sccalc/ time11,time12,time112,theti,it,nlobit + delta=0.02d0*pi + escloc=0.0D0 +c write (iout,'(a)') 'ESC' + do i=loc_start,loc_end + it=itype(i) + if (it.eq.10) goto 1 + nlobit=nlob(it) +c print *,'i=',i,' it=',it,' nlobit=',nlobit +c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad + theti=theta(i+1)-pipol + x(1)=dtan(theti) + x(2)=alph(i) + x(3)=omeg(i) +c write (iout,*) "i",i," x",x(1),x(2),x(3) + + if (x(2).gt.pi-delta) then + xtemp(1)=x(1) + xtemp(2)=pi-delta + xtemp(3)=x(3) + call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) + xtemp(2)=pi + call enesc(xtemp,escloci1,dersc1,ddummy,.false.) + call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2), + & escloci,dersc(2)) + call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), + & ddersc0(1),dersc(1)) + call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3), + & ddersc0(3),dersc(3)) + xtemp(2)=pi-delta + call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) + xtemp(2)=pi + call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) + call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1, + & dersc0(2),esclocbi,dersc02) + call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), + & dersc12,dersc01) + call splinthet(x(2),0.5d0*delta,ss,ssd) + dersc0(1)=dersc01 + dersc0(2)=dersc02 + dersc0(3)=0.0d0 + do k=1,3 + dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) + enddo + dersc(2)=dersc(2)+ssd*(escloci-esclocbi) +c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, +c & esclocbi,ss,ssd + escloci=ss*escloci+(1.0d0-ss)*esclocbi +c escloci=esclocbi +c write (iout,*) escloci + else if (x(2).lt.delta) then + xtemp(1)=x(1) + xtemp(2)=delta + xtemp(3)=x(3) + call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) + xtemp(2)=0.0d0 + call enesc(xtemp,escloci1,dersc1,ddummy,.false.) + call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2), + & escloci,dersc(2)) + call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), + & ddersc0(1),dersc(1)) + call spline2(x(2),delta,-delta,dersc0(3),dersc1(3), + & ddersc0(3),dersc(3)) + xtemp(2)=delta + call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) + xtemp(2)=0.0d0 + call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) + call spline1(x(2),delta,-delta,esclocbi0,esclocbi1, + & dersc0(2),esclocbi,dersc02) + call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), + & dersc12,dersc01) + dersc0(1)=dersc01 + dersc0(2)=dersc02 + dersc0(3)=0.0d0 + call splinthet(x(2),0.5d0*delta,ss,ssd) + do k=1,3 + dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) + enddo + dersc(2)=dersc(2)+ssd*(escloci-esclocbi) +c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, +c & esclocbi,ss,ssd + escloci=ss*escloci+(1.0d0-ss)*esclocbi +c write (iout,*) escloci + else + call enesc(x,escloci,dersc,ddummy,.false.) + endif + + escloc=escloc+escloci +c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc + + gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ + & wscloc*dersc(1) + gloc(ialph(i,1),icg)=wscloc*dersc(2) + gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3) + 1 continue + enddo + return + end +C--------------------------------------------------------------------------- + subroutine enesc(x,escloci,dersc,ddersc,mixed) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /sccalc/ time11,time12,time112,theti,it,nlobit + double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3) + double precision contr(maxlob,-1:1) + logical mixed +c write (iout,*) 'it=',it,' nlobit=',nlobit + escloc_i=0.0D0 + do j=1,3 + dersc(j)=0.0D0 + if (mixed) ddersc(j)=0.0d0 + enddo + x3=x(3) + +C Because of periodicity of the dependence of the SC energy in omega we have +C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi). +C To avoid underflows, first compute & store the exponents. + + do iii=-1,1 + + x(3)=x3+iii*dwapi + + do j=1,nlobit + do k=1,3 + z(k)=x(k)-censc(k,j,it) + enddo + do k=1,3 + Axk=0.0D0 + do l=1,3 + Axk=Axk+gaussc(l,k,j,it)*z(l) + enddo + Ax(k,j,iii)=Axk + enddo + expfac=0.0D0 + do k=1,3 + expfac=expfac+Ax(k,j,iii)*z(k) + enddo + contr(j,iii)=expfac + enddo ! j + + enddo ! iii + + x(3)=x3 +C As in the case of ebend, we want to avoid underflows in exponentiation and +C subsequent NaNs and INFs in energy calculation. +C Find the largest exponent + emin=contr(1,-1) + do iii=-1,1 + do j=1,nlobit + if (emin.gt.contr(j,iii)) emin=contr(j,iii) + enddo + enddo + emin=0.5D0*emin +cd print *,'it=',it,' emin=',emin + +C Compute the contribution to SC energy and derivatives + do iii=-1,1 + + do j=1,nlobit + expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin) +cd print *,'j=',j,' expfac=',expfac + escloc_i=escloc_i+expfac + do k=1,3 + dersc(k)=dersc(k)+Ax(k,j,iii)*expfac + enddo + if (mixed) then + do k=1,3,2 + ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) + & +gaussc(k,2,j,it))*expfac + enddo + endif + enddo + + enddo ! iii + + dersc(1)=dersc(1)/cos(theti)**2 + ddersc(1)=ddersc(1)/cos(theti)**2 + ddersc(3)=ddersc(3) + + escloci=-(dlog(escloc_i)-emin) + do j=1,3 + dersc(j)=dersc(j)/escloc_i + enddo + if (mixed) then + do j=1,3,2 + ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j)) + enddo + endif + return + end +C------------------------------------------------------------------------------ + subroutine enesc_bound(x,escloci,dersc,dersc12,mixed) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /sccalc/ time11,time12,time112,theti,it,nlobit + double precision x(3),z(3),Ax(3,maxlob),dersc(3) + double precision contr(maxlob) + logical mixed + + escloc_i=0.0D0 + + do j=1,3 + dersc(j)=0.0D0 + enddo + + do j=1,nlobit + do k=1,2 + z(k)=x(k)-censc(k,j,it) + enddo + z(3)=dwapi + do k=1,3 + Axk=0.0D0 + do l=1,3 + Axk=Axk+gaussc(l,k,j,it)*z(l) + enddo + Ax(k,j)=Axk + enddo + expfac=0.0D0 + do k=1,3 + expfac=expfac+Ax(k,j)*z(k) + enddo + contr(j)=expfac + enddo ! j + +C As in the case of ebend, we want to avoid underflows in exponentiation and +C subsequent NaNs and INFs in energy calculation. +C Find the largest exponent + emin=contr(1) + do j=1,nlobit + if (emin.gt.contr(j)) emin=contr(j) + enddo + emin=0.5D0*emin + +C Compute the contribution to SC energy and derivatives + + dersc12=0.0d0 + do j=1,nlobit + expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin) + escloc_i=escloc_i+expfac + do k=1,2 + dersc(k)=dersc(k)+Ax(k,j)*expfac + enddo + if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) + & +gaussc(1,2,j,it))*expfac + dersc(3)=0.0d0 + enddo + + dersc(1)=dersc(1)/cos(theti)**2 + dersc12=dersc12/cos(theti)**2 + escloci=-(dlog(escloc_i)-emin) + do j=1,2 + dersc(j)=dersc(j)/escloc_i + enddo + if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1)) + return + end +#else +c---------------------------------------------------------------------------------- + subroutine esc(escloc) +C Calculate the local energy of a side chain and its derivatives in the +C corresponding virtual-bond valence angles THETA and the spherical angles +C ALPHA and OMEGA derived from AM1 all-atom calculations. +C added by Urszula Kozlowska. 07/11/2007 +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.VAR' + include 'COMMON.SCROT' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + include 'COMMON.VECTORS' + double precision x_prime(3),y_prime(3),z_prime(3) + & , sumene,dsc_i,dp2_i,x(65), + & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6, + & de_dxx,de_dyy,de_dzz,de_dt + double precision s1_t,s1_6_t,s2_t,s2_6_t + double precision + & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3), + & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3), + & dt_dCi(3),dt_dCi1(3) + common /sccalc/ time11,time12,time112,theti,it,nlobit + delta=0.02d0*pi + escloc=0.0D0 + do i=loc_start,loc_end + costtab(i+1) =dcos(theta(i+1)) + sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1)) + cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1))) + sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1))) + cosfac2=0.5d0/(1.0d0+costtab(i+1)) + cosfac=dsqrt(cosfac2) + sinfac2=0.5d0/(1.0d0-costtab(i+1)) + sinfac=dsqrt(sinfac2) + it=itype(i) + if (it.eq.10) goto 1 +c +C Compute the axes of tghe local cartesian coordinates system; store in +c x_prime, y_prime and z_prime +c + do j=1,3 + x_prime(j) = 0.00 + y_prime(j) = 0.00 + z_prime(j) = 0.00 + enddo +C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres), +C & dc_norm(3,i+nres) + do j = 1,3 + x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac + y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac + enddo + do j = 1,3 + z_prime(j) = -uz(j,i-1) + enddo +c write (2,*) "i",i +c write (2,*) "x_prime",(x_prime(j),j=1,3) +c write (2,*) "y_prime",(y_prime(j),j=1,3) +c write (2,*) "z_prime",(z_prime(j),j=1,3) +c write (2,*) "xx",scalar(x_prime(1),x_prime(1)), +c & " xy",scalar(x_prime(1),y_prime(1)), +c & " xz",scalar(x_prime(1),z_prime(1)), +c & " yy",scalar(y_prime(1),y_prime(1)), +c & " yz",scalar(y_prime(1),z_prime(1)), +c & " zz",scalar(z_prime(1),z_prime(1)) +c +C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i), +C to local coordinate system. Store in xx, yy, zz. +c + xx=0.0d0 + yy=0.0d0 + zz=0.0d0 + do j = 1,3 + xx = xx + x_prime(j)*dc_norm(j,i+nres) + yy = yy + y_prime(j)*dc_norm(j,i+nres) + zz = zz + z_prime(j)*dc_norm(j,i+nres) + enddo + + xxtab(i)=xx + yytab(i)=yy + zztab(i)=zz +C +C Compute the energy of the ith side cbain +C +c write (2,*) "xx",xx," yy",yy," zz",zz + it=itype(i) + do j = 1,65 + x(j) = sc_parmin(j,it) + enddo +#ifdef CHECK_COORD +Cc diagnostics - remove later + xx1 = dcos(alph(2)) + yy1 = dsin(alph(2))*dcos(omeg(2)) + zz1 = -dsin(alph(2))*dsin(omeg(2)) + write(2,'(3f8.1,3f9.3,1x,3f9.3)') + & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz, + & xx1,yy1,zz1 +C," --- ", xx_w,yy_w,zz_w +c end diagnostics +#endif + sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2 + & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy + & + x(10)*yy*zz + sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 + & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy + & + x(20)*yy*zz + sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 + & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy + & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 + & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx + & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy + & +x(40)*xx*yy*zz + sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 + & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy + & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 + & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx + & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy + & +x(60)*xx*yy*zz + dsc_i = 0.743d0+x(61) + dp2_i = 1.9d0+x(62) + dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i + & *(xx*cost2tab(i+1)+yy*sint2tab(i+1))) + dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i + & *(xx*cost2tab(i+1)-yy*sint2tab(i+1))) + s1=(1+x(63))/(0.1d0 + dscp1) + s1_6=(1+x(64))/(0.1d0 + dscp1**6) + s2=(1+x(65))/(0.1d0 + dscp2) + s2_6=(1+x(65))/(0.1d0 + dscp2**6) + sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) + & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6) +c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3, +c & sumene4, +c & dscp1,dscp2,sumene +c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + escloc = escloc + sumene +c write (2,*) "escloc",escloc + if (.not. calc_grad) goto 1 +#ifdef DEBUG +C +C This section to check the numerical derivatives of the energy of ith side +C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert +C #define DEBUG in the code to turn it on. +C + write (2,*) "sumene =",sumene + aincr=1.0d-7 + xxsave=xx + xx=xx+aincr + write (2,*) xx,yy,zz + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dxx_num=(sumenep-sumene)/aincr + xx=xxsave + write (2,*) "xx+ sumene from enesc=",sumenep + yysave=yy + yy=yy+aincr + write (2,*) xx,yy,zz + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dyy_num=(sumenep-sumene)/aincr + yy=yysave + write (2,*) "yy+ sumene from enesc=",sumenep + zzsave=zz + zz=zz+aincr + write (2,*) xx,yy,zz + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dzz_num=(sumenep-sumene)/aincr + zz=zzsave + write (2,*) "zz+ sumene from enesc=",sumenep + costsave=cost2tab(i+1) + sintsave=sint2tab(i+1) + cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr)) + sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr)) + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dt_num=(sumenep-sumene)/aincr + write (2,*) " t+ sumene from enesc=",sumenep + cost2tab(i+1)=costsave + sint2tab(i+1)=sintsave +C End of diagnostics section. +#endif +C +C Compute the gradient of esc +C + pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2 + pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2 + pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2 + pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2 + pom_dx=dsc_i*dp2_i*cost2tab(i+1) + pom_dy=dsc_i*dp2_i*sint2tab(i+1) + pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1)) + pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1)) + pom1=(sumene3*sint2tab(i+1)+sumene1) + & *(pom_s1/dscp1+pom_s16*dscp1**4) + pom2=(sumene4*cost2tab(i+1)+sumene2) + & *(pom_s2/dscp2+pom_s26*dscp2**4) + sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy + sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 + & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) + & +x(40)*yy*zz + sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy + sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 + & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) + & +x(60)*yy*zz + de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) + & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) + & +(pom1+pom2)*pom_dx +#ifdef DEBUG + write(2,*), "de_dxx = ", de_dxx,de_dxx_num +#endif +C + sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz + sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 + & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) + & +x(40)*xx*zz + sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz + sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz + & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz + & +x(59)*zz**2 +x(60)*xx*zz + de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) + & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) + & +(pom1-pom2)*pom_dy +#ifdef DEBUG + write(2,*), "de_dyy = ", de_dyy,de_dyy_num +#endif +C + de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy + & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx + & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) + & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6) + & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2 + & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy + & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) + & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6) +#ifdef DEBUG + write(2,*), "de_dzz = ", de_dzz,de_dzz_num +#endif +C + de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) + & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) + & +pom1*pom_dt1+pom2*pom_dt2 +#ifdef DEBUG + write(2,*), "de_dt = ", de_dt,de_dt_num +#endif +c +C + cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres)) + cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres)) + cosfac2xx=cosfac2*xx + sinfac2yy=sinfac2*yy + do k = 1,3 + dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* + & vbld_inv(i+1) + dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* + & vbld_inv(i) + pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1) + pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i) +c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1, +c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k) +c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3), +c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i) + dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx + dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx + dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy + dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy + dZZ_Ci1(k)=0.0d0 + dZZ_Ci(k)=0.0d0 + do j=1,3 + dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres) + dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres) + enddo + + dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres)) + dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres)) + dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres)) +c + dt_dCi(k) = -dt_dCi(k)/sinttab(i+1) + dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1) + enddo + + do k=1,3 + dXX_Ctab(k,i)=dXX_Ci(k) + dXX_C1tab(k,i)=dXX_Ci1(k) + dYY_Ctab(k,i)=dYY_Ci(k) + dYY_C1tab(k,i)=dYY_Ci1(k) + dZZ_Ctab(k,i)=dZZ_Ci(k) + dZZ_C1tab(k,i)=dZZ_Ci1(k) + dXX_XYZtab(k,i)=dXX_XYZ(k) + dYY_XYZtab(k,i)=dYY_XYZ(k) + dZZ_XYZtab(k,i)=dZZ_XYZ(k) + enddo + + do k = 1,3 +c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1", +c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k) +c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci", +c & dyy_ci(k)," dzz_ci",dzz_ci(k) +c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci", +c & dt_dci(k) +c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ", +c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k) + gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) + & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k) + gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) + & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k) + gsclocx(k,i)= de_dxx*dxx_XYZ(k) + & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k) + enddo +c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3), +c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3) + +C to check gradient call subroutine check_grad + + 1 continue + enddo + return + end +#endif +c------------------------------------------------------------------------------ + subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont) +C +C This procedure calculates two-body contact function g(rij) and its derivative: +C +C eps0ij ! x < -1 +C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1 +C 0 ! x > 1 +C +C where x=(rij-r0ij)/delta +C +C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy +C + implicit none + double precision rij,r0ij,eps0ij,fcont,fprimcont + double precision x,x2,x4,delta +c delta=0.02D0*r0ij +c delta=0.2D0*r0ij + x=(rij-r0ij)/delta + if (x.lt.-1.0D0) then + fcont=eps0ij + fprimcont=0.0D0 + else if (x.le.1.0D0) then + x2=x*x + x4=x2*x2 + fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0) + fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta + else + fcont=0.0D0 + fprimcont=0.0D0 + endif + return + end +c------------------------------------------------------------------------------ + subroutine splinthet(theti,delta,ss,ssder) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.VAR' + include 'COMMON.GEO' + thetup=pi-delta + thetlow=delta + if (theti.gt.pipol) then + call gcont(theti,thetup,1.0d0,delta,ss,ssder) + else + call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder) + ssder=-ssder + endif + return + end +c------------------------------------------------------------------------------ + subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim) + implicit none + double precision x,x0,delta,f0,f1,fprim0,f,fprim + double precision ksi,ksi2,ksi3,a1,a2,a3 + a1=fprim0*delta/(f1-f0) + a2=3.0d0-2.0d0*a1 + a3=a1-2.0d0 + ksi=(x-x0)/delta + ksi2=ksi*ksi + ksi3=ksi2*ksi + f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi)) + fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3)) + return + end +c------------------------------------------------------------------------------ + subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx) + implicit none + double precision x,x0,delta,f0x,f1x,fprim0x,fx + double precision ksi,ksi2,ksi3,a1,a2,a3 + ksi=(x-x0)/delta + ksi2=ksi*ksi + ksi3=ksi2*ksi + a1=fprim0x*delta + a2=3*(f1x-f0x)-2*fprim0x*delta + a3=fprim0x*delta-2*(f1x-f0x) + fx=f0x+a1*ksi+a2*ksi2+a3*ksi3 + return + end +C----------------------------------------------------------------------------- +#ifdef CRYST_TOR +C----------------------------------------------------------------------------- + subroutine etor(etors,edihcnstr,fact) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. + etors=0.0D0 + do i=iphi_start,iphi_end + itori=itortyp(itype(i-2)) + itori1=itortyp(itype(i-1)) + phii=phi(i) + gloci=0.0D0 +C Proline-Proline pair is a special case... + if (itori.eq.3 .and. itori1.eq.3) then + if (phii.gt.-dwapi3) then + cosphi=dcos(3*phii) + fac=1.0D0/(1.0D0-cosphi) + etorsi=v1(1,3,3)*fac + etorsi=etorsi+etorsi + etors=etors+etorsi-v1(1,3,3) + gloci=gloci-3*fac*etorsi*dsin(3*phii) + endif + do j=1,3 + v1ij=v1(j+1,itori,itori1) + v2ij=v2(j+1,itori,itori1) + cosphi=dcos(j*phii) + sinphi=dsin(j*phii) + etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo + else + do j=1,nterm_old + v1ij=v1(j,itori,itori1) + v2ij=v2(j,itori,itori1) + cosphi=dcos(j*phii) + sinphi=dsin(j*phii) + etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo + endif + if (lprn) + & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') + & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, + & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6) + gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci +c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) + enddo +! 6/20/98 - dihedral angle constraints + edihcnstr=0.0d0 + do i=1,ndih_constr + itori=idih_constr(i) + phii=phi(itori) + difi=phii-phi0(i) + if (difi.gt.drange(i)) then + difi=difi-drange(i) + edihcnstr=edihcnstr+0.25d0*ftors*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 + else if (difi.lt.-drange(i)) then + difi=difi+drange(i) + edihcnstr=edihcnstr+0.25d0*ftors*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 + endif +! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii, +! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) + enddo +! write (iout,*) 'edihcnstr',edihcnstr + return + end +c------------------------------------------------------------------------------ +#else + subroutine etor(etors,edihcnstr,fact) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. + etors=0.0D0 + do i=iphi_start,iphi_end + if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215 + itori=itortyp(itype(i-2)) + itori1=itortyp(itype(i-1)) + phii=phi(i) + gloci=0.0D0 +C Regular cosine and sine terms + do j=1,nterm(itori,itori1) + v1ij=v1(j,itori,itori1) + v2ij=v2(j,itori,itori1) + cosphi=dcos(j*phii) + sinphi=dsin(j*phii) + etors=etors+v1ij*cosphi+v2ij*sinphi + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo +C Lorentz terms +C v1 +C E = SUM ----------------------------------- - v1 +C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1 +C + cosphi=dcos(0.5d0*phii) + sinphi=dsin(0.5d0*phii) + do j=1,nlor(itori,itori1) + vl1ij=vlor1(j,itori,itori1) + vl2ij=vlor2(j,itori,itori1) + vl3ij=vlor3(j,itori,itori1) + pom=vl2ij*cosphi+vl3ij*sinphi + pom1=1.0d0/(pom*pom+1.0d0) + etors=etors+vl1ij*pom1 + pom=-pom*pom1*pom1 + gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom + enddo +C Subtract the constant term + etors=etors-v0(itori,itori1) + if (lprn) + & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') + & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, + & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6) + gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci +c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) + 1215 continue + enddo +! 6/20/98 - dihedral angle constraints + edihcnstr=0.0d0 + do i=1,ndih_constr + itori=idih_constr(i) + phii=phi(itori) + difi=pinorm(phii-phi0(i)) + edihi=0.0d0 + if (difi.gt.drange(i)) then + difi=difi-drange(i) + edihcnstr=edihcnstr+0.25d0*ftors*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 + edihi=0.25d0*ftors*difi**4 + else if (difi.lt.-drange(i)) then + difi=difi+drange(i) + edihcnstr=edihcnstr+0.25d0*ftors*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 + edihi=0.25d0*ftors*difi**4 + else + difi=0.0d0 + endif +c write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi, +c & drange(i),edihi +! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii, +! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) + enddo +! write (iout,*) 'edihcnstr',edihcnstr + return + end +c---------------------------------------------------------------------------- + subroutine etor_d(etors_d,fact2) +C 6/23/01 Compute double torsional energy + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. + etors_d=0.0D0 + do i=iphi_start,iphi_end-1 + if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0) + & goto 1215 + itori=itortyp(itype(i-2)) + itori1=itortyp(itype(i-1)) + itori2=itortyp(itype(i)) + phii=phi(i) + phii1=phi(i+1) + gloci1=0.0D0 + gloci2=0.0D0 +C Regular cosine and sine terms + do j=1,ntermd_1(itori,itori1,itori2) + v1cij=v1c(1,j,itori,itori1,itori2) + v1sij=v1s(1,j,itori,itori1,itori2) + v2cij=v1c(2,j,itori,itori1,itori2) + v2sij=v1s(2,j,itori,itori1,itori2) + cosphi1=dcos(j*phii) + sinphi1=dsin(j*phii) + cosphi2=dcos(j*phii1) + sinphi2=dsin(j*phii1) + etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ + & v2cij*cosphi2+v2sij*sinphi2 + gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1) + gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2) + enddo + do k=2,ntermd_2(itori,itori1,itori2) + do l=1,k-1 + v1cdij = v2c(k,l,itori,itori1,itori2) + v2cdij = v2c(l,k,itori,itori1,itori2) + v1sdij = v2s(k,l,itori,itori1,itori2) + v2sdij = v2s(l,k,itori,itori1,itori2) + cosphi1p2=dcos(l*phii+(k-l)*phii1) + cosphi1m2=dcos(l*phii-(k-l)*phii1) + sinphi1p2=dsin(l*phii+(k-l)*phii1) + sinphi1m2=dsin(l*phii-(k-l)*phii1) + etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ + & v1sdij*sinphi1p2+v2sdij*sinphi1m2 + gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 + & -v1cdij*sinphi1p2-v2cdij*sinphi1m2) + gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 + & -v1cdij*sinphi1p2+v2cdij*sinphi1m2) + enddo + enddo + gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1 + gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2 + 1215 continue + enddo + return + end +#endif +c------------------------------------------------------------------------------ + subroutine eback_sc_corr(esccor) +c 7/21/2007 Correlations between the backbone-local and side-chain-local +c conformational states; temporarily implemented as differences +c between UNRES torsional potentials (dependent on three types of +c residues) and the torsional potentials dependent on all 20 types +c of residues computed from AM1 energy surfaces of terminally-blocked +c amino-acid residues. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.SCCOR' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. +c write (iout,*) "EBACK_SC_COR",itau_start,itau_end,nterm_sccor + esccor=0.0D0 + do i=itau_start,itau_end + esccor_ii=0.0D0 + isccori=isccortyp(itype(i-2)) + isccori1=isccortyp(itype(i-1)) + phii=phi(i) +cccc Added 9 May 2012 +cc Tauangle is torsional engle depending on the value of first digit +c(see comment below) +cc Omicron is flat angle depending on the value of first digit +c(see comment below) + + + do intertyp=1,3 !intertyp +cc Added 09 May 2012 (Adasko) +cc Intertyp means interaction type of backbone mainchain correlation: +c 1 = SC...Ca...Ca...Ca +c 2 = Ca...Ca...Ca...SC +c 3 = SC...Ca...Ca...SCi + gloci=0.0D0 + if (((intertyp.eq.3).and.((itype(i-2).eq.10).or. + & (itype(i-1).eq.10).or.(itype(i-2).eq.21).or. + & (itype(i-1).eq.21))) + & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10) + & .or.(itype(i-2).eq.21))) + & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or. + & (itype(i-1).eq.21)))) cycle + if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle + if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21)) + & cycle + do j=1,nterm_sccor(isccori,isccori1) + v1ij=v1sccor(j,intertyp,isccori,isccori1) + v2ij=v2sccor(j,intertyp,isccori,isccori1) + cosphi=dcos(j*tauangle(intertyp,i)) + sinphi=dsin(j*tauangle(intertyp,i)) + esccor=esccor+v1ij*cosphi+v2ij*sinphi + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo + gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci +c write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi +c &gloc_sc(intertyp,i-3,icg) + if (lprn) + & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') + & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, + & (v1sccor(j,intertyp,itori,itori1),j=1,6) + & ,(v2sccor(j,intertyp,itori,itori1),j=1,6) + gsccor_loc(i-3)=gsccor_loc(i-3)+gloci + enddo !intertyp + enddo +c do i=1,nres +c write (iout,*) "W@T@F", gloc_sc(1,i,icg),gloc(i,icg) +c enddo + return + end +c------------------------------------------------------------------------------ + subroutine multibody(ecorr) +C This subroutine calculates multi-body contributions to energy following +C the idea of Skolnick et al. If side chains I and J make a contact and +C at the same time side chains I+1 and J+1 make a contact, an extra +C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + double precision gx(3),gx1(3) + logical lprn + +C Set lprn=.true. for debugging + lprn=.false. + + if (lprn) then + write (iout,'(a)') 'Contact function values:' + do i=nnt,nct-2 + write (iout,'(i2,20(1x,i2,f10.5))') + & i,(jcont(j,i),facont(j,i),j=1,num_cont(i)) + enddo + endif + ecorr=0.0D0 + do i=nnt,nct + do j=1,3 + gradcorr(j,i)=0.0D0 + gradxorr(j,i)=0.0D0 + enddo + enddo + do i=nnt,nct-2 + + DO ISHIFT = 3,4 + + i1=i+ishift + num_conti=num_cont(i) + num_conti1=num_cont(i1) + do jj=1,num_conti + j=jcont(jj,i) + do kk=1,num_conti1 + j1=jcont(kk,i1) + if (j1.eq.j+ishift .or. j1.eq.j-ishift) then +cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1, +cd & ' ishift=',ishift +C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously. +C The system gains extra energy. + ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk) + endif ! j1==j+-ishift + enddo ! kk + enddo ! jj + + ENDDO ! ISHIFT + + enddo ! i + return + end +c------------------------------------------------------------------------------ + double precision function esccorr(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + double precision gx(3),gx1(3) + logical lprn + lprn=.false. + eij=facont(jj,i) + ekl=facont(kk,k) +cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl +C Calculate the multi-body contribution to energy. +C Calculate multi-body contributions to the gradient. +cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3), +cd & k,l,(gacont(m,kk,k),m=1,3) + do m=1,3 + gx(m) =ekl*gacont(m,jj,i) + gx1(m)=eij*gacont(m,kk,k) + gradxorr(m,i)=gradxorr(m,i)-gx(m) + gradxorr(m,j)=gradxorr(m,j)+gx(m) + gradxorr(m,k)=gradxorr(m,k)-gx1(m) + gradxorr(m,l)=gradxorr(m,l)+gx1(m) + enddo + do m=i,j-1 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+gx(ll) + enddo + enddo + do m=k,l-1 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll) + enddo + enddo + esccorr=-eij*ekl + return + end +c------------------------------------------------------------------------------ +#ifdef MPL + subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + integer dimen1,dimen2,atom,indx + double precision buffer(dimen1,dimen2) + double precision zapas + common /contacts_hb/ zapas(3,20,maxres,7), + & facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres), + & num_cont_hb(maxres),jcont_hb(20,maxres) + num_kont=num_cont_hb(atom) + do i=1,num_kont + do k=1,7 + do j=1,3 + buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k) + enddo ! j + enddo ! k + buffer(i,indx+22)=facont_hb(i,atom) + buffer(i,indx+23)=ees0p(i,atom) + buffer(i,indx+24)=ees0m(i,atom) + buffer(i,indx+25)=dfloat(jcont_hb(i,atom)) + enddo ! i + buffer(1,indx+26)=dfloat(num_kont) + return + end +c------------------------------------------------------------------------------ + subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + integer dimen1,dimen2,atom,indx + double precision buffer(dimen1,dimen2) + double precision zapas + common /contacts_hb/ zapas(3,20,maxres,7), + & facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres), + & num_cont_hb(maxres),jcont_hb(20,maxres) + num_kont=buffer(1,indx+26) + num_kont_old=num_cont_hb(atom) + num_cont_hb(atom)=num_kont+num_kont_old + do i=1,num_kont + ii=i+num_kont_old + do k=1,7 + do j=1,3 + zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j) + enddo ! j + enddo ! k + facont_hb(ii,atom)=buffer(i,indx+22) + ees0p(ii,atom)=buffer(i,indx+23) + ees0m(ii,atom)=buffer(i,indx+24) + jcont_hb(ii,atom)=buffer(i,indx+25) + enddo ! i + return + end +c------------------------------------------------------------------------------ +#endif + subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) +C This subroutine calculates multi-body contributions to hydrogen-bonding + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' +#ifdef MPL + include 'COMMON.INFO' +#endif + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' +#ifdef MPL + parameter (max_cont=maxconts) + parameter (max_dim=2*(8*3+2)) + parameter (msglen1=max_cont*max_dim*4) + parameter (msglen2=2*msglen1) + integer source,CorrelType,CorrelID,Error + double precision buffer(max_cont,max_dim) +#endif + double precision gx(3),gx1(3) + logical lprn,ldone + +C Set lprn=.true. for debugging + lprn=.false. +#ifdef MPL + n_corr=0 + n_corr1=0 + if (fgProcs.le.1) goto 30 + if (lprn) then + write (iout,'(a)') 'Contact function values:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i2,f5.2))') + & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), + & j=1,num_cont_hb(i)) + enddo + endif +C Caution! Following code assumes that electrostatic interactions concerning +C a given atom are split among at most two processors! + CorrelType=477 + CorrelID=MyID+1 + ldone=.false. + do i=1,max_cont + do j=1,max_dim + buffer(i,j)=0.0D0 + enddo + enddo + mm=mod(MyRank,2) +cd write (iout,*) 'MyRank',MyRank,' mm',mm + if (mm) 20,20,10 + 10 continue +cd write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone + if (MyRank.gt.0) then +C Send correlation contributions to the preceding processor + msglen=msglen1 + nn=num_cont_hb(iatel_s) + call pack_buffer(max_cont,max_dim,iatel_s,0,buffer) +cd write (iout,*) 'The BUFFER array:' +cd do i=1,nn +cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26) +cd enddo + if (ielstart(iatel_s).gt.iatel_s+ispp) then + msglen=msglen2 + call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer) +C Clear the contacts of the atom passed to the neighboring processor + nn=num_cont_hb(iatel_s+1) +cd do i=1,nn +cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26) +cd enddo + num_cont_hb(iatel_s)=0 + endif +cd write (iout,*) 'Processor ',MyID,MyRank, +cd & ' is sending correlation contribution to processor',MyID-1, +cd & ' msglen=',msglen +cd write (*,*) 'Processor ',MyID,MyRank, +cd & ' is sending correlation contribution to processor',MyID-1, +cd & ' msglen=',msglen,' CorrelType=',CorrelType + call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID) +cd write (iout,*) 'Processor ',MyID, +cd & ' has sent correlation contribution to processor',MyID-1, +cd & ' msglen=',msglen,' CorrelID=',CorrelID +cd write (*,*) 'Processor ',MyID, +cd & ' has sent correlation contribution to processor',MyID-1, +cd & ' msglen=',msglen,' CorrelID=',CorrelID + msglen=msglen1 + endif ! (MyRank.gt.0) + if (ldone) goto 30 + ldone=.true. + 20 continue +cd write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone + if (MyRank.lt.fgProcs-1) then +C Receive correlation contributions from the next processor + msglen=msglen1 + if (ielend(iatel_e).lt.nct-1) msglen=msglen2 +cd write (iout,*) 'Processor',MyID, +cd & ' is receiving correlation contribution from processor',MyID+1, +cd & ' msglen=',msglen,' CorrelType=',CorrelType +cd write (*,*) 'Processor',MyID, +cd & ' is receiving correlation contribution from processor',MyID+1, +cd & ' msglen=',msglen,' CorrelType=',CorrelType + nbytes=-1 + do while (nbytes.le.0) + call mp_probe(MyID+1,CorrelType,nbytes) + enddo +cd print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes + call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes) +cd write (iout,*) 'Processor',MyID, +cd & ' has received correlation contribution from processor',MyID+1, +cd & ' msglen=',msglen,' nbytes=',nbytes +cd write (iout,*) 'The received BUFFER array:' +cd do i=1,max_cont +cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52) +cd enddo + if (msglen.eq.msglen1) then + call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer) + else if (msglen.eq.msglen2) then + call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer) + call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer) + else + write (iout,*) + & 'ERROR!!!! message length changed while processing correlations.' + write (*,*) + & 'ERROR!!!! message length changed while processing correlations.' + call mp_stopall(Error) + endif ! msglen.eq.msglen1 + endif ! MyRank.lt.fgProcs-1 + if (ldone) goto 30 + ldone=.true. + goto 10 + 30 continue +#endif + if (lprn) then + write (iout,'(a)') 'Contact function values:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i2,f5.2))') + & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), + & j=1,num_cont_hb(i)) + enddo + endif + ecorr=0.0D0 +C Remove the loop below after debugging !!! + do i=nnt,nct + do j=1,3 + gradcorr(j,i)=0.0D0 + gradxorr(j,i)=0.0D0 + enddo + enddo +C Calculate the local-electrostatic correlation terms + do i=iatel_s,iatel_e+1 + i1=i+1 + num_conti=num_cont_hb(i) + num_conti1=num_cont_hb(i+1) + do jj=1,num_conti + j=jcont_hb(jj,i) + do kk=1,num_conti1 + j1=jcont_hb(kk,i1) +c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk + if (j1.eq.j+1 .or. j1.eq.j-1) then +C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. +C The system gains extra energy. + ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0) + n_corr=n_corr+1 + else if (j1.eq.j) then +C Contacts I-J and I-(J+1) occur simultaneously. +C The system loses extra energy. +c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0) + endif + enddo ! kk + do kk=1,num_conti + j1=jcont_hb(kk,i) +c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk + if (j1.eq.j+1) then +C Contacts I-J and (I+1)-J occur simultaneously. +C The system loses extra energy. +c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0) + endif ! j1==j+1 + enddo ! kk + enddo ! jj + enddo ! i + return + end +c------------------------------------------------------------------------------ + subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr, + & n_corr1) +C This subroutine calculates multi-body contributions to hydrogen-bonding + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' +#ifdef MPL + include 'COMMON.INFO' +#endif + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' +#ifdef MPL + parameter (max_cont=maxconts) + parameter (max_dim=2*(8*3+2)) + parameter (msglen1=max_cont*max_dim*4) + parameter (msglen2=2*msglen1) + integer source,CorrelType,CorrelID,Error + double precision buffer(max_cont,max_dim) +#endif + double precision gx(3),gx1(3) + logical lprn,ldone + +C Set lprn=.true. for debugging + lprn=.false. + eturn6=0.0d0 +#ifdef MPL + n_corr=0 + n_corr1=0 + if (fgProcs.le.1) goto 30 + if (lprn) then + write (iout,'(a)') 'Contact function values:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i2,f5.2))') + & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), + & j=1,num_cont_hb(i)) + enddo + endif +C Caution! Following code assumes that electrostatic interactions concerning +C a given atom are split among at most two processors! + CorrelType=477 + CorrelID=MyID+1 + ldone=.false. + do i=1,max_cont + do j=1,max_dim + buffer(i,j)=0.0D0 + enddo + enddo + mm=mod(MyRank,2) +cd write (iout,*) 'MyRank',MyRank,' mm',mm + if (mm) 20,20,10 + 10 continue +cd write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone + if (MyRank.gt.0) then +C Send correlation contributions to the preceding processor + msglen=msglen1 + nn=num_cont_hb(iatel_s) + call pack_buffer(max_cont,max_dim,iatel_s,0,buffer) +cd write (iout,*) 'The BUFFER array:' +cd do i=1,nn +cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26) +cd enddo + if (ielstart(iatel_s).gt.iatel_s+ispp) then + msglen=msglen2 + call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer) +C Clear the contacts of the atom passed to the neighboring processor + nn=num_cont_hb(iatel_s+1) +cd do i=1,nn +cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26) +cd enddo + num_cont_hb(iatel_s)=0 + endif +cd write (iout,*) 'Processor ',MyID,MyRank, +cd & ' is sending correlation contribution to processor',MyID-1, +cd & ' msglen=',msglen +cd write (*,*) 'Processor ',MyID,MyRank, +cd & ' is sending correlation contribution to processor',MyID-1, +cd & ' msglen=',msglen,' CorrelType=',CorrelType + call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID) +cd write (iout,*) 'Processor ',MyID, +cd & ' has sent correlation contribution to processor',MyID-1, +cd & ' msglen=',msglen,' CorrelID=',CorrelID +cd write (*,*) 'Processor ',MyID, +cd & ' has sent correlation contribution to processor',MyID-1, +cd & ' msglen=',msglen,' CorrelID=',CorrelID + msglen=msglen1 + endif ! (MyRank.gt.0) + if (ldone) goto 30 + ldone=.true. + 20 continue +cd write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone + if (MyRank.lt.fgProcs-1) then +C Receive correlation contributions from the next processor + msglen=msglen1 + if (ielend(iatel_e).lt.nct-1) msglen=msglen2 +cd write (iout,*) 'Processor',MyID, +cd & ' is receiving correlation contribution from processor',MyID+1, +cd & ' msglen=',msglen,' CorrelType=',CorrelType +cd write (*,*) 'Processor',MyID, +cd & ' is receiving correlation contribution from processor',MyID+1, +cd & ' msglen=',msglen,' CorrelType=',CorrelType + nbytes=-1 + do while (nbytes.le.0) + call mp_probe(MyID+1,CorrelType,nbytes) + enddo +cd print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes + call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes) +cd write (iout,*) 'Processor',MyID, +cd & ' has received correlation contribution from processor',MyID+1, +cd & ' msglen=',msglen,' nbytes=',nbytes +cd write (iout,*) 'The received BUFFER array:' +cd do i=1,max_cont +cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52) +cd enddo + if (msglen.eq.msglen1) then + call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer) + else if (msglen.eq.msglen2) then + call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer) + call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer) + else + write (iout,*) + & 'ERROR!!!! message length changed while processing correlations.' + write (*,*) + & 'ERROR!!!! message length changed while processing correlations.' + call mp_stopall(Error) + endif ! msglen.eq.msglen1 + endif ! MyRank.lt.fgProcs-1 + if (ldone) goto 30 + ldone=.true. + goto 10 + 30 continue +#endif + if (lprn) then + write (iout,'(a)') 'Contact function values:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i2,f5.2))') + & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), + & j=1,num_cont_hb(i)) + enddo + endif + ecorr=0.0D0 + ecorr5=0.0d0 + ecorr6=0.0d0 +C Remove the loop below after debugging !!! + do i=nnt,nct + do j=1,3 + gradcorr(j,i)=0.0D0 + gradxorr(j,i)=0.0D0 + enddo + enddo +C Calculate the dipole-dipole interaction energies + if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then + do i=iatel_s,iatel_e+1 + num_conti=num_cont_hb(i) + do jj=1,num_conti + j=jcont_hb(jj,i) + call dipole(i,j,jj) + enddo + enddo + endif +C Calculate the local-electrostatic correlation terms + do i=iatel_s,iatel_e+1 + i1=i+1 + num_conti=num_cont_hb(i) + num_conti1=num_cont_hb(i+1) + do jj=1,num_conti + j=jcont_hb(jj,i) + do kk=1,num_conti1 + j1=jcont_hb(kk,i1) +c write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk + if (j1.eq.j+1 .or. j1.eq.j-1) then +C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. +C The system gains extra energy. + n_corr=n_corr+1 + sqd1=dsqrt(d_cont(jj,i)) + sqd2=dsqrt(d_cont(kk,i1)) + sred_geom = sqd1*sqd2 + IF (sred_geom.lt.cutoff_corr) THEN + call gcont(sred_geom,r0_corr,1.0D0,delt_corr, + & ekont,fprimcont) +c write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk + fac_prim1=0.5d0*sqd2/sqd1*fprimcont + fac_prim2=0.5d0*sqd1/sqd2*fprimcont + do l=1,3 + g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i) + g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1) + enddo + n_corr1=n_corr1+1 +cd write (iout,*) 'sred_geom=',sred_geom, +cd & ' ekont=',ekont,' fprim=',fprimcont + call calc_eello(i,j,i+1,j1,jj,kk) + if (wcorr4.gt.0.0d0) + & ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk) + if (wcorr5.gt.0.0d0) + & ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk) +c print *,"wcorr5",ecorr5 +cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6 +cd write(2,*)'ijkl',i,j,i+1,j1 + if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3 + & .or. wturn6.eq.0.0d0))then +cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1 + ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk) +cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5, +cd & 'ecorr6=',ecorr6 +cd write (iout,'(4e15.5)') sred_geom, +cd & dabs(eello4(i,j,i+1,j1,jj,kk)), +cd & dabs(eello5(i,j,i+1,j1,jj,kk)), +cd & dabs(eello6(i,j,i+1,j1,jj,kk)) + else if (wturn6.gt.0.0d0 + & .and. (j.eq.i+4 .and. j1.eq.i+3)) then +cd write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1 + eturn6=eturn6+eello_turn6(i,jj,kk) +cd write (2,*) 'multibody_eello:eturn6',eturn6 + endif + ENDIF +1111 continue + else if (j1.eq.j) then +C Contacts I-J and I-(J+1) occur simultaneously. +C The system loses extra energy. +c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0) + endif + enddo ! kk + do kk=1,num_conti + j1=jcont_hb(kk,i) +c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk + if (j1.eq.j+1) then +C Contacts I-J and (I+1)-J occur simultaneously. +C The system loses extra energy. +c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0) + endif ! j1==j+1 + enddo ! kk + enddo ! jj + enddo ! i + return + end +c------------------------------------------------------------------------------ + double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + double precision gx(3),gx1(3) + logical lprn + lprn=.false. + eij=facont_hb(jj,i) + ekl=facont_hb(kk,k) + ees0pij=ees0p(jj,i) + ees0pkl=ees0p(kk,k) + ees0mij=ees0m(jj,i) + ees0mkl=ees0m(kk,k) + ekont=eij*ekl + ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl) +cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl) +C Following 4 lines for diagnostics. +cd ees0pkl=0.0D0 +cd ees0pij=1.0D0 +cd ees0mkl=0.0D0 +cd ees0mij=1.0D0 +c write (iout,*)'Contacts have occurred for peptide groups',i,j, +c & ' and',k,l +c write (iout,*)'Contacts have occurred for peptide groups', +c & i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l +c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees +C Calculate the multi-body contribution to energy. + ecorr=ecorr+ekont*ees + if (calc_grad) then +C Calculate multi-body contributions to the gradient. + do ll=1,3 + ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i) + gradcorr(ll,i)=gradcorr(ll,i)+ghalf + & -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+ + & coeffm*ees0mkl*gacontm_hb1(ll,jj,i)) + gradcorr(ll,j)=gradcorr(ll,j)+ghalf + & -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+ + & coeffm*ees0mkl*gacontm_hb2(ll,jj,i)) + ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k) + gradcorr(ll,k)=gradcorr(ll,k)+ghalf + & -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+ + & coeffm*ees0mij*gacontm_hb1(ll,kk,k)) + gradcorr(ll,l)=gradcorr(ll,l)+ghalf + & -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+ + & coeffm*ees0mij*gacontm_hb2(ll,kk,k)) + enddo + do m=i+1,j-1 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+ + & ees*ekl*gacont_hbr(ll,jj,i)- + & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+ + & coeffm*ees0mkl*gacontm_hb3(ll,jj,i)) + enddo + enddo + do m=k+1,l-1 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+ + & ees*eij*gacont_hbr(ll,kk,k)- + & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+ + & coeffm*ees0mij*gacontm_hb3(ll,kk,k)) + enddo + enddo + endif + ehbcorr=ekont*ees + return + end +C--------------------------------------------------------------------------- + subroutine dipole(i,j,jj) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2), + & auxmat(2,2) + iti1 = itortyp(itype(i+1)) + if (j.lt.nres-1) then + itj1 = itortyp(itype(j+1)) + else + itj1=ntortyp+1 + endif + do iii=1,2 + dipi(iii,1)=Ub2(iii,i) + dipderi(iii)=Ub2der(iii,i) + dipi(iii,2)=b1(iii,iti1) + dipj(iii,1)=Ub2(iii,j) + dipderj(iii)=Ub2der(iii,j) + dipj(iii,2)=b1(iii,itj1) + enddo + kkk=0 + do iii=1,2 + call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1)) + do jjj=1,2 + kkk=kkk+1 + dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) + enddo + enddo + if (.not.calc_grad) return + do kkk=1,5 + do lll=1,3 + mmm=0 + do iii=1,2 + call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii), + & auxvec(1)) + do jjj=1,2 + mmm=mmm+1 + dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) + enddo + enddo + enddo + enddo + call transpose2(a_chuj(1,1,jj,i),auxmat(1,1)) + call matvec2(auxmat(1,1),dipderi(1),auxvec(1)) + do iii=1,2 + dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii)) + enddo + call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1)) + do iii=1,2 + dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii)) + enddo + return + end +C--------------------------------------------------------------------------- + subroutine calc_eello(i,j,k,l,jj,kk) +C +C This subroutine computes matrices and vectors needed to calculate +C the fourth-, fifth-, and sixth-order local-electrostatic terms. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.FFIELD' + double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2), + & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2) + logical lprn + common /kutas/ lprn +cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l, +cd & ' jj=',jj,' kk=',kk +cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return + do iii=1,2 + do jjj=1,2 + aa1(iii,jjj)=a_chuj(iii,jjj,jj,i) + aa2(iii,jjj)=a_chuj(iii,jjj,kk,k) + enddo + enddo + call transpose2(aa1(1,1),aa1t(1,1)) + call transpose2(aa2(1,1),aa2t(1,1)) + do kkk=1,5 + do lll=1,3 + call transpose2(a_chuj_der(1,1,lll,kkk,jj,i), + & aa1tder(1,1,lll,kkk)) + call transpose2(a_chuj_der(1,1,lll,kkk,kk,k), + & aa2tder(1,1,lll,kkk)) + enddo + enddo + if (l.eq.j+1) then +C parallel orientation of the two CA-CA-CA frames. + if (i.gt.1) then + iti=itortyp(itype(i)) + else + iti=ntortyp+1 + endif + itk1=itortyp(itype(k+1)) + itj=itortyp(itype(j)) + if (l.lt.nres-1) then + itl1=itortyp(itype(l+1)) + else + itl1=ntortyp+1 + endif +C A1 kernel(j+1) A2T +cd do iii=1,2 +cd write (iout,'(3f10.5,5x,3f10.5)') +cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2) +cd enddo + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l), + & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0) THEN + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l), + & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l), + & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1), + & ADtEAderx(1,1,1,1,1,1)) + lprn=.false. + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l), + & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), + & ADtEA1derx(1,1,1,1,1,1)) + ENDIF +C End 6-th order cumulants +cd lprn=.false. +cd if (lprn) then +cd write (2,*) 'In calc_eello6' +cd do iii=1,2 +cd write (2,*) 'iii=',iii +cd do kkk=1,5 +cd write (2,*) 'kkk=',kkk +cd do jjj=1,2 +cd write (2,'(3(2f10.5),5x)') +cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) +cd enddo +cd enddo +cd enddo +cd endif + call transpose2(EUgder(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) + call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), + & EAEAderx(1,1,lll,kkk,iii,1)) + enddo + enddo + enddo +C A1T kernel(i+1) A2 + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k), + & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0) THEN + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k), + & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k), + & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), + & ADtEAderx(1,1,1,1,1,2)) + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k), + & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), + & ADtEA1derx(1,1,1,1,1,2)) + ENDIF +C End 6-th order cumulants + call transpose2(EUgder(1,1,l),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2)) + call transpose2(EUg(1,1,l),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & EAEAderx(1,1,lll,kkk,iii,2)) + enddo + enddo + enddo +C AEAb1 and AEAb2 +C Calculate the vectors and their derivatives in virtual-bond dihedral angles. +C They are needed only when the fifth- or the sixth-order cumulants are +C indluded. + IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN + call transpose2(AEA(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1)) + call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1)) + call transpose2(AEAderg(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1)) + call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1)) + call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1)) + call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1)) + call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1)) + call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1)) + call transpose2(AEA(1,1,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2)) + call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2)) + call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2)) + call transpose2(AEAderg(1,1,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2)) + call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2)) + call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2)) + call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2)) + call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2)) + call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2)) + call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2)) +C Calculate the Cartesian derivatives of the vectors. + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti), + & AEAb1derx(1,lll,kkk,iii,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i), + & AEAb2derx(1,lll,kkk,iii,1,1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1), + & AEAb1derx(1,lll,kkk,iii,2,1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1), + & AEAb2derx(1,lll,kkk,iii,2,1)) + call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itj), + & AEAb1derx(1,lll,kkk,iii,1,2)) + call matvec2(auxmat(1,1),Ub2(1,j), + & AEAb2derx(1,lll,kkk,iii,1,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1), + & AEAb1derx(1,lll,kkk,iii,2,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1), + & AEAb2derx(1,lll,kkk,iii,2,2)) + enddo + enddo + enddo + ENDIF +C End vectors + else +C Antiparallel orientation of the two CA-CA-CA frames. + if (i.gt.1) then + iti=itortyp(itype(i)) + else + iti=ntortyp+1 + endif + itk1=itortyp(itype(k+1)) + itl=itortyp(itype(l)) + itj=itortyp(itype(j)) + if (j.lt.nres-1) then + itj1=itortyp(itype(j+1)) + else + itj1=ntortyp+1 + endif +C A2 kernel(j-1)T A1T + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j), + & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. + & j.eq.i+4 .and. l.eq.i+3)) THEN + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j), + & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) + call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j), + & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1), + & ADtEAderx(1,1,1,1,1,1)) + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j), + & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), + & ADtEA1derx(1,1,1,1,1,1)) + ENDIF +C End 6-th order cumulants + call transpose2(EUgder(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) + call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), + & EAEAderx(1,1,lll,kkk,iii,1)) + enddo + enddo + enddo +C A2T kernel(i+1)T A1 + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k), + & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. + & j.eq.i+4 .and. l.eq.i+3)) THEN + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k), + & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k), + & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), + & ADtEAderx(1,1,1,1,1,2)) + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k), + & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), + & ADtEA1derx(1,1,1,1,1,2)) + ENDIF +C End 6-th order cumulants + call transpose2(EUgder(1,1,j),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2)) + call transpose2(EUg(1,1,j),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & EAEAderx(1,1,lll,kkk,iii,2)) + enddo + enddo + enddo +C AEAb1 and AEAb2 +C Calculate the vectors and their derivatives in virtual-bond dihedral angles. +C They are needed only when the fifth- or the sixth-order cumulants are +C indluded. + IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. + & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN + call transpose2(AEA(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1)) + call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1)) + call transpose2(AEAderg(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1)) + call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1)) + call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1)) + call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1)) + call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1)) + call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1)) + call transpose2(AEA(1,1,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2)) + call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2)) + call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2)) + call transpose2(AEAderg(1,1,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2)) + call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2)) + call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2)) + call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2)) + call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2)) + call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2)) + call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2)) +C Calculate the Cartesian derivatives of the vectors. + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti), + & AEAb1derx(1,lll,kkk,iii,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i), + & AEAb2derx(1,lll,kkk,iii,1,1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1), + & AEAb1derx(1,lll,kkk,iii,2,1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1), + & AEAb2derx(1,lll,kkk,iii,2,1)) + call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itl), + & AEAb1derx(1,lll,kkk,iii,1,2)) + call matvec2(auxmat(1,1),Ub2(1,l), + & AEAb2derx(1,lll,kkk,iii,1,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1), + & AEAb1derx(1,lll,kkk,iii,2,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j), + & AEAb2derx(1,lll,kkk,iii,2,2)) + enddo + enddo + enddo + ENDIF +C End vectors + endif + return + end +C--------------------------------------------------------------------------- + subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp, + & KK,KKderg,AKA,AKAderg,AKAderx) + implicit none + integer nderg + logical transp + double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5), + & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2), + & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2) + integer iii,kkk,lll + integer jjj,mmm + logical lprn + common /kutas/ lprn + call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1)) + do iii=1,nderg + call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp, + & AKAderg(1,1,iii)) + enddo +cd if (lprn) write (2,*) 'In kernel' + do kkk=1,5 +cd if (lprn) write (2,*) 'kkk=',kkk + do lll=1,3 + call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1), + & KK(1,1),transp,AKAderx(1,1,lll,kkk,1)) +cd if (lprn) then +cd write (2,*) 'lll=',lll +cd write (2,*) 'iii=1' +cd do jjj=1,2 +cd write (2,'(3(2f10.5),5x)') +cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2) +cd enddo +cd endif + call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk), + & KK(1,1),transp,AKAderx(1,1,lll,kkk,2)) +cd if (lprn) then +cd write (2,*) 'lll=',lll +cd write (2,*) 'iii=2' +cd do jjj=1,2 +cd write (2,'(3(2f10.5),5x)') +cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2) +cd enddo +cd endif + enddo + enddo + return + end +C--------------------------------------------------------------------------- + double precision function eello4(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision pizda(2,2),ggg1(3),ggg2(3) +cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then +cd eello4=0.0d0 +cd return +cd endif +cd print *,'eello4:',i,j,k,l,jj,kk +cd write (2,*) 'i',i,' j',j,' k',k,' l',l +cd call checkint4(i,j,k,l,jj,kk,eel4_num) +cold eij=facont_hb(jj,i) +cold ekl=facont_hb(kk,k) +cold ekont=eij*ekl + eel4=-EAEA(1,1,1)-EAEA(2,2,1) + if (calc_grad) then +cd eel41=-EAEA(1,1,2)-EAEA(2,2,2) + gcorr_loc(k-1)=gcorr_loc(k-1) + & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1)) + if (l.eq.j+1) then + gcorr_loc(l-1)=gcorr_loc(l-1) + & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) + else + gcorr_loc(j-1)=gcorr_loc(j-1) + & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) + endif + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) + & -EAEAderx(2,2,lll,kkk,iii,1) +cd derx(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd gcorr_loc(l-1)=0.0d0 +cd gcorr_loc(j-1)=0.0d0 +cd gcorr_loc(k-1)=0.0d0 +cd eel4=1.0d0 +cd write (iout,*)'Contacts have occurred for peptide groups', +cd & i,j,' fcont:',eij,' eij',' and ',k,l, +cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif + do ll=1,3 +cold ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i) + ggg1(ll)=eel4*g_contij(ll,1) + ggg2(ll)=eel4*g_contij(ll,2) + ghalf=0.5d0*ggg1(ll) +cd ghalf=0.0d0 + gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1) + gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1) + gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1) + gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1) +cold ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k) + ghalf=0.5d0*ggg2(ll) +cd ghalf=0.0d0 + gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2) + gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2) + gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2) + gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2) + enddo +cd goto 1112 + do m=i+1,j-1 + do ll=1,3 +cold gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i) + gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll) + enddo + enddo + do m=k+1,l-1 + do ll=1,3 +cold gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k) + gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll) + enddo + enddo +1112 continue + do m=i+2,j2 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1) + enddo + enddo + do m=k+2,l2 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2) + enddo + enddo +cd do iii=1,nres-3 +cd write (2,*) iii,gcorr_loc(iii) +cd enddo + endif + eello4=ekont*eel4 +cd write (2,*) 'ekont',ekont +cd write (iout,*) 'eello4',ekont*eel4 + return + end +C--------------------------------------------------------------------------- + double precision function eello5(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2) + double precision ggg1(3),ggg2(3) +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel chains C +C C +C o o o o C +C /l\ / \ \ / \ / \ / C +C / \ / \ \ / \ / \ / C +C j| o |l1 | o | o| o | | o |o C +C \ |/k\| |/ \| / |/ \| |/ \| C +C \i/ \ / \ / / \ / \ C +C o k1 o C +C (I) (II) (III) (IV) C +C C +C eello5_1 eello5_2 eello5_3 eello5_4 C +C C +C Antiparallel chains C +C C +C o o o o C +C /j\ / \ \ / \ / \ / C +C / \ / \ \ / \ / \ / C +C j1| o |l | o | o| o | | o |o C +C \ |/k\| |/ \| / |/ \| |/ \| C +C \i/ \ / \ / / \ / \ C +C o k1 o C +C (I) (II) (III) (IV) C +C C +C eello5_1 eello5_2 eello5_3 eello5_4 C +C C +C o denotes a local interaction, vertical lines an electrostatic interaction. C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then +cd eello5=0.0d0 +cd return +cd endif +cd write (iout,*) +cd & 'EELLO5: Contacts have occurred for peptide groups',i,j, +cd & ' and',k,l + itk=itortyp(itype(k)) + itl=itortyp(itype(l)) + itj=itortyp(itype(j)) + eello5_1=0.0d0 + eello5_2=0.0d0 + eello5_3=0.0d0 + eello5_4=0.0d0 +cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num, +cd & eel5_3_num,eel5_4_num) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd eij=facont_hb(jj,i) +cd ekl=facont_hb(kk,k) +cd ekont=eij*ekl +cd write (iout,*)'Contacts have occurred for peptide groups', +cd & i,j,' fcont:',eij,' eij',' and ',k,l +cd goto 1111 +C Contribution from the graph I. +cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1) +cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) + if (calc_grad) then +C Explicit gradient in virtual-dihedral angles. + if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) + & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2der(1,i))) + call transpose2(EUgder(1,1,k),auxmat1(1,1)) + call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) + call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + if (l.eq.j+1) then + if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) + else + if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) + endif +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) + enddo + enddo + enddo +c goto 1112 + endif +c1111 continue +C Contribution from graph II + call transpose2(EE(1,1,itk),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k)) + if (calc_grad) then +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k)) + call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + if (l.eq.j+1) then + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k))) + else + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k))) + endif +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k)) + enddo + enddo + enddo +cd goto 1112 + endif +cd1111 continue + if (l.eq.j+1) then +cd goto 1110 +C Parallel orientation +C Contribution from graph III + call transpose2(EUg(1,1,l),auxmat(1,1)) + call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) + if (calc_grad) then +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2der(1,j))) + call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) + call transpose2(EUgder(1,1,l),auxmat1(1,1)) + call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) + enddo + enddo + enddo +cd goto 1112 + endif +C Contribution from graph IV +cd1110 continue + call transpose2(EE(1,1,itl),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) + & -0.5d0*scalar2(vv(1),Ctobr(1,l)) + if (calc_grad) then +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) + & -0.5d0*scalar2(vv(1),Ctobr(1,l))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) + & -0.5d0*scalar2(vv(1),Ctobr(1,l)) + enddo + enddo + enddo + endif + else +C Antiparallel orientation +C Contribution from graph III +c goto 1110 + call transpose2(EUg(1,1,j),auxmat(1,1)) + call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) + if (calc_grad) then +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2der(1,l))) + call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) + call transpose2(EUgder(1,1,j),auxmat1(1,1)) + call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) + & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) + enddo + enddo + enddo +cd goto 1112 + endif +C Contribution from graph IV +1110 continue + call transpose2(EE(1,1,itj),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) + & -0.5d0*scalar2(vv(1),Ctobr(1,j)) + if (calc_grad) then +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) + & -0.5d0*scalar2(vv(1),Ctobr(1,j))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) + & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) + & -0.5d0*scalar2(vv(1),Ctobr(1,j)) + enddo + enddo + enddo + endif + endif +1112 continue + eel5=eello5_1+eello5_2+eello5_3+eello5_4 +cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then +cd write (2,*) 'ijkl',i,j,k,l +cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2, +cd & ' eello5_3',eello5_3,' eello5_4',eello5_4 +cd endif +cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num +cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num +cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num +cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num + if (calc_grad) then + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif +cd eij=1.0d0 +cd ekl=1.0d0 +cd ekont=1.0d0 +cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont + do ll=1,3 + ggg1(ll)=eel5*g_contij(ll,1) + ggg2(ll)=eel5*g_contij(ll,2) +cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i) + ghalf=0.5d0*ggg1(ll) +cd ghalf=0.0d0 + gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1) + gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1) + gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1) + gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1) +cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k) + ghalf=0.5d0*ggg2(ll) +cd ghalf=0.0d0 + gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2) + gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2) + gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2) + gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2) + enddo +cd goto 1112 + do m=i+1,j-1 + do ll=1,3 +cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i) + gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll) + enddo + enddo + do m=k+1,l-1 + do ll=1,3 +cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k) + gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll) + enddo + enddo +c1112 continue + do m=i+2,j2 + do ll=1,3 + gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1) + enddo + enddo + do m=k+2,l2 + do ll=1,3 + gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2) + enddo + enddo +cd do iii=1,nres-3 +cd write (2,*) iii,g_corr5_loc(iii) +cd enddo + endif + eello5=ekont*eel5 +cd write (2,*) 'ekont',ekont +cd write (iout,*) 'eello5',ekont*eel5 + return + end +c-------------------------------------------------------------------------- + double precision function eello6(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.FFIELD' + double precision ggg1(3),ggg2(3) +cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then +cd eello6=0.0d0 +cd return +cd endif +cd write (iout,*) +cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, +cd & ' and',k,l + eello6_1=0.0d0 + eello6_2=0.0d0 + eello6_3=0.0d0 + eello6_4=0.0d0 + eello6_5=0.0d0 + eello6_6=0.0d0 +cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num, +cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd eij=facont_hb(jj,i) +cd ekl=facont_hb(kk,k) +cd ekont=eij*ekl +cd eij=1.0d0 +cd ekl=1.0d0 +cd ekont=1.0d0 + if (l.eq.j+1) then + eello6_1=eello6_graph1(i,j,k,l,1,.false.) + eello6_2=eello6_graph1(j,i,l,k,2,.false.) + eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.) + eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) + eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.) + eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.) + else + eello6_1=eello6_graph1(i,j,k,l,1,.false.) + eello6_2=eello6_graph1(l,k,j,i,2,.true.) + eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.) + eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) + if (wturn6.eq.0.0d0 .or. j.ne.i+4) then + eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) + else + eello6_5=0.0d0 + endif + eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.) + endif +C If turn contributions are considered, they will be handled separately. + eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6 +cd write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num +cd write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num +cd write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num +cd write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num +cd write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num +cd write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num +cd goto 1112 + if (calc_grad) then + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif + do ll=1,3 + ggg1(ll)=eel6*g_contij(ll,1) + ggg2(ll)=eel6*g_contij(ll,2) +cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i) + ghalf=0.5d0*ggg1(ll) +cd ghalf=0.0d0 + gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1) + gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1) + gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1) + gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1) + ghalf=0.5d0*ggg2(ll) +cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k) +cd ghalf=0.0d0 + gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2) + gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2) + gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2) + gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2) + enddo +cd goto 1112 + do m=i+1,j-1 + do ll=1,3 +cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i) + gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll) + enddo + enddo + do m=k+1,l-1 + do ll=1,3 +cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k) + gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll) + enddo + enddo +1112 continue + do m=i+2,j2 + do ll=1,3 + gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1) + enddo + enddo + do m=k+2,l2 + do ll=1,3 + gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2) + enddo + enddo +cd do iii=1,nres-3 +cd write (2,*) iii,g_corr6_loc(iii) +cd enddo + endif + eello6=ekont*eel6 +cd write (2,*) 'ekont',ekont +cd write (iout,*) 'eello6',ekont*eel6 + return + end +c-------------------------------------------------------------------------- + double precision function eello6_graph1(i,j,k,l,imat,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2) + logical swap + logical lprn + common /kutas/ lprn +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel Antiparallel C +C C +C o o C +C /l\ /j\ C +C / \ / \ C +C /| o | | o |\ C +C \ j|/k\| / \ |/k\|l / C +C \ / \ / \ / \ / C +C o o o o C +C i i C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + itk=itortyp(itype(k)) + s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i)) + s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k)) + s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k)) + call transpose2(EUgC(1,1,k),auxmat(1,1)) + call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) + vv1(1)=pizda1(1,1)-pizda1(2,2) + vv1(2)=pizda1(1,2)+pizda1(2,1) + s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) + vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk) + vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk) + s5=scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5 + eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5) + if (.not. calc_grad) return + if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) + & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) + & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) + & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) + & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) + & +scalar2(vv(1),Dtobr2der(1,i))) + call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1)) + vv1(1)=pizda1(1,1)-pizda1(2,2) + vv1(2)=pizda1(1,2)+pizda1(2,1) + vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk) + vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk) + if (l.eq.j+1) then + g_corr6_loc(l-1)=g_corr6_loc(l-1) + & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) + & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) + & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) + & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i)))) + else + g_corr6_loc(j-1)=g_corr6_loc(j-1) + & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) + & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) + & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) + & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i)))) + endif + call transpose2(EUgCder(1,1,k),auxmat(1,1)) + call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) + vv1(1)=pizda1(1,1)-pizda1(2,2) + vv1(2)=pizda1(1,2)+pizda1(2,1) + if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) + & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) + & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) + & +0.5d0*scalar2(vv1(1),Dtobr2(1,i)))) + do iii=1,2 + if (swap) then + ind=3-iii + else + ind=iii + endif + do kkk=1,5 + do lll=1,3 + s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i)) + s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k)) + s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k)) + call transpose2(EUgC(1,1,k),auxmat(1,1)) + call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1), + & pizda1(1,1)) + vv1(1)=pizda1(1,1)-pizda1(2,2) + vv1(2)=pizda1(1,2)+pizda1(2,1) + s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) + vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) + & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk) + vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) + & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk) + s5=scalar2(vv(1),Dtobr2(1,i)) + derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5) + enddo + enddo + enddo + return + end +c---------------------------------------------------------------------------- + double precision function eello6_graph2(i,j,k,l,jj,kk,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + logical swap + double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), + & auxvec1(2),auxvec2(1),auxmat1(2,2) + logical lprn + common /kutas/ lprn +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel Antiparallel C +C C +C o o C +C \ /l\ /j\ / C +C \ / \ / \ / C +C o| o | | o |o C +C \ j|/k\| \ |/k\|l C +C \ / \ \ / \ C +C o o C +C i i C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l +C AL 7/4/01 s1 would occur in the sixth-order moment, +C but not in a cluster cumulant +#ifdef MOMENT + s1=dip(1,jj,i)*dip(1,kk,k) +#endif + call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + eello6_graph2=-(s1+s2+s3+s4) +#else + eello6_graph2=-(s2+s3+s4) +#endif +c eello6_graph2=-s3 + if (.not. calc_grad) return +C Derivatives in gamma(i-1) + if (i.gt.1) then +#ifdef MOMENT + s1=dipderg(1,jj,i)*dip(1,kk,k) +#endif + s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1)) + call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) + s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i)) +#ifdef MOMENT + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) +#endif +c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3 + endif +C Derivatives in gamma(k-1) +#ifdef MOMENT + s1=dip(1,jj,i)*dipderg(1,kk,k) +#endif + call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) + call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) + call transpose2(EUgder(1,1,k),auxmat1(1,1)) + call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +#ifdef MOMENT + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) +#endif +c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3 +C Derivatives in gamma(j-1) or gamma(l-1) + if (j.gt.1) then +#ifdef MOMENT + s1=dipderg(3,jj,i)*dip(1,kk,k) +#endif + call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1)) + call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +#ifdef MOMENT + if (swap) then + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 + else + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 + endif +#endif + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4) +c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3 + endif +C Derivatives in gamma(l-1) or gamma(j-1) + if (l.gt.1) then +#ifdef MOMENT + s1=dip(1,jj,i)*dipderg(3,kk,k) +#endif + call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) + call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) + call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +#ifdef MOMENT + if (swap) then + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 + else + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 + endif +#endif + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4) +c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3 + endif +C Cartesian derivatives. + if (lprn) then + write (2,*) 'In eello6_graph2' + do iii=1,2 + write (2,*) 'iii=',iii + do kkk=1,5 + write (2,*) 'kkk=',kkk + do jjj=1,2 + write (2,'(3(2f10.5),5x)') + & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) + enddo + enddo + enddo + endif + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + if (iii.eq.1) then + s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k) + else + s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k) + endif +#endif + call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k), + & auxvec(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l), + & auxvec(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) +#else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) +#endif + if (swap) then + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 + else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + endif + enddo + enddo + enddo + return + end +c---------------------------------------------------------------------------- + double precision function eello6_graph3(i,j,k,l,jj,kk,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2) + logical swap +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel Antiparallel C +C C +C o o C +C /l\ / \ /j\ C +C / \ / \ / \ C +C /| o |o o| o |\ C +C j|/k\| / |/k\|l / C +C / \ / / \ / C +C / o / o C +C i i C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C 4/7/01 AL Component s1 was removed, because it pertains to the respective +C energy moment and not to the cluster cumulant. + iti=itortyp(itype(i)) + if (j.lt.nres-1) then + itj1=itortyp(itype(j+1)) + else + itj1=ntortyp+1 + endif + itk=itortyp(itype(k)) + itk1=itortyp(itype(k+1)) + if (l.lt.nres-1) then + itl1=itortyp(itype(l+1)) + else + itl1=ntortyp+1 + endif +#ifdef MOMENT + s1=dip(4,jj,i)*dip(4,kk,k) +#endif + call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1)) + s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) + call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1)) + s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) + call transpose2(EE(1,1,itk),auxmat(1,1)) + call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) +cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + eello6_graph3=-(s1+s2+s3+s4) +#else + eello6_graph3=-(s2+s3+s4) +#endif +c eello6_graph3=-s4 + if (.not. calc_grad) return +C Derivatives in gamma(k-1) + call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1)) + s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) + s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k)) + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4) +C Derivatives in gamma(l-1) + call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1)) + s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) + call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) +C Cartesian derivatives. + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + if (iii.eq.1) then + s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k) + else + s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k) + endif +#endif + call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1), + & auxvec(1)) + s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) + call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1), + & auxvec(1)) + s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) + call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) +#ifdef MOMENT + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) +#else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) +#endif + if (swap) then + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 + else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + endif +c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4 + enddo + enddo + enddo + return + end +c---------------------------------------------------------------------------- + double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.FFIELD' + double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), + & auxvec1(2),auxmat1(2,2) + logical swap +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel Antiparallel C +C C +C o o C +C /l\ / \ /j\ C +C / \ / \ / \ C +C /| o |o o| o |\ C +C \ j|/k\| \ |/k\|l C +C \ / \ \ / \ C +C o \ o \ C +C i i C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C 4/7/01 AL Component s1 was removed, because it pertains to the respective +C energy moment and not to the cluster cumulant. +cd write (2,*) 'eello_graph4: wturn6',wturn6 + iti=itortyp(itype(i)) + itj=itortyp(itype(j)) + if (j.lt.nres-1) then + itj1=itortyp(itype(j+1)) + else + itj1=ntortyp+1 + endif + itk=itortyp(itype(k)) + if (k.lt.nres-1) then + itk1=itortyp(itype(k+1)) + else + itk1=ntortyp+1 + endif + itl=itortyp(itype(l)) + if (l.lt.nres-1) then + itl1=itortyp(itype(l+1)) + else + itl1=ntortyp+1 + endif +cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l +cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk, +cd & ' itl',itl,' itl1',itl1 +#ifdef MOMENT + if (imat.eq.1) then + s1=dip(3,jj,i)*dip(3,kk,k) + else + s1=dip(2,jj,j)*dip(2,kk,l) + endif +#endif + call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) + else + call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) + endif + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + eello6_graph4=-(s1+s2+s3+s4) +#else + eello6_graph4=-(s2+s3+s4) +#endif + if (.not. calc_grad) return +C Derivatives in gamma(i-1) + if (i.gt.1) then +#ifdef MOMENT + if (imat.eq.1) then + s1=dipderg(2,jj,i)*dip(3,kk,k) + else + s1=dipderg(4,jj,j)*dip(2,kk,l) + endif +#endif + s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) + else + call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) + endif + s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i)) + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then +cd write (2,*) 'turn6 derivatives' +#ifdef MOMENT + gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4) +#else + gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4) +#endif + else +#ifdef MOMENT + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) +#endif + endif + endif +C Derivatives in gamma(k-1) +#ifdef MOMENT + if (imat.eq.1) then + s1=dip(3,jj,i)*dipderg(2,kk,k) + else + s1=dip(2,jj,j)*dipderg(4,kk,l) + endif +#endif + call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) + else + call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) + endif + call transpose2(EUgder(1,1,k),auxmat1(1,1)) + call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then +#ifdef MOMENT + gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4) +#else + gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4) +#endif + else +#ifdef MOMENT + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) +#endif + endif +C Derivatives in gamma(j-1) or gamma(l-1) + if (l.eq.j+1 .and. l.gt.1) then + call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) + else if (j.gt.1) then + call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then + gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4) + else + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4) + endif + endif +C Cartesian derivatives. + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + if (iii.eq.1) then + if (imat.eq.1) then + s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k) + else + s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l) + endif + else + if (imat.eq.1) then + s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k) + else + s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l) + endif + endif +#endif + call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k), + & auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), + & b1(1,itj1),auxvec(1)) + s3=-0.5d0*scalar2(b1(1,itj),auxvec(1)) + else + call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), + & b1(1,itl1),auxvec(1)) + s3=-0.5d0*scalar2(b1(1,itl),auxvec(1)) + endif + call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + if (swap) then + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then +#ifdef MOMENT + derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) + & -(s1+s2+s4) +#else + derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) + & -(s2+s4) +#endif + derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3 + else +#ifdef MOMENT + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4) +#else + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4) +#endif + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + endif + else +#ifdef MOMENT + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) +#else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) +#endif + if (l.eq.j+1) then + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + else + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 + endif + endif + enddo + enddo + enddo + return + end +c---------------------------------------------------------------------------- + double precision function eello_turn6(i,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2), + & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2), + & ggg1(3),ggg2(3) + double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2), + & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2) +C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to +C the respective energy moment and not to the cluster cumulant. + eello_turn6=0.0d0 + j=i+4 + k=i+1 + l=i+3 + iti=itortyp(itype(i)) + itk=itortyp(itype(k)) + itk1=itortyp(itype(k+1)) + itl=itortyp(itype(l)) + itj=itortyp(itype(j)) +cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj +cd write (2,*) 'i',i,' k',k,' j',j,' l',l +cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then +cd eello6=0.0d0 +cd return +cd endif +cd write (iout,*) +cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, +cd & ' and',k,l +cd call checkint_turn6(i,jj,kk,eel_turn6_num) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx_turn(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd eij=1.0d0 +cd ekl=1.0d0 +cd ekont=1.0d0 + eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) +cd eello6_5=0.0d0 +cd write (2,*) 'eello6_5',eello6_5 +#ifdef MOMENT + call transpose2(AEA(1,1,1),auxmat(1,1)) + call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1)) + ss1=scalar2(Ub2(1,i+2),b1(1,itl)) + s1 = (auxmat(1,1)+auxmat(2,2))*ss1 +#else + s1 = 0.0d0 +#endif + call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1)) + call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1)) + s2 = scalar2(b1(1,itk),vtemp1(1)) +#ifdef MOMENT + call transpose2(AEA(1,1,2),atemp(1,1)) + call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1)) + call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1)) + s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) +#else + s8=0.0d0 +#endif + call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1)) + call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1)) + s12 = scalar2(Ub2(1,i+2),vtemp3(1)) +#ifdef MOMENT + call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1)) + call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1)) + call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1)) + call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1)) + ss13 = scalar2(b1(1,itk),vtemp4(1)) + s13 = (gtemp(1,1)+gtemp(2,2))*ss13 +#else + s13=0.0d0 +#endif +c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13 +c s1=0.0d0 +c s2=0.0d0 +c s8=0.0d0 +c s12=0.0d0 +c s13=0.0d0 + eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13) + if (calc_grad) then +C Derivatives in gamma(i+2) +#ifdef MOMENT + call transpose2(AEA(1,1,1),auxmatd(1,1)) + call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 + call transpose2(AEAderg(1,1,2),atempd(1,1)) + call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1)) + s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) +#else + s8d=0.0d0 +#endif + call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1)) + call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 + gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d) +C Derivatives in gamma(i+3) +#ifdef MOMENT + call transpose2(AEA(1,1,1),auxmatd(1,1)) + call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + ss1d=scalar2(Ub2der(1,i+2),b1(1,itl)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d +#else + s1d=0.0d0 +#endif + call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1)) + call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1)) + s2d = scalar2(b1(1,itk),vtemp1d(1)) +#ifdef MOMENT + call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1)) + s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1)) +#endif + s12d = scalar2(Ub2der(1,i+2),vtemp3(1)) +#ifdef MOMENT + call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1)) + call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) + s13d = (gtempd(1,1)+gtempd(2,2))*ss13 +#else + s13d=0.0d0 +#endif +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + gel_loc_turn6(i+1)=gel_loc_turn6(i+1) + & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) +#else + gel_loc_turn6(i+1)=gel_loc_turn6(i+1) + & -0.5d0*ekont*(s2d+s12d) +#endif +C Derivatives in gamma(i+4) + call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1)) + call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +#ifdef MOMENT + call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1)) + call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1)) + s13d = (gtempd(1,1)+gtempd(2,2))*ss13 +#else + s13d = 0.0d0 +#endif +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +C s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d) +#else + gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d) +#endif +C Derivatives in gamma(i+5) +#ifdef MOMENT + call transpose2(AEAderg(1,1,1),auxmatd(1,1)) + call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 +#else + s1d = 0.0d0 +#endif + call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1)) + call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1)) + s2d = scalar2(b1(1,itk),vtemp1d(1)) +#ifdef MOMENT + call transpose2(AEA(1,1,2),atempd(1,1)) + call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1)) + s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) +#else + s8d = 0.0d0 +#endif + call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +#ifdef MOMENT + call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1)) + ss13d = scalar2(b1(1,itk),vtemp4d(1)) + s13d = (gtemp(1,1)+gtemp(2,2))*ss13d +#else + s13d = 0.0d0 +#endif +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + gel_loc_turn6(i+3)=gel_loc_turn6(i+3) + & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) +#else + gel_loc_turn6(i+3)=gel_loc_turn6(i+3) + & -0.5d0*ekont*(s2d+s12d) +#endif +C Cartesian derivatives + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1)) + call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 +#else + s1d = 0.0d0 +#endif + call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1), + & vtemp1d(1)) + s2d = scalar2(b1(1,itk),vtemp1d(1)) +#ifdef MOMENT + call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1)) + call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1)) + s8d = -(atempd(1,1)+atempd(2,2))* + & scalar2(cc(1,1,itl),vtemp2(1)) +#else + s8d = 0.0d0 +#endif + call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2), + & auxmatd(1,1)) + call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) + & - 0.5d0*(s1d+s2d) +#else + derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) + & - 0.5d0*s2d +#endif +#ifdef MOMENT + derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) + & - 0.5d0*(s8d+s12d) +#else + derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) + & - 0.5d0*s12d +#endif + enddo + enddo + enddo +#ifdef MOMENT + do kkk=1,5 + do lll=1,3 + call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1), + & achuj_tempd(1,1)) + call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1)) + call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) + s13d=(gtempd(1,1)+gtempd(2,2))*ss13 + derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d + call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4), + & vtemp4d(1)) + ss13d = scalar2(b1(1,itk),vtemp4d(1)) + s13d = (gtemp(1,1)+gtemp(2,2))*ss13d + derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d + enddo + enddo +#endif +cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num', +cd & 16*eel_turn6_num +cd goto 1112 + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif + do ll=1,3 + ggg1(ll)=eel_turn6*g_contij(ll,1) + ggg2(ll)=eel_turn6*g_contij(ll,2) + ghalf=0.5d0*ggg1(ll) +cd ghalf=0.0d0 + gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf + & +ekont*derx_turn(ll,2,1) + gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1) + gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf + & +ekont*derx_turn(ll,4,1) + gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1) + ghalf=0.5d0*ggg2(ll) +cd ghalf=0.0d0 + gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf + & +ekont*derx_turn(ll,2,2) + gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2) + gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf + & +ekont*derx_turn(ll,4,2) + gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2) + enddo +cd goto 1112 + do m=i+1,j-1 + do ll=1,3 + gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll) + enddo + enddo + do m=k+1,l-1 + do ll=1,3 + gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll) + enddo + enddo +1112 continue + do m=i+2,j2 + do ll=1,3 + gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1) + enddo + enddo + do m=k+2,l2 + do ll=1,3 + gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2) + enddo + enddo +cd do iii=1,nres-3 +cd write (2,*) iii,g_corr6_loc(iii) +cd enddo + endif + eello_turn6=ekont*eel_turn6 +cd write (2,*) 'ekont',ekont +cd write (2,*) 'eel_turn6',ekont*eel_turn6 + return + end +crc------------------------------------------------- + SUBROUTINE MATVEC2(A1,V1,V2) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + DIMENSION A1(2,2),V1(2),V2(2) +c DO 1 I=1,2 +c VI=0.0 +c DO 3 K=1,2 +c 3 VI=VI+A1(I,K)*V1(K) +c Vaux(I)=VI +c 1 CONTINUE + + vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2) + vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2) + + v2(1)=vaux1 + v2(2)=vaux2 + END +C--------------------------------------- + SUBROUTINE MATMAT2(A1,A2,A3) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + DIMENSION A1(2,2),A2(2,2),A3(2,2) +c DIMENSION AI3(2,2) +c DO J=1,2 +c A3IJ=0.0 +c DO K=1,2 +c A3IJ=A3IJ+A1(I,K)*A2(K,J) +c enddo +c A3(I,J)=A3IJ +c enddo +c enddo + + ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1) + ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2) + ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1) + ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2) + + A3(1,1)=AI3_11 + A3(2,1)=AI3_21 + A3(1,2)=AI3_12 + A3(2,2)=AI3_22 + END + +c------------------------------------------------------------------------- + double precision function scalar2(u,v) + implicit none + double precision u(2),v(2) + double precision sc + integer i + scalar2=u(1)*v(1)+u(2)*v(2) + return + end + +C----------------------------------------------------------------------------- + + subroutine transpose2(a,at) + implicit none + double precision a(2,2),at(2,2) + at(1,1)=a(1,1) + at(1,2)=a(2,1) + at(2,1)=a(1,2) + at(2,2)=a(2,2) + return + end +c-------------------------------------------------------------------------- + subroutine transpose(n,a,at) + implicit none + integer n,i,j + double precision a(n,n),at(n,n) + do i=1,n + do j=1,n + at(j,i)=a(i,j) + enddo + enddo + return + end +C--------------------------------------------------------------------------- + subroutine prodmat3(a1,a2,kk,transp,prod) + implicit none + integer i,j + double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2) + logical transp +crc double precision auxmat(2,2),prod_(2,2) + + if (transp) then +crc call transpose2(kk(1,1),auxmat(1,1)) +crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1)) +crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) + + prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) + & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1) + prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) + & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2) + prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) + & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1) + prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) + & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2) + + else +crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1)) +crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) + + prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) + & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1) + prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) + & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2) + prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) + & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1) + prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) + & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2) + + endif +c call transpose2(a2(1,1),a2t(1,1)) + +crc print *,transp +crc print *,((prod_(i,j),i=1,2),j=1,2) +crc print *,((prod(i,j),i=1,2),j=1,2) + + return + end +C----------------------------------------------------------------------------- + double precision function scalar(u,v) + implicit none + double precision u(3),v(3) + double precision sc + integer i + sc=0.0d0 + do i=1,3 + sc=sc+u(i)*v(i) + enddo + scalar=sc + return + end + diff --git a/source/wham/src-NEWSC-NEWCORR/energy_p_new.F.org b/source/wham/src-NEWSC-NEWCORR/energy_p_new.F.org new file mode 100644 index 0000000..8f99a16 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/energy_p_new.F.org @@ -0,0 +1,6452 @@ + subroutine etotal(energia) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + + external proc_proc +#ifdef WINPGI +cMS$ATTRIBUTES C :: proc_proc +#endif + + include 'COMMON.IOUNITS' + double precision energia(0:max_ene),energia1(0:max_ene+1) +#ifdef MPL + include 'COMMON.INFO' + external d_vadd + integer ready +#endif + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' +cd write(iout, '(a,i2)')'Calling etotal ipot=',ipot +cd print *,'nnt=',nnt,' nct=',nct +C +C Compute the side-chain and electrostatic interaction energy +C + goto (101,102,103,104,105) ipot +C Lennard-Jones potential. + 101 call elj(evdw) +cd print '(a)','Exit ELJ' + goto 106 +C Lennard-Jones-Kihara potential (shifted). + 102 call eljk(evdw) + goto 106 +C Berne-Pechukas potential (dilated LJ, angular dependence). + 103 call ebp(evdw) + goto 106 +C Gay-Berne potential (shifted LJ, angular dependence). + 104 call egb(evdw) + goto 106 +C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). + 105 call egbv(evdw) +C +C Calculate electrostatic (H-bonding) energy of the main chain. +C + 106 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4) +C +C Calculate excluded-volume interaction energy between peptide groups +C and side chains. +C + call escp(evdw2,evdw2_14) +C +C Calculate the disulfide-bridge and other energy and the contributions +C from other distance constraints. +cd print *,'Calling EHPB' + call edis(ehpb) +cd print *,'EHPB exitted succesfully.' +C +C Calculate the virtual-bond-angle energy. +C + call ebend(ebe) +cd print *,'Bend energy finished.' +C +C Calculate the SC local energy. +C + call esc(escloc) +cd print *,'SCLOC energy finished.' +C +C Calculate the virtual-bond torsional energy. +C +cd print *,'nterm=',nterm + call etor(etors,edihcnstr) +C +C 6/23/01 Calculate double-torsional energy +C + call etor_d(etors_d) +C +C 12/1/95 Multi-body terms +C + n_corr=0 + n_corr1=0 + if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 + & .or. wturn6.gt.0.0d0) then +c print *,"calling multibody_eello" + call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1) +c write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1 +c print *,ecorr,ecorr5,ecorr6,eturn6 + endif + if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then + call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) + endif +C call multibody(ecorr) +C +C Sum the energies +C +C scale large componenets +#ifdef SCALE + ecorr5_scal=1000.0 + eel_loc_scal=100.0 + eello_turn3_scal=100.0 + eello_turn4_scal=100.0 + eturn6_scal=1000.0 + ecorr6_scal=1000.0 +#else + ecorr5_scal=1.0 + eel_loc_scal=1.0 + eello_turn3_scal=1.0 + eello_turn4_scal=1.0 + eturn6_scal=1.0 + ecorr6_scal=1.0 +#endif + + ecorr5=ecorr5/ecorr5_scal + eel_loc=eel_loc/eel_loc_scal + eello_turn3=eello_turn3/eello_turn3_scal + eello_turn4=eello_turn4/eello_turn4_scal + eturn6=eturn6/eturn6_scal + ecorr6=ecorr6/ecorr6_scal +#ifdef MPL + if (fgprocs.gt.1) then +cd call enerprint(evdw,evdw1,evdw2,ees,ebe,escloc,etors,ehpb, +cd & edihcnstr,ecorr,eel_loc,eello_turn4,etot) + energia(1)=evdw + energia(2)=evdw2 + energia(3)=ees + energia(4)=evdw1 + energia(5)=ecorr + energia(6)=etors + energia(7)=ebe + energia(8)=escloc + energia(9)=ehpb + energia(10)=edihcnstr + energia(11)=eel_loc + energia(12)=ecorr5 + energia(13)=ecorr6 + energia(14)=eello_turn3 + energia(15)=eello_turn4 + energia(16)=eturn6 + energia(17)=etors_d + msglen=80 + do i=1,15 + energia1(i)=energia(i) + enddo +cd write (iout,*) 'BossID=',BossID,' MyGroup=',MyGroup +cd write (*,*) 'BossID=',BossID,' MyGroup=',MyGroup +cd write (*,*) 'Processor',MyID,' calls MP_REDUCE in ENERGY', +cd & ' BossID=',BossID,' MyGroup=',MyGroup + call mp_reduce(energia1(1),energia(1),msglen,BossID,d_vadd, + & fgGroupID) +cd write (iout,*) 'Processor',MyID,' Reduce finished' + evdw=energia(1) + evdw2=energia(2) + ees=energia(3) + evdw1=energia(4) + ecorr=energia(5) + etors=energia(6) + ebe=energia(7) + escloc=energia(8) + ehpb=energia(9) + edihcnstr=energia(10) + eel_loc=energia(11) + ecorr5=energia(12) + ecorr6=energia(13) + eello_turn3=energia(14) + eello_turn4=energia(15) + eturn6=energia(16) + etors_d=energia(17) + endif +c if (MyID.eq.BossID) then +#endif + etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) + & +wang*ebe+wtor*etors+wscloc*escloc + & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5 + & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 + & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d + energia(0)=etot + energia(1)=evdw + energia(2)=evdw2 + energia(3)=ees+evdw1 + energia(4)=ecorr + energia(5)=ecorr5 + energia(6)=ecorr6 + energia(7)=eel_loc + energia(8)=eello_turn3 + energia(9)=eello_turn4 + energia(10)=eturn6 + energia(11)=ebe + energia(12)=escloc + energia(13)=etors + energia(14)=etors_d + energia(15)=ehpb + energia(16)=edihcnstr + energia(17)=evdw2_14 +c detecting NaNQ + i=0 +#ifdef WINPGI + idumm=proc_proc(etot,i) +#else + call proc_proc(etot,i) +#endif + if(i.eq.1)energia(0)=1.0d+99 +#ifdef MPL +c endif +#endif + if (calc_grad) then +C +C Sum up the components of the Cartesian gradient. +C + do i=1,nct + do j=1,3 + gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+ + & welec*gelc(j,i)+wstrain*ghpbc(j,i)+ + & wcorr*gradcorr(j,i)+ + & wel_loc*gel_loc(j,i)/eel_loc_scal+ + & wturn3*gcorr3_turn(j,i)/eello_turn3_scal+ + & wturn4*gcorr4_turn(j,i)/eello_turn4_scal+ + & wcorr5*gradcorr5(j,i)/ecorr5_scal+ + & wcorr6*gradcorr6(j,i)/ecorr6_scal+ + & wturn6*gcorr6_turn(j,i)/eturn6_scal + gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ + & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i) + enddo +cd print '(i3,9(1pe12.4))',i,(gvdwc(k,i),k=1,3),(gelc(k,i),k=1,3), +cd & (gradc(k,i),k=1,3) + enddo + + + do i=1,nres-3 +cd write (iout,*) i,g_corr5_loc(i) + gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) + & +wcorr5*g_corr5_loc(i)/ecorr5_scal + & +wcorr6*g_corr6_loc(i)/ecorr6_scal + & +wturn4*gel_loc_turn4(i)/eello_turn4_scal + & +wturn3*gel_loc_turn3(i)/eello_turn3_scal + & +wturn6*gel_loc_turn6(i)/eturn6_scal + & +wel_loc*gel_loc_loc(i)/eel_loc_scal + enddo + endif +cd print*,evdw,wsc,evdw2,wscp,ees+evdw1,welec,ebe,wang, +cd & escloc,wscloc,etors,wtor,ehpb,wstrain,nss,ebr,etot +cd call enerprint(energia(0)) +cd call intout +cd stop + return + end +C------------------------------------------------------------------------ + subroutine enerprint(energia) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + double precision energia(0:max_ene) + etot=energia(0) + evdw=energia(1) + evdw2=energia(2) + ees=energia(3) + ecorr=energia(4) + ecorr5=energia(5) + ecorr6=energia(6) + eel_loc=energia(7) + eello_turn3=energia(8) + eello_turn4=energia(9) + eello_turn6=energia(10) + ebe=energia(11) + escloc=energia(12) + etors=energia(13) + etors_d=energia(14) + ehpb=energia(15) + edihcnstr=energia(16) + write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,ebe,wang, + & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain, + & ecorr,wcorr, + & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3, + & eello_turn4,wturn4,eello_turn6,wturn6,edihcnstr,ebr*nss,etot + 10 format (/'Virtual-chain energies:'// + & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ + & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ + & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ + & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ + & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ + & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ + & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ + & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6, + & ' (SS bridges & dist. cnstr.)'/ + & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ + & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ + & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ + & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ + & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ + & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ + & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ + & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ + & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ + & 'ETOT= ',1pE16.6,' (total)') + return + end +C----------------------------------------------------------------------- + subroutine elj(evdw) +C +C This subroutine calculates the interaction energy of nonbonded side chains +C assuming the LJ potential of interaction. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + parameter (accur=1.0d-10) + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.TORSION' + include 'COMMON.ENEPS' + include 'COMMON.SBRIDGE' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.CONTACTS' + dimension gg(3) + integer icant + external icant +cd print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon + do i=1,210 + do j=1,2 + eneps_temp(j,i)=0.0d0 + enddo + enddo + evdw=0.0D0 + do i=iatsc_s,iatsc_e + itypi=itype(i) + itypi1=itype(i+1) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) +C Change 12/1/95 + num_conti=0 +C +C Calculate SC interaction energy. +C + do iint=1,nint_gr(i) +cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), +cd & 'iend=',iend(i,iint) + do j=istart(i,iint),iend(i,iint) + itypj=itype(j) + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi +C Change 12/1/95 to calculate four-body interactions + rij=xj*xj+yj*yj+zj*zj + rrij=1.0D0/rij +c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj + eps0ij=eps(itypi,itypj) + fac=rrij**expon2 + e1=fac*fac*aa(itypi,itypj) + e2=fac*bb(itypi,itypj) + evdwij=e1+e2 + ij=icant(itypi,itypj) + eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij) + eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij +cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) +cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj) +cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)') +cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), +cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm, +cd & (c(k,i),k=1,3),(c(k,j),k=1,3) + evdw=evdw+evdwij + if (calc_grad) then +C +C Calculate the components of the gradient in DC and X +C + fac=-rrij*(e1+evdwij) + gg(1)=xj*fac + gg(2)=yj*fac + gg(3)=zj*fac + do k=1,3 + gvdwx(k,i)=gvdwx(k,i)-gg(k) + gvdwx(k,j)=gvdwx(k,j)+gg(k) + enddo + do k=i,j-1 + do l=1,3 + gvdwc(l,k)=gvdwc(l,k)+gg(l) + enddo + enddo + endif +C +C 12/1/95, revised on 5/20/97 +C +C Calculate the contact function. The ith column of the array JCONT will +C contain the numbers of atoms that make contacts with the atom I (of numbers +C greater than I). The arrays FACONT and GACONT will contain the values of +C the contact function and its derivative. +C +C Uncomment next line, if the correlation interactions include EVDW explicitly. +c if (j.gt.i+1 .and. evdwij.le.0.0D0) then +C Uncomment next line, if the correlation interactions are contact function only + if (j.gt.i+1.and. eps0ij.gt.0.0D0) then + rij=dsqrt(rij) + sigij=sigma(itypi,itypj) + r0ij=rs0(itypi,itypj) +C +C Check whether the SC's are not too far to make a contact. +C + rcut=1.5d0*r0ij + call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont) +C Add a new contact, if the SC's are close enough, but not too close (ri' + do k=1,3 + ggg(k)=-ggg(k) +C Uncomment following line for SC-p interactions +c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) + enddo + endif + do k=1,3 + gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) + enddo + kstart=min0(i+1,j) + kend=max0(i-1,j-1) +cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend +cd write (iout,*) ggg(1),ggg(2),ggg(3) + do k=kstart,kend + do l=1,3 + gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) + enddo + enddo + endif + enddo + enddo ! iint + 1225 continue + enddo ! i + do i=1,nct + do j=1,3 + gvdwc_scp(j,i)=expon*gvdwc_scp(j,i) + gradx_scp(j,i)=expon*gradx_scp(j,i) + enddo + enddo +C****************************************************************************** +C +C N O T E !!! +C +C To save time the factor EXPON has been extracted from ALL components +C of GVDWC and GRADX. Remember to multiply them by this factor before further +C use! +C +C****************************************************************************** + return + end +C-------------------------------------------------------------------------- + subroutine edis(ehpb) +C +C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + dimension ggg(3) + ehpb=0.0D0 +cd print *,'edis: nhpb=',nhpb,' fbr=',fbr +cd print *,'link_start=',link_start,' link_end=',link_end + if (link_end.eq.0) return + do i=link_start,link_end +C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a +C CA-CA distance used in regularization of structure. + ii=ihpb(i) + jj=jhpb(i) +C iii and jjj point to the residues for which the distance is assigned. + if (ii.gt.nres) then + iii=ii-nres + jjj=jj-nres + else + iii=ii + jjj=jj + endif +C Calculate the distance between the two points and its difference from the +C target distance. + dd=dist(ii,jj) + rdis=dd-dhpb(i) +C Get the force constant corresponding to this distance. + waga=forcon(i) +C Calculate the contribution to energy. + ehpb=ehpb+waga*rdis*rdis +C +C Evaluate gradient. +C + fac=waga*rdis/dd +cd print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd, +cd & ' waga=',waga,' fac=',fac + do j=1,3 + ggg(j)=fac*(c(j,jj)-c(j,ii)) + enddo +cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3) +C If this is a SC-SC distace, we need to calculate the contributions to the +C Cartesian gradient in the SC vectors (ghpbx). + if (iii.lt.ii) then + do j=1,3 + ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) + ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) + enddo + endif + do j=iii,jjj-1 + do k=1,3 + ghpbc(k,j)=ghpbc(k,j)+ggg(k) + enddo + enddo + enddo + ehpb=0.5D0*ehpb + return + end +C-------------------------------------------------------------------------- + subroutine ebend(etheta) +C +C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral +C angles gamma and its derivatives in consecutive thetas and gammas. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + common /calcthet/ term1,term2,termm,diffak,ratak, + & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, + & delthe0,sig0inv,sigtc,sigsqtc,delthec,it + double precision y(2),z(2) + delta=0.02d0*pi + time11=dexp(-2*time) + time12=1.0d0 + etheta=0.0D0 +c write (iout,*) "nres",nres +c write (*,'(a,i2)') 'EBEND ICG=',icg +c write (iout,*) ithet_start,ithet_end + do i=ithet_start,ithet_end +C Zero the energy function and its derivative at 0 or pi. + call splinthet(theta(i),0.5d0*delta,ss,ssd) + it=itype(i-1) + if (i.gt.ithet_start .and. + & (itel(i-1).eq.0 .or. itel(i-2).eq.0)) goto 1215 + if (i.gt.3 .and. (i.le.4 .or. itel(i-3).ne.0)) then + phii=phi(i) + y(1)=dcos(phii) + y(2)=dsin(phii) + else + y(1)=0.0D0 + y(2)=0.0D0 + endif + if (i.lt.nres .and. itel(i).ne.0) then + phii1=phi(i+1) + z(1)=dcos(phii1) + z(2)=dsin(phii1) + else + z(1)=0.0D0 + z(2)=0.0D0 + endif +C Calculate the "mean" value of theta from the part of the distribution +C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2). +C In following comments this theta will be referred to as t_c. + thet_pred_mean=0.0d0 + do k=1,2 + athetk=athet(k,it) + bthetk=bthet(k,it) + thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k) + enddo +c write (iout,*) "thet_pred_mean",thet_pred_mean + dthett=thet_pred_mean*ssd + thet_pred_mean=thet_pred_mean*ss+a0thet(it) +c write (iout,*) "thet_pred_mean",thet_pred_mean +C Derivatives of the "mean" values in gamma1 and gamma2. + dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss + dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss + if (theta(i).gt.pi-delta) then + call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0, + & E_tc0) + call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0) + call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1) + call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai, + & E_theta) + call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0, + & E_tc) + else if (theta(i).lt.delta) then + call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0) + call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1) + call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai, + & E_theta) + call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0) + call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0, + & E_tc) + else + call theteng(theta(i),thet_pred_mean,theta0(it),ethetai, + & E_theta,E_tc) + endif + etheta=etheta+ethetai +c write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i), +c & rad2deg*phii,rad2deg*phii1,ethetai + if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1 + if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2 + gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett) + 1215 continue + enddo +C Ufff.... We've done all this!!! + return + end +C--------------------------------------------------------------------------- + subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta, + & E_tc) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /calcthet/ term1,term2,termm,diffak,ratak, + & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, + & delthe0,sig0inv,sigtc,sigsqtc,delthec,it +C Calculate the contributions to both Gaussian lobes. +C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time) +C The "polynomial part" of the "standard deviation" of this part of +C the distribution. + sig=polthet(3,it) + do j=2,0,-1 + sig=sig*thet_pred_mean+polthet(j,it) + enddo +C Derivative of the "interior part" of the "standard deviation of the" +C gamma-dependent Gaussian lobe in t_c. + sigtc=3*polthet(3,it) + do j=2,1,-1 + sigtc=sigtc*thet_pred_mean+j*polthet(j,it) + enddo + sigtc=sig*sigtc +C Set the parameters of both Gaussian lobes of the distribution. +C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc) + fac=sig*sig+sigc0(it) + sigcsq=fac+fac + sigc=1.0D0/sigcsq +C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c + sigsqtc=-4.0D0*sigcsq*sigtc +c print *,i,sig,sigtc,sigsqtc +C Following variable (sigtc) is d[sigma(t_c)]/dt_c + sigtc=-sigtc/(fac*fac) +C Following variable is sigma(t_c)**(-2) + sigcsq=sigcsq*sigcsq + sig0i=sig0(it) + sig0inv=1.0D0/sig0i**2 + delthec=thetai-thet_pred_mean + delthe0=thetai-theta0i + term1=-0.5D0*sigcsq*delthec*delthec + term2=-0.5D0*sig0inv*delthe0*delthe0 +C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and +C NaNs in taking the logarithm. We extract the largest exponent which is added +C to the energy (this being the log of the distribution) at the end of energy +C term evaluation for this virtual-bond angle. + if (term1.gt.term2) then + termm=term1 + term2=dexp(term2-termm) + term1=1.0d0 + else + termm=term2 + term1=dexp(term1-termm) + term2=1.0d0 + endif +C The ratio between the gamma-independent and gamma-dependent lobes of +C the distribution is a Gaussian function of thet_pred_mean too. + diffak=gthet(2,it)-thet_pred_mean + ratak=diffak/gthet(3,it)**2 + ak=dexp(gthet(1,it)-0.5D0*diffak*ratak) +C Let's differentiate it in thet_pred_mean NOW. + aktc=ak*ratak +C Now put together the distribution terms to make complete distribution. + termexp=term1+ak*term2 + termpre=sigc+ak*sig0i +C Contribution of the bending energy from this theta is just the -log of +C the sum of the contributions from the two lobes and the pre-exponential +C factor. Simple enough, isn't it? + ethetai=(-dlog(termexp)-termm+dlog(termpre)) +C NOW the derivatives!!! +C 6/6/97 Take into account the deformation. + E_theta=(delthec*sigcsq*term1 + & +ak*delthe0*sig0inv*term2)/termexp + E_tc=((sigtc+aktc*sig0i)/termpre + & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ + & aktc*term2)/termexp) + return + end +c----------------------------------------------------------------------------- + subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /calcthet/ term1,term2,termm,diffak,ratak, + & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, + & delthe0,sig0inv,sigtc,sigsqtc,delthec,it + delthec=thetai-thet_pred_mean + delthe0=thetai-theta0i +C "Thank you" to MAPLE (probably spared one day of hand-differentiation). + t3 = thetai-thet_pred_mean + t6 = t3**2 + t9 = term1 + t12 = t3*sigcsq + t14 = t12+t6*sigsqtc + t16 = 1.0d0 + t21 = thetai-theta0i + t23 = t21**2 + t26 = term2 + t27 = t21*t26 + t32 = termexp + t40 = t32**2 + E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 + & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 + & *(-t12*t9-ak*sig0inv*t27) + return + end +c----------------------------------------------------------------------------- + subroutine esc(escloc) +C Calculate the local energy of a side chain and its derivatives in the +C corresponding virtual-bond valence angles THETA and the spherical angles +C ALPHA and OMEGA. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3), + & ddersc0(3),ddummy(3),xtemp(3),temp(3) + common /sccalc/ time11,time12,time112,theti,it,nlobit + delta=0.02d0*pi + escloc=0.0D0 +c write (iout,'(a)') 'ESC' + do i=loc_start,loc_end + it=itype(i) + if (it.eq.10) goto 1 + nlobit=nlob(it) +c print *,'i=',i,' it=',it,' nlobit=',nlobit +c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad + theti=theta(i+1)-pipol + x(1)=dtan(theti) + x(2)=alph(i) + x(3)=omeg(i) + + if (x(2).gt.pi-delta) then + xtemp(1)=x(1) + xtemp(2)=pi-delta + xtemp(3)=x(3) + call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) + xtemp(2)=pi + call enesc(xtemp,escloci1,dersc1,ddummy,.false.) + call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2), + & escloci,dersc(2)) + call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), + & ddersc0(1),dersc(1)) + call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3), + & ddersc0(3),dersc(3)) + xtemp(2)=pi-delta + call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) + xtemp(2)=pi + call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) + call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1, + & dersc0(2),esclocbi,dersc02) + call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), + & dersc12,dersc01) + call splinthet(x(2),0.5d0*delta,ss,ssd) + dersc0(1)=dersc01 + dersc0(2)=dersc02 + dersc0(3)=0.0d0 + do k=1,3 + dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) + enddo + dersc(2)=dersc(2)+ssd*(escloci-esclocbi) +c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, +c & esclocbi,ss,ssd + escloci=ss*escloci+(1.0d0-ss)*esclocbi +c escloci=esclocbi +c write (iout,*) escloci + else if (x(2).lt.delta) then + xtemp(1)=x(1) + xtemp(2)=delta + xtemp(3)=x(3) + call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) + xtemp(2)=0.0d0 + call enesc(xtemp,escloci1,dersc1,ddummy,.false.) + call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2), + & escloci,dersc(2)) + call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), + & ddersc0(1),dersc(1)) + call spline2(x(2),delta,-delta,dersc0(3),dersc1(3), + & ddersc0(3),dersc(3)) + xtemp(2)=delta + call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) + xtemp(2)=0.0d0 + call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) + call spline1(x(2),delta,-delta,esclocbi0,esclocbi1, + & dersc0(2),esclocbi,dersc02) + call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), + & dersc12,dersc01) + dersc0(1)=dersc01 + dersc0(2)=dersc02 + dersc0(3)=0.0d0 + call splinthet(x(2),0.5d0*delta,ss,ssd) + do k=1,3 + dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) + enddo + dersc(2)=dersc(2)+ssd*(escloci-esclocbi) +c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, +c & esclocbi,ss,ssd + escloci=ss*escloci+(1.0d0-ss)*esclocbi +c write (iout,*) escloci + else + call enesc(x,escloci,dersc,ddummy,.false.) + endif + + escloc=escloc+escloci +c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc + + gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ + & wscloc*dersc(1) + gloc(ialph(i,1),icg)=wscloc*dersc(2) + gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3) + 1 continue + enddo + return + end +C--------------------------------------------------------------------------- + subroutine enesc(x,escloci,dersc,ddersc,mixed) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /sccalc/ time11,time12,time112,theti,it,nlobit + double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3) + double precision contr(maxlob,-1:1) + logical mixed +c write (iout,*) 'it=',it,' nlobit=',nlobit + escloc_i=0.0D0 + do j=1,3 + dersc(j)=0.0D0 + if (mixed) ddersc(j)=0.0d0 + enddo + x3=x(3) + +C Because of periodicity of the dependence of the SC energy in omega we have +C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi). +C To avoid underflows, first compute & store the exponents. + + do iii=-1,1 + + x(3)=x3+iii*dwapi + + do j=1,nlobit + do k=1,3 + z(k)=x(k)-censc(k,j,it) + enddo + do k=1,3 + Axk=0.0D0 + do l=1,3 + Axk=Axk+gaussc(l,k,j,it)*z(l) + enddo + Ax(k,j,iii)=Axk + enddo + expfac=0.0D0 + do k=1,3 + expfac=expfac+Ax(k,j,iii)*z(k) + enddo + contr(j,iii)=expfac + enddo ! j + + enddo ! iii + + x(3)=x3 +C As in the case of ebend, we want to avoid underflows in exponentiation and +C subsequent NaNs and INFs in energy calculation. +C Find the largest exponent + emin=contr(1,-1) + do iii=-1,1 + do j=1,nlobit + if (emin.gt.contr(j,iii)) emin=contr(j,iii) + enddo + enddo + emin=0.5D0*emin +cd print *,'it=',it,' emin=',emin + +C Compute the contribution to SC energy and derivatives + do iii=-1,1 + + do j=1,nlobit + expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin) +cd print *,'j=',j,' expfac=',expfac + escloc_i=escloc_i+expfac + do k=1,3 + dersc(k)=dersc(k)+Ax(k,j,iii)*expfac + enddo + if (mixed) then + do k=1,3,2 + ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) + & +gaussc(k,2,j,it))*expfac + enddo + endif + enddo + + enddo ! iii + + dersc(1)=dersc(1)/cos(theti)**2 + ddersc(1)=ddersc(1)/cos(theti)**2 + ddersc(3)=ddersc(3) + + escloci=-(dlog(escloc_i)-emin) + do j=1,3 + dersc(j)=dersc(j)/escloc_i + enddo + if (mixed) then + do j=1,3,2 + ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j)) + enddo + endif + return + end +C------------------------------------------------------------------------------ + subroutine enesc_bound(x,escloci,dersc,dersc12,mixed) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /sccalc/ time11,time12,time112,theti,it,nlobit + double precision x(3),z(3),Ax(3,maxlob),dersc(3) + double precision contr(maxlob) + logical mixed + + escloc_i=0.0D0 + + do j=1,3 + dersc(j)=0.0D0 + enddo + + do j=1,nlobit + do k=1,2 + z(k)=x(k)-censc(k,j,it) + enddo + z(3)=dwapi + do k=1,3 + Axk=0.0D0 + do l=1,3 + Axk=Axk+gaussc(l,k,j,it)*z(l) + enddo + Ax(k,j)=Axk + enddo + expfac=0.0D0 + do k=1,3 + expfac=expfac+Ax(k,j)*z(k) + enddo + contr(j)=expfac + enddo ! j + +C As in the case of ebend, we want to avoid underflows in exponentiation and +C subsequent NaNs and INFs in energy calculation. +C Find the largest exponent + emin=contr(1) + do j=1,nlobit + if (emin.gt.contr(j)) emin=contr(j) + enddo + emin=0.5D0*emin + +C Compute the contribution to SC energy and derivatives + + dersc12=0.0d0 + do j=1,nlobit + expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin) + escloc_i=escloc_i+expfac + do k=1,2 + dersc(k)=dersc(k)+Ax(k,j)*expfac + enddo + if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) + & +gaussc(1,2,j,it))*expfac + dersc(3)=0.0d0 + enddo + + dersc(1)=dersc(1)/cos(theti)**2 + dersc12=dersc12/cos(theti)**2 + escloci=-(dlog(escloc_i)-emin) + do j=1,2 + dersc(j)=dersc(j)/escloc_i + enddo + if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1)) + return + end +c------------------------------------------------------------------------------ + subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont) +C +C This procedure calculates two-body contact function g(rij) and its derivative: +C +C eps0ij ! x < -1 +C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1 +C 0 ! x > 1 +C +C where x=(rij-r0ij)/delta +C +C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy +C + implicit none + double precision rij,r0ij,eps0ij,fcont,fprimcont + double precision x,x2,x4,delta +c delta=0.02D0*r0ij +c delta=0.2D0*r0ij + x=(rij-r0ij)/delta + if (x.lt.-1.0D0) then + fcont=eps0ij + fprimcont=0.0D0 + else if (x.le.1.0D0) then + x2=x*x + x4=x2*x2 + fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0) + fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta + else + fcont=0.0D0 + fprimcont=0.0D0 + endif + return + end +c------------------------------------------------------------------------------ + subroutine splinthet(theti,delta,ss,ssder) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.GEO' + thetup=pi-delta + thetlow=delta + if (theti.gt.pipol) then + call gcont(theti,thetup,1.0d0,delta,ss,ssder) + else + call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder) + ssder=-ssder + endif + return + end +c------------------------------------------------------------------------------ + subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim) + implicit none + double precision x,x0,delta,f0,f1,fprim0,f,fprim + double precision ksi,ksi2,ksi3,a1,a2,a3 + a1=fprim0*delta/(f1-f0) + a2=3.0d0-2.0d0*a1 + a3=a1-2.0d0 + ksi=(x-x0)/delta + ksi2=ksi*ksi + ksi3=ksi2*ksi + f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi)) + fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3)) + return + end +c------------------------------------------------------------------------------ + subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx) + implicit none + double precision x,x0,delta,f0x,f1x,fprim0x,fx + double precision ksi,ksi2,ksi3,a1,a2,a3 + ksi=(x-x0)/delta + ksi2=ksi*ksi + ksi3=ksi2*ksi + a1=fprim0x*delta + a2=3*(f1x-f0x)-2*fprim0x*delta + a3=fprim0x*delta-2*(f1x-f0x) + fx=f0x+a1*ksi+a2*ksi2+a3*ksi3 + return + end +C----------------------------------------------------------------------------- +#ifdef CRYST_TOR +C----------------------------------------------------------------------------- + subroutine etor(etors,edihcnstr) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. + etors=0.0D0 + do i=iphi_start,iphi_end + itori=itortyp(itype(i-2)) + itori1=itortyp(itype(i-1)) + phii=phi(i) + gloci=0.0D0 +C Proline-Proline pair is a special case... + if (itori.eq.3 .and. itori1.eq.3) then + if (phii.gt.-dwapi3) then + cosphi=dcos(3*phii) + fac=1.0D0/(1.0D0-cosphi) + etorsi=v1(1,3,3)*fac + etorsi=etorsi+etorsi + etors=etors+etorsi-v1(1,3,3) + gloci=gloci-3*fac*etorsi*dsin(3*phii) + endif + do j=1,3 + v1ij=v1(j+1,itori,itori1) + v2ij=v2(j+1,itori,itori1) + cosphi=dcos(j*phii) + sinphi=dsin(j*phii) + etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo + else + do j=1,nterm_old + v1ij=v1(j,itori,itori1) + v2ij=v2(j,itori,itori1) + cosphi=dcos(j*phii) + sinphi=dsin(j*phii) + etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo + endif + if (lprn) + & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') + & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, + & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6) + gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci +c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) + enddo +! 6/20/98 - dihedral angle constraints + edihcnstr=0.0d0 + do i=1,ndih_constr + itori=idih_constr(i) + phii=phi(itori) + difi=phii-phi0(i) + if (difi.gt.drange(i)) then + difi=difi-drange(i) + edihcnstr=edihcnstr+0.25d0*ftors*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 + else if (difi.lt.-drange(i)) then + difi=difi+drange(i) + edihcnstr=edihcnstr+0.25d0*ftors*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 + endif +! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii, +! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) + enddo +! write (iout,*) 'edihcnstr',edihcnstr + return + end +c------------------------------------------------------------------------------ +#else + subroutine etor(etors,edihcnstr) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. + etors=0.0D0 + do i=iphi_start,iphi_end + if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215 + itori=itortyp(itype(i-2)) + itori1=itortyp(itype(i-1)) + phii=phi(i) + gloci=0.0D0 +C Regular cosine and sine terms + do j=1,nterm(itori,itori1) + v1ij=v1(j,itori,itori1) + v2ij=v2(j,itori,itori1) + cosphi=dcos(j*phii) + sinphi=dsin(j*phii) + etors=etors+v1ij*cosphi+v2ij*sinphi + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo +C Lorentz terms +C v1 +C E = SUM ----------------------------------- - v1 +C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1 +C + cosphi=dcos(0.5d0*phii) + sinphi=dsin(0.5d0*phii) + do j=1,nlor(itori,itori1) + vl1ij=vlor1(j,itori,itori1) + vl2ij=vlor2(j,itori,itori1) + vl3ij=vlor3(j,itori,itori1) + pom=vl2ij*cosphi+vl3ij*sinphi + pom1=1.0d0/(pom*pom+1.0d0) + etors=etors+vl1ij*pom1 + pom=-pom*pom1*pom1 + gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom + enddo +C Subtract the constant term + etors=etors-v0(itori,itori1) + if (lprn) + & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') + & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, + & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6) + gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci +c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) + 1215 continue + enddo +! 6/20/98 - dihedral angle constraints + edihcnstr=0.0d0 + do i=1,ndih_constr + print *,"i",i + itori=idih_constr(i) + phii=phi(itori) + difi=phii-phi0(i) + if (difi.gt.drange(i)) then + difi=difi-drange(i) + edihcnstr=edihcnstr+0.25d0*ftors*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 + else if (difi.lt.-drange(i)) then + difi=difi+drange(i) + edihcnstr=edihcnstr+0.25d0*ftors*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 + endif +! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii, +! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) + enddo +! write (iout,*) 'edihcnstr',edihcnstr + return + end +c---------------------------------------------------------------------------- + subroutine etor_d(etors_d) +C 6/23/01 Compute double torsional energy + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. + etors_d=0.0D0 + do i=iphi_start,iphi_end-1 + if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0) + & goto 1215 + itori=itortyp(itype(i-2)) + itori1=itortyp(itype(i-1)) + itori2=itortyp(itype(i)) + phii=phi(i) + phii1=phi(i+1) + gloci1=0.0D0 + gloci2=0.0D0 +C Regular cosine and sine terms + do j=1,ntermd_1(itori,itori1,itori2) + v1cij=v1c(1,j,itori,itori1,itori2) + v1sij=v1s(1,j,itori,itori1,itori2) + v2cij=v1c(2,j,itori,itori1,itori2) + v2sij=v1s(2,j,itori,itori1,itori2) + cosphi1=dcos(j*phii) + sinphi1=dsin(j*phii) + cosphi2=dcos(j*phii1) + sinphi2=dsin(j*phii1) + etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ + & v2cij*cosphi2+v2sij*sinphi2 + gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1) + gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2) + enddo + do k=2,ntermd_2(itori,itori1,itori2) + do l=1,k-1 + v1cdij = v2c(k,l,itori,itori1,itori2) + v2cdij = v2c(l,k,itori,itori1,itori2) + v1sdij = v2s(k,l,itori,itori1,itori2) + v2sdij = v2s(l,k,itori,itori1,itori2) + cosphi1p2=dcos(l*phii+(k-l)*phii1) + cosphi1m2=dcos(l*phii-(k-l)*phii1) + sinphi1p2=dsin(l*phii+(k-l)*phii1) + sinphi1m2=dsin(l*phii-(k-l)*phii1) + etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ + & v1sdij*sinphi1p2+v2sdij*sinphi1m2 + gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 + & -v1cdij*sinphi1p2-v2cdij*sinphi1m2) + gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 + & -v1cdij*sinphi1p2+v2cdij*sinphi1m2) + enddo + enddo + gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1 + gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2 + 1215 continue + enddo + return + end +#endif +c------------------------------------------------------------------------------ + subroutine multibody(ecorr) +C This subroutine calculates multi-body contributions to energy following +C the idea of Skolnick et al. If side chains I and J make a contact and +C at the same time side chains I+1 and J+1 make a contact, an extra +C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + double precision gx(3),gx1(3) + logical lprn + +C Set lprn=.true. for debugging + lprn=.false. + + if (lprn) then + write (iout,'(a)') 'Contact function values:' + do i=nnt,nct-2 + write (iout,'(i2,20(1x,i2,f10.5))') + & i,(jcont(j,i),facont(j,i),j=1,num_cont(i)) + enddo + endif + ecorr=0.0D0 + do i=nnt,nct + do j=1,3 + gradcorr(j,i)=0.0D0 + gradxorr(j,i)=0.0D0 + enddo + enddo + do i=nnt,nct-2 + + DO ISHIFT = 3,4 + + i1=i+ishift + num_conti=num_cont(i) + num_conti1=num_cont(i1) + do jj=1,num_conti + j=jcont(jj,i) + do kk=1,num_conti1 + j1=jcont(kk,i1) + if (j1.eq.j+ishift .or. j1.eq.j-ishift) then +cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1, +cd & ' ishift=',ishift +C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously. +C The system gains extra energy. + ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk) + endif ! j1==j+-ishift + enddo ! kk + enddo ! jj + + ENDDO ! ISHIFT + + enddo ! i + return + end +c------------------------------------------------------------------------------ + double precision function esccorr(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + double precision gx(3),gx1(3) + logical lprn + lprn=.false. + eij=facont(jj,i) + ekl=facont(kk,k) +cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl +C Calculate the multi-body contribution to energy. +C Calculate multi-body contributions to the gradient. +cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3), +cd & k,l,(gacont(m,kk,k),m=1,3) + do m=1,3 + gx(m) =ekl*gacont(m,jj,i) + gx1(m)=eij*gacont(m,kk,k) + gradxorr(m,i)=gradxorr(m,i)-gx(m) + gradxorr(m,j)=gradxorr(m,j)+gx(m) + gradxorr(m,k)=gradxorr(m,k)-gx1(m) + gradxorr(m,l)=gradxorr(m,l)+gx1(m) + enddo + do m=i,j-1 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+gx(ll) + enddo + enddo + do m=k,l-1 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll) + enddo + enddo + esccorr=-eij*ekl + return + end +c------------------------------------------------------------------------------ +#ifdef MPL + subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + integer dimen1,dimen2,atom,indx + double precision buffer(dimen1,dimen2) + double precision zapas + common /contacts_hb/ zapas(3,20,maxres,7), + & facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres), + & num_cont_hb(maxres),jcont_hb(20,maxres) + num_kont=num_cont_hb(atom) + do i=1,num_kont + do k=1,7 + do j=1,3 + buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k) + enddo ! j + enddo ! k + buffer(i,indx+22)=facont_hb(i,atom) + buffer(i,indx+23)=ees0p(i,atom) + buffer(i,indx+24)=ees0m(i,atom) + buffer(i,indx+25)=dfloat(jcont_hb(i,atom)) + enddo ! i + buffer(1,indx+26)=dfloat(num_kont) + return + end +c------------------------------------------------------------------------------ + subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + integer dimen1,dimen2,atom,indx + double precision buffer(dimen1,dimen2) + double precision zapas + common /contacts_hb/ zapas(3,20,maxres,7), + & facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres), + & num_cont_hb(maxres),jcont_hb(20,maxres) + num_kont=buffer(1,indx+26) + num_kont_old=num_cont_hb(atom) + num_cont_hb(atom)=num_kont+num_kont_old + do i=1,num_kont + ii=i+num_kont_old + do k=1,7 + do j=1,3 + zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j) + enddo ! j + enddo ! k + facont_hb(ii,atom)=buffer(i,indx+22) + ees0p(ii,atom)=buffer(i,indx+23) + ees0m(ii,atom)=buffer(i,indx+24) + jcont_hb(ii,atom)=buffer(i,indx+25) + enddo ! i + return + end +c------------------------------------------------------------------------------ +#endif + subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) +C This subroutine calculates multi-body contributions to hydrogen-bonding + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' +#ifdef MPL + include 'COMMON.INFO' +#endif + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' +#ifdef MPL + parameter (max_cont=maxconts) + parameter (max_dim=2*(8*3+2)) + parameter (msglen1=max_cont*max_dim*4) + parameter (msglen2=2*msglen1) + integer source,CorrelType,CorrelID,Error + double precision buffer(max_cont,max_dim) +#endif + double precision gx(3),gx1(3) + logical lprn,ldone + +C Set lprn=.true. for debugging + lprn=.false. +#ifdef MPL + n_corr=0 + n_corr1=0 + if (fgProcs.le.1) goto 30 + if (lprn) then + write (iout,'(a)') 'Contact function values:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i2,f5.2))') + & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), + & j=1,num_cont_hb(i)) + enddo + endif +C Caution! Following code assumes that electrostatic interactions concerning +C a given atom are split among at most two processors! + CorrelType=477 + CorrelID=MyID+1 + ldone=.false. + do i=1,max_cont + do j=1,max_dim + buffer(i,j)=0.0D0 + enddo + enddo + mm=mod(MyRank,2) +cd write (iout,*) 'MyRank',MyRank,' mm',mm + if (mm) 20,20,10 + 10 continue +cd write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone + if (MyRank.gt.0) then +C Send correlation contributions to the preceding processor + msglen=msglen1 + nn=num_cont_hb(iatel_s) + call pack_buffer(max_cont,max_dim,iatel_s,0,buffer) +cd write (iout,*) 'The BUFFER array:' +cd do i=1,nn +cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26) +cd enddo + if (ielstart(iatel_s).gt.iatel_s+ispp) then + msglen=msglen2 + call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer) +C Clear the contacts of the atom passed to the neighboring processor + nn=num_cont_hb(iatel_s+1) +cd do i=1,nn +cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26) +cd enddo + num_cont_hb(iatel_s)=0 + endif +cd write (iout,*) 'Processor ',MyID,MyRank, +cd & ' is sending correlation contribution to processor',MyID-1, +cd & ' msglen=',msglen +cd write (*,*) 'Processor ',MyID,MyRank, +cd & ' is sending correlation contribution to processor',MyID-1, +cd & ' msglen=',msglen,' CorrelType=',CorrelType + call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID) +cd write (iout,*) 'Processor ',MyID, +cd & ' has sent correlation contribution to processor',MyID-1, +cd & ' msglen=',msglen,' CorrelID=',CorrelID +cd write (*,*) 'Processor ',MyID, +cd & ' has sent correlation contribution to processor',MyID-1, +cd & ' msglen=',msglen,' CorrelID=',CorrelID + msglen=msglen1 + endif ! (MyRank.gt.0) + if (ldone) goto 30 + ldone=.true. + 20 continue +cd write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone + if (MyRank.lt.fgProcs-1) then +C Receive correlation contributions from the next processor + msglen=msglen1 + if (ielend(iatel_e).lt.nct-1) msglen=msglen2 +cd write (iout,*) 'Processor',MyID, +cd & ' is receiving correlation contribution from processor',MyID+1, +cd & ' msglen=',msglen,' CorrelType=',CorrelType +cd write (*,*) 'Processor',MyID, +cd & ' is receiving correlation contribution from processor',MyID+1, +cd & ' msglen=',msglen,' CorrelType=',CorrelType + nbytes=-1 + do while (nbytes.le.0) + call mp_probe(MyID+1,CorrelType,nbytes) + enddo +cd print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes + call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes) +cd write (iout,*) 'Processor',MyID, +cd & ' has received correlation contribution from processor',MyID+1, +cd & ' msglen=',msglen,' nbytes=',nbytes +cd write (iout,*) 'The received BUFFER array:' +cd do i=1,max_cont +cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52) +cd enddo + if (msglen.eq.msglen1) then + call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer) + else if (msglen.eq.msglen2) then + call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer) + call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer) + else + write (iout,*) + & 'ERROR!!!! message length changed while processing correlations.' + write (*,*) + & 'ERROR!!!! message length changed while processing correlations.' + call mp_stopall(Error) + endif ! msglen.eq.msglen1 + endif ! MyRank.lt.fgProcs-1 + if (ldone) goto 30 + ldone=.true. + goto 10 + 30 continue +#endif + if (lprn) then + write (iout,'(a)') 'Contact function values:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i2,f5.2))') + & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), + & j=1,num_cont_hb(i)) + enddo + endif + ecorr=0.0D0 +C Remove the loop below after debugging !!! + do i=nnt,nct + do j=1,3 + gradcorr(j,i)=0.0D0 + gradxorr(j,i)=0.0D0 + enddo + enddo +C Calculate the local-electrostatic correlation terms + do i=iatel_s,iatel_e+1 + i1=i+1 + num_conti=num_cont_hb(i) + num_conti1=num_cont_hb(i+1) + do jj=1,num_conti + j=jcont_hb(jj,i) + do kk=1,num_conti1 + j1=jcont_hb(kk,i1) +c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk + if (j1.eq.j+1 .or. j1.eq.j-1) then +C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. +C The system gains extra energy. + ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0) + n_corr=n_corr+1 + else if (j1.eq.j) then +C Contacts I-J and I-(J+1) occur simultaneously. +C The system loses extra energy. +c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0) + endif + enddo ! kk + do kk=1,num_conti + j1=jcont_hb(kk,i) +c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk + if (j1.eq.j+1) then +C Contacts I-J and (I+1)-J occur simultaneously. +C The system loses extra energy. +c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0) + endif ! j1==j+1 + enddo ! kk + enddo ! jj + enddo ! i + return + end +c------------------------------------------------------------------------------ + subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr, + & n_corr1) +C This subroutine calculates multi-body contributions to hydrogen-bonding + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' +#ifdef MPL + include 'COMMON.INFO' +#endif + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' +#ifdef MPL + parameter (max_cont=maxconts) + parameter (max_dim=2*(8*3+2)) + parameter (msglen1=max_cont*max_dim*4) + parameter (msglen2=2*msglen1) + integer source,CorrelType,CorrelID,Error + double precision buffer(max_cont,max_dim) +#endif + double precision gx(3),gx1(3) + logical lprn,ldone + +C Set lprn=.true. for debugging + lprn=.false. + eturn6=0.0d0 +#ifdef MPL + n_corr=0 + n_corr1=0 + if (fgProcs.le.1) goto 30 + if (lprn) then + write (iout,'(a)') 'Contact function values:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i2,f5.2))') + & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), + & j=1,num_cont_hb(i)) + enddo + endif +C Caution! Following code assumes that electrostatic interactions concerning +C a given atom are split among at most two processors! + CorrelType=477 + CorrelID=MyID+1 + ldone=.false. + do i=1,max_cont + do j=1,max_dim + buffer(i,j)=0.0D0 + enddo + enddo + mm=mod(MyRank,2) +cd write (iout,*) 'MyRank',MyRank,' mm',mm + if (mm) 20,20,10 + 10 continue +cd write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone + if (MyRank.gt.0) then +C Send correlation contributions to the preceding processor + msglen=msglen1 + nn=num_cont_hb(iatel_s) + call pack_buffer(max_cont,max_dim,iatel_s,0,buffer) +cd write (iout,*) 'The BUFFER array:' +cd do i=1,nn +cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26) +cd enddo + if (ielstart(iatel_s).gt.iatel_s+ispp) then + msglen=msglen2 + call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer) +C Clear the contacts of the atom passed to the neighboring processor + nn=num_cont_hb(iatel_s+1) +cd do i=1,nn +cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26) +cd enddo + num_cont_hb(iatel_s)=0 + endif +cd write (iout,*) 'Processor ',MyID,MyRank, +cd & ' is sending correlation contribution to processor',MyID-1, +cd & ' msglen=',msglen +cd write (*,*) 'Processor ',MyID,MyRank, +cd & ' is sending correlation contribution to processor',MyID-1, +cd & ' msglen=',msglen,' CorrelType=',CorrelType + call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID) +cd write (iout,*) 'Processor ',MyID, +cd & ' has sent correlation contribution to processor',MyID-1, +cd & ' msglen=',msglen,' CorrelID=',CorrelID +cd write (*,*) 'Processor ',MyID, +cd & ' has sent correlation contribution to processor',MyID-1, +cd & ' msglen=',msglen,' CorrelID=',CorrelID + msglen=msglen1 + endif ! (MyRank.gt.0) + if (ldone) goto 30 + ldone=.true. + 20 continue +cd write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone + if (MyRank.lt.fgProcs-1) then +C Receive correlation contributions from the next processor + msglen=msglen1 + if (ielend(iatel_e).lt.nct-1) msglen=msglen2 +cd write (iout,*) 'Processor',MyID, +cd & ' is receiving correlation contribution from processor',MyID+1, +cd & ' msglen=',msglen,' CorrelType=',CorrelType +cd write (*,*) 'Processor',MyID, +cd & ' is receiving correlation contribution from processor',MyID+1, +cd & ' msglen=',msglen,' CorrelType=',CorrelType + nbytes=-1 + do while (nbytes.le.0) + call mp_probe(MyID+1,CorrelType,nbytes) + enddo +cd print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes + call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes) +cd write (iout,*) 'Processor',MyID, +cd & ' has received correlation contribution from processor',MyID+1, +cd & ' msglen=',msglen,' nbytes=',nbytes +cd write (iout,*) 'The received BUFFER array:' +cd do i=1,max_cont +cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52) +cd enddo + if (msglen.eq.msglen1) then + call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer) + else if (msglen.eq.msglen2) then + call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer) + call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer) + else + write (iout,*) + & 'ERROR!!!! message length changed while processing correlations.' + write (*,*) + & 'ERROR!!!! message length changed while processing correlations.' + call mp_stopall(Error) + endif ! msglen.eq.msglen1 + endif ! MyRank.lt.fgProcs-1 + if (ldone) goto 30 + ldone=.true. + goto 10 + 30 continue +#endif + if (lprn) then + write (iout,'(a)') 'Contact function values:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i2,f5.2))') + & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), + & j=1,num_cont_hb(i)) + enddo + endif + ecorr=0.0D0 + ecorr5=0.0d0 + ecorr6=0.0d0 +C Remove the loop below after debugging !!! + do i=nnt,nct + do j=1,3 + gradcorr(j,i)=0.0D0 + gradxorr(j,i)=0.0D0 + enddo + enddo +C Calculate the dipole-dipole interaction energies + if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then + do i=iatel_s,iatel_e+1 + num_conti=num_cont_hb(i) + do jj=1,num_conti + j=jcont_hb(jj,i) + call dipole(i,j,jj) + enddo + enddo + endif +C Calculate the local-electrostatic correlation terms + do i=iatel_s,iatel_e+1 + i1=i+1 + num_conti=num_cont_hb(i) + num_conti1=num_cont_hb(i+1) + do jj=1,num_conti + j=jcont_hb(jj,i) + do kk=1,num_conti1 + j1=jcont_hb(kk,i1) +c write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk + if (j1.eq.j+1 .or. j1.eq.j-1) then +C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. +C The system gains extra energy. + n_corr=n_corr+1 + sqd1=dsqrt(d_cont(jj,i)) + sqd2=dsqrt(d_cont(kk,i1)) + sred_geom = sqd1*sqd2 + IF (sred_geom.lt.cutoff_corr) THEN + call gcont(sred_geom,r0_corr,1.0D0,delt_corr, + & ekont,fprimcont) +c write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk + fac_prim1=0.5d0*sqd2/sqd1*fprimcont + fac_prim2=0.5d0*sqd1/sqd2*fprimcont + do l=1,3 + g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i) + g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1) + enddo + n_corr1=n_corr1+1 +cd write (iout,*) 'sred_geom=',sred_geom, +cd & ' ekont=',ekont,' fprim=',fprimcont + call calc_eello(i,j,i+1,j1,jj,kk) + if (wcorr4.gt.0.0d0) + & ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk) + if (wcorr5.gt.0.0d0) + & ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk) +c print *,"wcorr5",ecorr5 +cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6 +cd write(2,*)'ijkl',i,j,i+1,j1 + if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3 + & .or. wturn6.eq.0.0d0))then +cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1 + ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk) +cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5, +cd & 'ecorr6=',ecorr6 +cd write (iout,'(4e15.5)') sred_geom, +cd & dabs(eello4(i,j,i+1,j1,jj,kk)), +cd & dabs(eello5(i,j,i+1,j1,jj,kk)), +cd & dabs(eello6(i,j,i+1,j1,jj,kk)) + else if (wturn6.gt.0.0d0 + & .and. (j.eq.i+4 .and. j1.eq.i+3)) then +cd write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1 + eturn6=eturn6+eello_turn6(i,jj,kk) +cd write (2,*) 'multibody_eello:eturn6',eturn6 + endif + ENDIF +1111 continue + else if (j1.eq.j) then +C Contacts I-J and I-(J+1) occur simultaneously. +C The system loses extra energy. +c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0) + endif + enddo ! kk + do kk=1,num_conti + j1=jcont_hb(kk,i) +c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk + if (j1.eq.j+1) then +C Contacts I-J and (I+1)-J occur simultaneously. +C The system loses extra energy. +c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0) + endif ! j1==j+1 + enddo ! kk + enddo ! jj + enddo ! i + return + end +c------------------------------------------------------------------------------ + double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + double precision gx(3),gx1(3) + logical lprn + lprn=.false. + eij=facont_hb(jj,i) + ekl=facont_hb(kk,k) + ees0pij=ees0p(jj,i) + ees0pkl=ees0p(kk,k) + ees0mij=ees0m(jj,i) + ees0mkl=ees0m(kk,k) + ekont=eij*ekl + ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl) +cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl) +C Following 4 lines for diagnostics. +cd ees0pkl=0.0D0 +cd ees0pij=1.0D0 +cd ees0mkl=0.0D0 +cd ees0mij=1.0D0 +c write (iout,*)'Contacts have occurred for peptide groups',i,j, +c & ' and',k,l +c write (iout,*)'Contacts have occurred for peptide groups', +c & i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l +c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees +C Calculate the multi-body contribution to energy. + ecorr=ecorr+ekont*ees + if (calc_grad) then +C Calculate multi-body contributions to the gradient. + do ll=1,3 + ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i) + gradcorr(ll,i)=gradcorr(ll,i)+ghalf + & -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+ + & coeffm*ees0mkl*gacontm_hb1(ll,jj,i)) + gradcorr(ll,j)=gradcorr(ll,j)+ghalf + & -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+ + & coeffm*ees0mkl*gacontm_hb2(ll,jj,i)) + ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k) + gradcorr(ll,k)=gradcorr(ll,k)+ghalf + & -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+ + & coeffm*ees0mij*gacontm_hb1(ll,kk,k)) + gradcorr(ll,l)=gradcorr(ll,l)+ghalf + & -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+ + & coeffm*ees0mij*gacontm_hb2(ll,kk,k)) + enddo + do m=i+1,j-1 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+ + & ees*ekl*gacont_hbr(ll,jj,i)- + & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+ + & coeffm*ees0mkl*gacontm_hb3(ll,jj,i)) + enddo + enddo + do m=k+1,l-1 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+ + & ees*eij*gacont_hbr(ll,kk,k)- + & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+ + & coeffm*ees0mij*gacontm_hb3(ll,kk,k)) + enddo + enddo + endif + ehbcorr=ekont*ees + return + end +C--------------------------------------------------------------------------- + subroutine dipole(i,j,jj) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2), + & auxmat(2,2) + iti1 = itortyp(itype(i+1)) + if (j.lt.nres-1) then + itj1 = itortyp(itype(j+1)) + else + itj1=ntortyp+1 + endif + do iii=1,2 + dipi(iii,1)=Ub2(iii,i) + dipderi(iii)=Ub2der(iii,i) + dipi(iii,2)=b1(iii,iti1) + dipj(iii,1)=Ub2(iii,j) + dipderj(iii)=Ub2der(iii,j) + dipj(iii,2)=b1(iii,itj1) + enddo + kkk=0 + do iii=1,2 + call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1)) + do jjj=1,2 + kkk=kkk+1 + dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) + enddo + enddo + if (.not.calc_grad) return + do kkk=1,5 + do lll=1,3 + mmm=0 + do iii=1,2 + call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii), + & auxvec(1)) + do jjj=1,2 + mmm=mmm+1 + dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) + enddo + enddo + enddo + enddo + call transpose2(a_chuj(1,1,jj,i),auxmat(1,1)) + call matvec2(auxmat(1,1),dipderi(1),auxvec(1)) + do iii=1,2 + dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii)) + enddo + call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1)) + do iii=1,2 + dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii)) + enddo + return + end +C--------------------------------------------------------------------------- + subroutine calc_eello(i,j,k,l,jj,kk) +C +C This subroutine computes matrices and vectors needed to calculate +C the fourth-, fifth-, and sixth-order local-electrostatic terms. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.FFIELD' + double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2), + & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2) + logical lprn + common /kutas/ lprn +cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l, +cd & ' jj=',jj,' kk=',kk +cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return + do iii=1,2 + do jjj=1,2 + aa1(iii,jjj)=a_chuj(iii,jjj,jj,i) + aa2(iii,jjj)=a_chuj(iii,jjj,kk,k) + enddo + enddo + call transpose2(aa1(1,1),aa1t(1,1)) + call transpose2(aa2(1,1),aa2t(1,1)) + do kkk=1,5 + do lll=1,3 + call transpose2(a_chuj_der(1,1,lll,kkk,jj,i), + & aa1tder(1,1,lll,kkk)) + call transpose2(a_chuj_der(1,1,lll,kkk,kk,k), + & aa2tder(1,1,lll,kkk)) + enddo + enddo + if (l.eq.j+1) then +C parallel orientation of the two CA-CA-CA frames. + if (i.gt.1) then + iti=itortyp(itype(i)) + else + iti=ntortyp+1 + endif + itk1=itortyp(itype(k+1)) + itj=itortyp(itype(j)) + if (l.lt.nres-1) then + itl1=itortyp(itype(l+1)) + else + itl1=ntortyp+1 + endif +C A1 kernel(j+1) A2T +cd do iii=1,2 +cd write (iout,'(3f10.5,5x,3f10.5)') +cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2) +cd enddo + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l), + & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0) THEN + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l), + & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l), + & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1), + & ADtEAderx(1,1,1,1,1,1)) + lprn=.false. + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l), + & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), + & ADtEA1derx(1,1,1,1,1,1)) + ENDIF +C End 6-th order cumulants +cd lprn=.false. +cd if (lprn) then +cd write (2,*) 'In calc_eello6' +cd do iii=1,2 +cd write (2,*) 'iii=',iii +cd do kkk=1,5 +cd write (2,*) 'kkk=',kkk +cd do jjj=1,2 +cd write (2,'(3(2f10.5),5x)') +cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) +cd enddo +cd enddo +cd enddo +cd endif + call transpose2(EUgder(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) + call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), + & EAEAderx(1,1,lll,kkk,iii,1)) + enddo + enddo + enddo +C A1T kernel(i+1) A2 + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k), + & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0) THEN + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k), + & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k), + & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), + & ADtEAderx(1,1,1,1,1,2)) + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k), + & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), + & ADtEA1derx(1,1,1,1,1,2)) + ENDIF +C End 6-th order cumulants + call transpose2(EUgder(1,1,l),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2)) + call transpose2(EUg(1,1,l),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & EAEAderx(1,1,lll,kkk,iii,2)) + enddo + enddo + enddo +C AEAb1 and AEAb2 +C Calculate the vectors and their derivatives in virtual-bond dihedral angles. +C They are needed only when the fifth- or the sixth-order cumulants are +C indluded. + IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN + call transpose2(AEA(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1)) + call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1)) + call transpose2(AEAderg(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1)) + call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1)) + call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1)) + call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1)) + call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1)) + call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1)) + call transpose2(AEA(1,1,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2)) + call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2)) + call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2)) + call transpose2(AEAderg(1,1,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2)) + call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2)) + call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2)) + call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2)) + call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2)) + call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2)) + call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2)) +C Calculate the Cartesian derivatives of the vectors. + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti), + & AEAb1derx(1,lll,kkk,iii,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i), + & AEAb2derx(1,lll,kkk,iii,1,1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1), + & AEAb1derx(1,lll,kkk,iii,2,1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1), + & AEAb2derx(1,lll,kkk,iii,2,1)) + call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itj), + & AEAb1derx(1,lll,kkk,iii,1,2)) + call matvec2(auxmat(1,1),Ub2(1,j), + & AEAb2derx(1,lll,kkk,iii,1,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1), + & AEAb1derx(1,lll,kkk,iii,2,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1), + & AEAb2derx(1,lll,kkk,iii,2,2)) + enddo + enddo + enddo + ENDIF +C End vectors + else +C Antiparallel orientation of the two CA-CA-CA frames. + if (i.gt.1) then + iti=itortyp(itype(i)) + else + iti=ntortyp+1 + endif + itk1=itortyp(itype(k+1)) + itl=itortyp(itype(l)) + itj=itortyp(itype(j)) + if (j.lt.nres-1) then + itj1=itortyp(itype(j+1)) + else + itj1=ntortyp+1 + endif +C A2 kernel(j-1)T A1T + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j), + & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. + & j.eq.i+4 .and. l.eq.i+3)) THEN + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j), + & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) + call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j), + & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1), + & ADtEAderx(1,1,1,1,1,1)) + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j), + & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), + & ADtEA1derx(1,1,1,1,1,1)) + ENDIF +C End 6-th order cumulants + call transpose2(EUgder(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) + call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), + & EAEAderx(1,1,lll,kkk,iii,1)) + enddo + enddo + enddo +C A2T kernel(i+1)T A1 + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k), + & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. + & j.eq.i+4 .and. l.eq.i+3)) THEN + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k), + & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k), + & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), + & ADtEAderx(1,1,1,1,1,2)) + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k), + & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), + & ADtEA1derx(1,1,1,1,1,2)) + ENDIF +C End 6-th order cumulants + call transpose2(EUgder(1,1,j),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2)) + call transpose2(EUg(1,1,j),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & EAEAderx(1,1,lll,kkk,iii,2)) + enddo + enddo + enddo +C AEAb1 and AEAb2 +C Calculate the vectors and their derivatives in virtual-bond dihedral angles. +C They are needed only when the fifth- or the sixth-order cumulants are +C indluded. + IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. + & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN + call transpose2(AEA(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1)) + call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1)) + call transpose2(AEAderg(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1)) + call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1)) + call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1)) + call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1)) + call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1)) + call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1)) + call transpose2(AEA(1,1,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2)) + call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2)) + call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2)) + call transpose2(AEAderg(1,1,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2)) + call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2)) + call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2)) + call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2)) + call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2)) + call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2)) + call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2)) +C Calculate the Cartesian derivatives of the vectors. + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti), + & AEAb1derx(1,lll,kkk,iii,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i), + & AEAb2derx(1,lll,kkk,iii,1,1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1), + & AEAb1derx(1,lll,kkk,iii,2,1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1), + & AEAb2derx(1,lll,kkk,iii,2,1)) + call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itl), + & AEAb1derx(1,lll,kkk,iii,1,2)) + call matvec2(auxmat(1,1),Ub2(1,l), + & AEAb2derx(1,lll,kkk,iii,1,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1), + & AEAb1derx(1,lll,kkk,iii,2,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j), + & AEAb2derx(1,lll,kkk,iii,2,2)) + enddo + enddo + enddo + ENDIF +C End vectors + endif + return + end +C--------------------------------------------------------------------------- + subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp, + & KK,KKderg,AKA,AKAderg,AKAderx) + implicit none + integer nderg + logical transp + double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5), + & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2), + & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2) + integer iii,kkk,lll + integer jjj,mmm + logical lprn + common /kutas/ lprn + call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1)) + do iii=1,nderg + call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp, + & AKAderg(1,1,iii)) + enddo +cd if (lprn) write (2,*) 'In kernel' + do kkk=1,5 +cd if (lprn) write (2,*) 'kkk=',kkk + do lll=1,3 + call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1), + & KK(1,1),transp,AKAderx(1,1,lll,kkk,1)) +cd if (lprn) then +cd write (2,*) 'lll=',lll +cd write (2,*) 'iii=1' +cd do jjj=1,2 +cd write (2,'(3(2f10.5),5x)') +cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2) +cd enddo +cd endif + call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk), + & KK(1,1),transp,AKAderx(1,1,lll,kkk,2)) +cd if (lprn) then +cd write (2,*) 'lll=',lll +cd write (2,*) 'iii=2' +cd do jjj=1,2 +cd write (2,'(3(2f10.5),5x)') +cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2) +cd enddo +cd endif + enddo + enddo + return + end +C--------------------------------------------------------------------------- + double precision function eello4(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision pizda(2,2),ggg1(3),ggg2(3) +cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then +cd eello4=0.0d0 +cd return +cd endif +cd print *,'eello4:',i,j,k,l,jj,kk +cd write (2,*) 'i',i,' j',j,' k',k,' l',l +cd call checkint4(i,j,k,l,jj,kk,eel4_num) +cold eij=facont_hb(jj,i) +cold ekl=facont_hb(kk,k) +cold ekont=eij*ekl + eel4=-EAEA(1,1,1)-EAEA(2,2,1) + if (calc_grad) then +cd eel41=-EAEA(1,1,2)-EAEA(2,2,2) + gcorr_loc(k-1)=gcorr_loc(k-1) + & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1)) + if (l.eq.j+1) then + gcorr_loc(l-1)=gcorr_loc(l-1) + & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) + else + gcorr_loc(j-1)=gcorr_loc(j-1) + & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) + endif + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) + & -EAEAderx(2,2,lll,kkk,iii,1) +cd derx(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd gcorr_loc(l-1)=0.0d0 +cd gcorr_loc(j-1)=0.0d0 +cd gcorr_loc(k-1)=0.0d0 +cd eel4=1.0d0 +cd write (iout,*)'Contacts have occurred for peptide groups', +cd & i,j,' fcont:',eij,' eij',' and ',k,l, +cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif + do ll=1,3 +cold ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i) + ggg1(ll)=eel4*g_contij(ll,1) + ggg2(ll)=eel4*g_contij(ll,2) + ghalf=0.5d0*ggg1(ll) +cd ghalf=0.0d0 + gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1) + gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1) + gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1) + gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1) +cold ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k) + ghalf=0.5d0*ggg2(ll) +cd ghalf=0.0d0 + gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2) + gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2) + gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2) + gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2) + enddo +cd goto 1112 + do m=i+1,j-1 + do ll=1,3 +cold gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i) + gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll) + enddo + enddo + do m=k+1,l-1 + do ll=1,3 +cold gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k) + gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll) + enddo + enddo +1112 continue + do m=i+2,j2 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1) + enddo + enddo + do m=k+2,l2 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2) + enddo + enddo +cd do iii=1,nres-3 +cd write (2,*) iii,gcorr_loc(iii) +cd enddo + endif + eello4=ekont*eel4 +cd write (2,*) 'ekont',ekont +cd write (iout,*) 'eello4',ekont*eel4 + return + end +C--------------------------------------------------------------------------- + double precision function eello5(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2) + double precision ggg1(3),ggg2(3) +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel chains C +C C +C o o o o C +C /l\ / \ \ / \ / \ / C +C / \ / \ \ / \ / \ / C +C j| o |l1 | o | o| o | | o |o C +C \ |/k\| |/ \| / |/ \| |/ \| C +C \i/ \ / \ / / \ / \ C +C o k1 o C +C (I) (II) (III) (IV) C +C C +C eello5_1 eello5_2 eello5_3 eello5_4 C +C C +C Antiparallel chains C +C C +C o o o o C +C /j\ / \ \ / \ / \ / C +C / \ / \ \ / \ / \ / C +C j1| o |l | o | o| o | | o |o C +C \ |/k\| |/ \| / |/ \| |/ \| C +C \i/ \ / \ / / \ / \ C +C o k1 o C +C (I) (II) (III) (IV) C +C C +C eello5_1 eello5_2 eello5_3 eello5_4 C +C C +C o denotes a local interaction, vertical lines an electrostatic interaction. C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then +cd eello5=0.0d0 +cd return +cd endif +cd write (iout,*) +cd & 'EELLO5: Contacts have occurred for peptide groups',i,j, +cd & ' and',k,l + itk=itortyp(itype(k)) + itl=itortyp(itype(l)) + itj=itortyp(itype(j)) + eello5_1=0.0d0 + eello5_2=0.0d0 + eello5_3=0.0d0 + eello5_4=0.0d0 +cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num, +cd & eel5_3_num,eel5_4_num) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd eij=facont_hb(jj,i) +cd ekl=facont_hb(kk,k) +cd ekont=eij*ekl +cd write (iout,*)'Contacts have occurred for peptide groups', +cd & i,j,' fcont:',eij,' eij',' and ',k,l +cd goto 1111 +C Contribution from the graph I. +cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1) +cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) + if (calc_grad) then +C Explicit gradient in virtual-dihedral angles. + if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) + & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2der(1,i))) + call transpose2(EUgder(1,1,k),auxmat1(1,1)) + call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) + call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + if (l.eq.j+1) then + if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) + else + if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) + endif +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) + enddo + enddo + enddo +c goto 1112 + endif +c1111 continue +C Contribution from graph II + call transpose2(EE(1,1,itk),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k)) + if (calc_grad) then +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k)) + call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + if (l.eq.j+1) then + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k))) + else + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k))) + endif +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k)) + enddo + enddo + enddo +cd goto 1112 + endif +cd1111 continue + if (l.eq.j+1) then +cd goto 1110 +C Parallel orientation +C Contribution from graph III + call transpose2(EUg(1,1,l),auxmat(1,1)) + call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) + if (calc_grad) then +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2der(1,j))) + call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) + call transpose2(EUgder(1,1,l),auxmat1(1,1)) + call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) + enddo + enddo + enddo +cd goto 1112 + endif +C Contribution from graph IV +cd1110 continue + call transpose2(EE(1,1,itl),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) + & -0.5d0*scalar2(vv(1),Ctobr(1,l)) + if (calc_grad) then +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) + & -0.5d0*scalar2(vv(1),Ctobr(1,l))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) + & -0.5d0*scalar2(vv(1),Ctobr(1,l)) + enddo + enddo + enddo + endif + else +C Antiparallel orientation +C Contribution from graph III +c goto 1110 + call transpose2(EUg(1,1,j),auxmat(1,1)) + call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) + if (calc_grad) then +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2der(1,l))) + call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) + call transpose2(EUgder(1,1,j),auxmat1(1,1)) + call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) + & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) + enddo + enddo + enddo +cd goto 1112 + endif +C Contribution from graph IV +1110 continue + call transpose2(EE(1,1,itj),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) + & -0.5d0*scalar2(vv(1),Ctobr(1,j)) + if (calc_grad) then +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) + & -0.5d0*scalar2(vv(1),Ctobr(1,j))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) + & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) + & -0.5d0*scalar2(vv(1),Ctobr(1,j)) + enddo + enddo + enddo + endif + endif +1112 continue + eel5=eello5_1+eello5_2+eello5_3+eello5_4 +cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then +cd write (2,*) 'ijkl',i,j,k,l +cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2, +cd & ' eello5_3',eello5_3,' eello5_4',eello5_4 +cd endif +cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num +cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num +cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num +cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num + if (calc_grad) then + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif +cd eij=1.0d0 +cd ekl=1.0d0 +cd ekont=1.0d0 +cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont + do ll=1,3 + ggg1(ll)=eel5*g_contij(ll,1) + ggg2(ll)=eel5*g_contij(ll,2) +cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i) + ghalf=0.5d0*ggg1(ll) +cd ghalf=0.0d0 + gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1) + gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1) + gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1) + gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1) +cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k) + ghalf=0.5d0*ggg2(ll) +cd ghalf=0.0d0 + gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2) + gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2) + gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2) + gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2) + enddo +cd goto 1112 + do m=i+1,j-1 + do ll=1,3 +cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i) + gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll) + enddo + enddo + do m=k+1,l-1 + do ll=1,3 +cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k) + gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll) + enddo + enddo +c1112 continue + do m=i+2,j2 + do ll=1,3 + gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1) + enddo + enddo + do m=k+2,l2 + do ll=1,3 + gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2) + enddo + enddo +cd do iii=1,nres-3 +cd write (2,*) iii,g_corr5_loc(iii) +cd enddo + endif + eello5=ekont*eel5 +cd write (2,*) 'ekont',ekont +cd write (iout,*) 'eello5',ekont*eel5 + return + end +c-------------------------------------------------------------------------- + double precision function eello6(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.FFIELD' + double precision ggg1(3),ggg2(3) +cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then +cd eello6=0.0d0 +cd return +cd endif +cd write (iout,*) +cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, +cd & ' and',k,l + eello6_1=0.0d0 + eello6_2=0.0d0 + eello6_3=0.0d0 + eello6_4=0.0d0 + eello6_5=0.0d0 + eello6_6=0.0d0 +cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num, +cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd eij=facont_hb(jj,i) +cd ekl=facont_hb(kk,k) +cd ekont=eij*ekl +cd eij=1.0d0 +cd ekl=1.0d0 +cd ekont=1.0d0 + if (l.eq.j+1) then + eello6_1=eello6_graph1(i,j,k,l,1,.false.) + eello6_2=eello6_graph1(j,i,l,k,2,.false.) + eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.) + eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) + eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.) + eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.) + else + eello6_1=eello6_graph1(i,j,k,l,1,.false.) + eello6_2=eello6_graph1(l,k,j,i,2,.true.) + eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.) + eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) + if (wturn6.eq.0.0d0 .or. j.ne.i+4) then + eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) + else + eello6_5=0.0d0 + endif + eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.) + endif +C If turn contributions are considered, they will be handled separately. + eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6 +cd write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num +cd write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num +cd write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num +cd write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num +cd write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num +cd write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num +cd goto 1112 + if (calc_grad) then + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif + do ll=1,3 + ggg1(ll)=eel6*g_contij(ll,1) + ggg2(ll)=eel6*g_contij(ll,2) +cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i) + ghalf=0.5d0*ggg1(ll) +cd ghalf=0.0d0 + gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1) + gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1) + gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1) + gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1) + ghalf=0.5d0*ggg2(ll) +cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k) +cd ghalf=0.0d0 + gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2) + gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2) + gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2) + gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2) + enddo +cd goto 1112 + do m=i+1,j-1 + do ll=1,3 +cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i) + gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll) + enddo + enddo + do m=k+1,l-1 + do ll=1,3 +cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k) + gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll) + enddo + enddo +1112 continue + do m=i+2,j2 + do ll=1,3 + gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1) + enddo + enddo + do m=k+2,l2 + do ll=1,3 + gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2) + enddo + enddo +cd do iii=1,nres-3 +cd write (2,*) iii,g_corr6_loc(iii) +cd enddo + endif + eello6=ekont*eel6 +cd write (2,*) 'ekont',ekont +cd write (iout,*) 'eello6',ekont*eel6 + return + end +c-------------------------------------------------------------------------- + double precision function eello6_graph1(i,j,k,l,imat,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2) + logical swap + logical lprn + common /kutas/ lprn +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C Parallel Antiparallel +C +C o o +C /l\ /j\ +C / \ / \ +C /| o | | o |\ +C \ j|/k\| / \ |/k\|l / +C \ / \ / \ / \ / +C o o o o +C i i +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + itk=itortyp(itype(k)) + s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i)) + s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k)) + s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k)) + call transpose2(EUgC(1,1,k),auxmat(1,1)) + call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) + vv1(1)=pizda1(1,1)-pizda1(2,2) + vv1(2)=pizda1(1,2)+pizda1(2,1) + s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) + vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk) + vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk) + s5=scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5 + eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5) + if (.not. calc_grad) return + if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) + & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) + & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) + & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) + & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) + & +scalar2(vv(1),Dtobr2der(1,i))) + call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1)) + vv1(1)=pizda1(1,1)-pizda1(2,2) + vv1(2)=pizda1(1,2)+pizda1(2,1) + vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk) + vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk) + if (l.eq.j+1) then + g_corr6_loc(l-1)=g_corr6_loc(l-1) + & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) + & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) + & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) + & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i)))) + else + g_corr6_loc(j-1)=g_corr6_loc(j-1) + & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) + & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) + & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) + & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i)))) + endif + call transpose2(EUgCder(1,1,k),auxmat(1,1)) + call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) + vv1(1)=pizda1(1,1)-pizda1(2,2) + vv1(2)=pizda1(1,2)+pizda1(2,1) + if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) + & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) + & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) + & +0.5d0*scalar2(vv1(1),Dtobr2(1,i)))) + do iii=1,2 + if (swap) then + ind=3-iii + else + ind=iii + endif + do kkk=1,5 + do lll=1,3 + s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i)) + s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k)) + s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k)) + call transpose2(EUgC(1,1,k),auxmat(1,1)) + call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1), + & pizda1(1,1)) + vv1(1)=pizda1(1,1)-pizda1(2,2) + vv1(2)=pizda1(1,2)+pizda1(2,1) + s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) + vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) + & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk) + vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) + & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk) + s5=scalar2(vv(1),Dtobr2(1,i)) + derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5) + enddo + enddo + enddo + return + end +c---------------------------------------------------------------------------- + double precision function eello6_graph2(i,j,k,l,jj,kk,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + logical swap + double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), + & auxvec1(2),auxvec2(1),auxmat1(2,2) + logical lprn + common /kutas/ lprn +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C Parallel Antiparallel +C +C o o +C \ /l\ /j\ / +C \ / \ / \ / +C o| o | | o |o +C \ j|/k\| \ |/k\|l +C \ / \ \ / \ +C o o +C i i +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l +C AL 7/4/01 s1 would occur in the sixth-order moment, +C but not in a cluster cumulant +#ifdef MOMENT + s1=dip(1,jj,i)*dip(1,kk,k) +#endif + call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + eello6_graph2=-(s1+s2+s3+s4) +#else + eello6_graph2=-(s2+s3+s4) +#endif +c eello6_graph2=-s3 + if (.not. calc_grad) return +C Derivatives in gamma(i-1) + if (i.gt.1) then +#ifdef MOMENT + s1=dipderg(1,jj,i)*dip(1,kk,k) +#endif + s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1)) + call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) + s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i)) +#ifdef MOMENT + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) +#endif +c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3 + endif +C Derivatives in gamma(k-1) +#ifdef MOMENT + s1=dip(1,jj,i)*dipderg(1,kk,k) +#endif + call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) + call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) + call transpose2(EUgder(1,1,k),auxmat1(1,1)) + call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +#ifdef MOMENT + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) +#endif +c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3 +C Derivatives in gamma(j-1) or gamma(l-1) + if (j.gt.1) then +#ifdef MOMENT + s1=dipderg(3,jj,i)*dip(1,kk,k) +#endif + call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1)) + call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +#ifdef MOMENT + if (swap) then + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 + else + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 + endif +#endif + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4) +c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3 + endif +C Derivatives in gamma(l-1) or gamma(j-1) + if (l.gt.1) then +#ifdef MOMENT + s1=dip(1,jj,i)*dipderg(3,kk,k) +#endif + call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) + call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) + call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +#ifdef MOMENT + if (swap) then + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 + else + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 + endif +#endif + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4) +c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3 + endif +C Cartesian derivatives. + if (lprn) then + write (2,*) 'In eello6_graph2' + do iii=1,2 + write (2,*) 'iii=',iii + do kkk=1,5 + write (2,*) 'kkk=',kkk + do jjj=1,2 + write (2,'(3(2f10.5),5x)') + & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) + enddo + enddo + enddo + endif + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + if (iii.eq.1) then + s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k) + else + s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k) + endif +#endif + call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k), + & auxvec(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l), + & auxvec(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) +#else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) +#endif + if (swap) then + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 + else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + endif + enddo + enddo + enddo + return + end +c---------------------------------------------------------------------------- + double precision function eello6_graph3(i,j,k,l,jj,kk,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2) + logical swap +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C Parallel Antiparallel +C +C o o +C /l\ / \ /j\ +C / \ / \ / \ +C /| o |o o| o |\ +C j|/k\| / |/k\|l / +C / \ / / \ / +C / o / o +C i i +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C 4/7/01 AL Component s1 was removed, because it pertains to the respective +C energy moment and not to the cluster cumulant. + iti=itortyp(itype(i)) + if (j.lt.nres-1) then + itj1=itortyp(itype(j+1)) + else + itj1=ntortyp+1 + endif + itk=itortyp(itype(k)) + itk1=itortyp(itype(k+1)) + if (l.lt.nres-1) then + itl1=itortyp(itype(l+1)) + else + itl1=ntortyp+1 + endif +#ifdef MOMENT + s1=dip(4,jj,i)*dip(4,kk,k) +#endif + call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1)) + s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) + call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1)) + s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) + call transpose2(EE(1,1,itk),auxmat(1,1)) + call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) +cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + eello6_graph3=-(s1+s2+s3+s4) +#else + eello6_graph3=-(s2+s3+s4) +#endif +c eello6_graph3=-s4 + if (.not. calc_grad) return +C Derivatives in gamma(k-1) + call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1)) + s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) + s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k)) + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4) +C Derivatives in gamma(l-1) + call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1)) + s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) + call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) +C Cartesian derivatives. + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + if (iii.eq.1) then + s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k) + else + s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k) + endif +#endif + call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1), + & auxvec(1)) + s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) + call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1), + & auxvec(1)) + s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) + call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) +#ifdef MOMENT + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) +#else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) +#endif + if (swap) then + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 + else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + endif +c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4 + enddo + enddo + enddo + return + end +c---------------------------------------------------------------------------- + double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.FFIELD' + double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), + & auxvec1(2),auxmat1(2,2) + logical swap +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C Parallel Antiparallel +C +C o o +C /l\ / \ /j\ +C / \ / \ / \ +C /| o |o o| o |\ +C \ j|/k\| \ |/k\|l +C \ / \ \ / \ +C o \ o \ +C i i +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C 4/7/01 AL Component s1 was removed, because it pertains to the respective +C energy moment and not to the cluster cumulant. +cd write (2,*) 'eello_graph4: wturn6',wturn6 + iti=itortyp(itype(i)) + itj=itortyp(itype(j)) + if (j.lt.nres-1) then + itj1=itortyp(itype(j+1)) + else + itj1=ntortyp+1 + endif + itk=itortyp(itype(k)) + if (k.lt.nres-1) then + itk1=itortyp(itype(k+1)) + else + itk1=ntortyp+1 + endif + itl=itortyp(itype(l)) + if (l.lt.nres-1) then + itl1=itortyp(itype(l+1)) + else + itl1=ntortyp+1 + endif +cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l +cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk, +cd & ' itl',itl,' itl1',itl1 +#ifdef MOMENT + if (imat.eq.1) then + s1=dip(3,jj,i)*dip(3,kk,k) + else + s1=dip(2,jj,j)*dip(2,kk,l) + endif +#endif + call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) + else + call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) + endif + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + eello6_graph4=-(s1+s2+s3+s4) +#else + eello6_graph4=-(s2+s3+s4) +#endif + if (.not. calc_grad) return +C Derivatives in gamma(i-1) + if (i.gt.1) then +#ifdef MOMENT + if (imat.eq.1) then + s1=dipderg(2,jj,i)*dip(3,kk,k) + else + s1=dipderg(4,jj,j)*dip(2,kk,l) + endif +#endif + s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) + else + call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) + endif + s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i)) + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then +cd write (2,*) 'turn6 derivatives' +#ifdef MOMENT + gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4) +#else + gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4) +#endif + else +#ifdef MOMENT + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) +#endif + endif + endif +C Derivatives in gamma(k-1) +#ifdef MOMENT + if (imat.eq.1) then + s1=dip(3,jj,i)*dipderg(2,kk,k) + else + s1=dip(2,jj,j)*dipderg(4,kk,l) + endif +#endif + call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) + else + call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) + endif + call transpose2(EUgder(1,1,k),auxmat1(1,1)) + call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then +#ifdef MOMENT + gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4) +#else + gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4) +#endif + else +#ifdef MOMENT + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) +#endif + endif +C Derivatives in gamma(j-1) or gamma(l-1) + if (l.eq.j+1 .and. l.gt.1) then + call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) + else if (j.gt.1) then + call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then + gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4) + else + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4) + endif + endif +C Cartesian derivatives. + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + if (iii.eq.1) then + if (imat.eq.1) then + s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k) + else + s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l) + endif + else + if (imat.eq.1) then + s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k) + else + s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l) + endif + endif +#endif + call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k), + & auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), + & b1(1,itj1),auxvec(1)) + s3=-0.5d0*scalar2(b1(1,itj),auxvec(1)) + else + call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), + & b1(1,itl1),auxvec(1)) + s3=-0.5d0*scalar2(b1(1,itl),auxvec(1)) + endif + call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + if (swap) then + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then +#ifdef MOMENT + derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) + & -(s1+s2+s4) +#else + derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) + & -(s2+s4) +#endif + derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3 + else +#ifdef MOMENT + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4) +#else + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4) +#endif + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + endif + else +#ifdef MOMENT + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) +#else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) +#endif + if (l.eq.j+1) then + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + else + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 + endif + endif + enddo + enddo + enddo + return + end +c---------------------------------------------------------------------------- + double precision function eello_turn6(i,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2), + & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2), + & ggg1(3),ggg2(3) + double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2), + & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2) +C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to +C the respective energy moment and not to the cluster cumulant. + eello_turn6=0.0d0 + j=i+4 + k=i+1 + l=i+3 + iti=itortyp(itype(i)) + itk=itortyp(itype(k)) + itk1=itortyp(itype(k+1)) + itl=itortyp(itype(l)) + itj=itortyp(itype(j)) +cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj +cd write (2,*) 'i',i,' k',k,' j',j,' l',l +cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then +cd eello6=0.0d0 +cd return +cd endif +cd write (iout,*) +cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, +cd & ' and',k,l +cd call checkint_turn6(i,jj,kk,eel_turn6_num) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx_turn(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd eij=1.0d0 +cd ekl=1.0d0 +cd ekont=1.0d0 + eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) +cd eello6_5=0.0d0 +cd write (2,*) 'eello6_5',eello6_5 +#ifdef MOMENT + call transpose2(AEA(1,1,1),auxmat(1,1)) + call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1)) + ss1=scalar2(Ub2(1,i+2),b1(1,itl)) + s1 = (auxmat(1,1)+auxmat(2,2))*ss1 +#endif + call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1)) + call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1)) + s2 = scalar2(b1(1,itk),vtemp1(1)) +#ifdef MOMENT + call transpose2(AEA(1,1,2),atemp(1,1)) + call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1)) + call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1)) + s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) +#endif + call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1)) + call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1)) + s12 = scalar2(Ub2(1,i+2),vtemp3(1)) +#ifdef MOMENT + call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1)) + call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1)) + call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1)) + call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1)) + ss13 = scalar2(b1(1,itk),vtemp4(1)) + s13 = (gtemp(1,1)+gtemp(2,2))*ss13 +#endif +c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13 +c s1=0.0d0 +c s2=0.0d0 +c s8=0.0d0 +c s12=0.0d0 +c s13=0.0d0 + eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13) + if (calc_grad) then +C Derivatives in gamma(i+2) +#ifdef MOMENT + call transpose2(AEA(1,1,1),auxmatd(1,1)) + call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 + call transpose2(AEAderg(1,1,2),atempd(1,1)) + call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1)) + s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) +#endif + call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1)) + call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 + gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d) +C Derivatives in gamma(i+3) +#ifdef MOMENT + call transpose2(AEA(1,1,1),auxmatd(1,1)) + call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + ss1d=scalar2(Ub2der(1,i+2),b1(1,itl)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d +#endif + call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1)) + call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1)) + s2d = scalar2(b1(1,itk),vtemp1d(1)) +#ifdef MOMENT + call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1)) + s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1)) +#endif + s12d = scalar2(Ub2der(1,i+2),vtemp3(1)) +#ifdef MOMENT + call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1)) + call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) + s13d = (gtempd(1,1)+gtempd(2,2))*ss13 +#endif +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + gel_loc_turn6(i+1)=gel_loc_turn6(i+1) + & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) +#else + gel_loc_turn6(i+1)=gel_loc_turn6(i+1) + & -0.5d0*ekont*(s2d+s12d) +#endif +C Derivatives in gamma(i+4) + call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1)) + call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +#ifdef MOMENT + call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1)) + call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1)) + s13d = (gtempd(1,1)+gtempd(2,2))*ss13 +#endif +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +C s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d) +#else + gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d) +#endif +C Derivatives in gamma(i+5) +#ifdef MOMENT + call transpose2(AEAderg(1,1,1),auxmatd(1,1)) + call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 +#endif + call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1)) + call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1)) + s2d = scalar2(b1(1,itk),vtemp1d(1)) +#ifdef MOMENT + call transpose2(AEA(1,1,2),atempd(1,1)) + call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1)) + s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) +#endif + call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +#ifdef MOMENT + call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1)) + ss13d = scalar2(b1(1,itk),vtemp4d(1)) + s13d = (gtemp(1,1)+gtemp(2,2))*ss13d +#endif +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + gel_loc_turn6(i+3)=gel_loc_turn6(i+3) + & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) +#else + gel_loc_turn6(i+3)=gel_loc_turn6(i+3) + & -0.5d0*ekont*(s2d+s12d) +#endif +C Cartesian derivatives + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1)) + call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 +#endif + call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1), + & vtemp1d(1)) + s2d = scalar2(b1(1,itk),vtemp1d(1)) +#ifdef MOMENT + call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1)) + call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1)) + s8d = -(atempd(1,1)+atempd(2,2))* + & scalar2(cc(1,1,itl),vtemp2(1)) +#endif + call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2), + & auxmatd(1,1)) + call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) + & - 0.5d0*(s1d+s2d) +#else + derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) + & - 0.5d0*s2d +#endif +#ifdef MOMENT + derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) + & - 0.5d0*(s8d+s12d) +#else + derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) + & - 0.5d0*s12d +#endif + enddo + enddo + enddo +#ifdef MOMENT + do kkk=1,5 + do lll=1,3 + call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1), + & achuj_tempd(1,1)) + call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1)) + call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) + s13d=(gtempd(1,1)+gtempd(2,2))*ss13 + derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d + call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4), + & vtemp4d(1)) + ss13d = scalar2(b1(1,itk),vtemp4d(1)) + s13d = (gtemp(1,1)+gtemp(2,2))*ss13d + derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d + enddo + enddo +#endif +cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num', +cd & 16*eel_turn6_num +cd goto 1112 + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif + do ll=1,3 + ggg1(ll)=eel_turn6*g_contij(ll,1) + ggg2(ll)=eel_turn6*g_contij(ll,2) + ghalf=0.5d0*ggg1(ll) +cd ghalf=0.0d0 + gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf + & +ekont*derx_turn(ll,2,1) + gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1) + gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf + & +ekont*derx_turn(ll,4,1) + gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1) + ghalf=0.5d0*ggg2(ll) +cd ghalf=0.0d0 + gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf + & +ekont*derx_turn(ll,2,2) + gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2) + gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf + & +ekont*derx_turn(ll,4,2) + gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2) + enddo +cd goto 1112 + do m=i+1,j-1 + do ll=1,3 + gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll) + enddo + enddo + do m=k+1,l-1 + do ll=1,3 + gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll) + enddo + enddo +1112 continue + do m=i+2,j2 + do ll=1,3 + gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1) + enddo + enddo + do m=k+2,l2 + do ll=1,3 + gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2) + enddo + enddo +cd do iii=1,nres-3 +cd write (2,*) iii,g_corr6_loc(iii) +cd enddo + endif + eello_turn6=ekont*eel_turn6 +cd write (2,*) 'ekont',ekont +cd write (2,*) 'eel_turn6',ekont*eel_turn6 + return + end +crc------------------------------------------------- + SUBROUTINE MATVEC2(A1,V1,V2) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + DIMENSION A1(2,2),V1(2),V2(2) +c DO 1 I=1,2 +c VI=0.0 +c DO 3 K=1,2 +c 3 VI=VI+A1(I,K)*V1(K) +c Vaux(I)=VI +c 1 CONTINUE + + vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2) + vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2) + + v2(1)=vaux1 + v2(2)=vaux2 + END +C--------------------------------------- + SUBROUTINE MATMAT2(A1,A2,A3) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + DIMENSION A1(2,2),A2(2,2),A3(2,2) +c DIMENSION AI3(2,2) +c DO J=1,2 +c A3IJ=0.0 +c DO K=1,2 +c A3IJ=A3IJ+A1(I,K)*A2(K,J) +c enddo +c A3(I,J)=A3IJ +c enddo +c enddo + + ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1) + ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2) + ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1) + ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2) + + A3(1,1)=AI3_11 + A3(2,1)=AI3_21 + A3(1,2)=AI3_12 + A3(2,2)=AI3_22 + END + +c------------------------------------------------------------------------- + double precision function scalar2(u,v) + implicit none + double precision u(2),v(2) + double precision sc + integer i + scalar2=u(1)*v(1)+u(2)*v(2) + return + end + +C----------------------------------------------------------------------------- + + subroutine transpose2(a,at) + implicit none + double precision a(2,2),at(2,2) + at(1,1)=a(1,1) + at(1,2)=a(2,1) + at(2,1)=a(1,2) + at(2,2)=a(2,2) + return + end +c-------------------------------------------------------------------------- + subroutine transpose(n,a,at) + implicit none + integer n,i,j + double precision a(n,n),at(n,n) + do i=1,n + do j=1,n + at(j,i)=a(i,j) + enddo + enddo + return + end +C--------------------------------------------------------------------------- + subroutine prodmat3(a1,a2,kk,transp,prod) + implicit none + integer i,j + double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2) + logical transp +crc double precision auxmat(2,2),prod_(2,2) + + if (transp) then +crc call transpose2(kk(1,1),auxmat(1,1)) +crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1)) +crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) + + prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) + & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1) + prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) + & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2) + prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) + & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1) + prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) + & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2) + + else +crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1)) +crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) + + prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) + & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1) + prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) + & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2) + prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) + & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1) + prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) + & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2) + + endif +c call transpose2(a2(1,1),a2t(1,1)) + +crc print *,transp +crc print *,((prod_(i,j),i=1,2),j=1,2) +crc print *,((prod(i,j),i=1,2),j=1,2) + + return + end +C----------------------------------------------------------------------------- + double precision function scalar(u,v) + implicit none + double precision u(3),v(3) + double precision sc + integer i + sc=0.0d0 + do i=1,3 + sc=sc+u(i)*v(i) + enddo + scalar=sc + return + end + diff --git a/source/wham/src-NEWSC-NEWCORR/fitsq.f b/source/wham/src-NEWSC-NEWCORR/fitsq.f new file mode 100644 index 0000000..17d92ee --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/fitsq.f @@ -0,0 +1,352 @@ + subroutine fitsq(rms,x,y,nn,t,b,non_conv) + implicit real*8 (a-h,o-z) + include 'COMMON.IOUNITS' +c x and y are the vectors of coordinates (dimensioned (3,n)) of the two +c structures to be superimposed. nn is 3*n, where n is the number of +c points. t and b are respectively the translation vector and the +c rotation matrix that transforms the second set of coordinates to the +c frame of the first set. +c eta = machine-specific variable + + dimension x(3*nn),y(3*nn),t(3) + dimension b(3,3),q(3,3),r(3,3),v(3),xav(3),yav(3),e(3),c(3,3) + logical non_conv + eta = z00100000 +c small=25.0*rmdcon(3) +c small=25.0*eta +c small=25.0*10.e-10 +c the following is a very lenient value for 'small' + small = 0.0001D0 + non_conv=.false. + fn=nn + do 10 i=1,3 + xav(i)=0.0D0 + yav(i)=0.0D0 + do 10 j=1,3 + 10 b(j,i)=0.0D0 + nc=0 +c + do 30 n=1,nn + do 20 i=1,3 +crc write(iout,*)'x = ',x(nc+i),' y = ',y(nc+i) + xav(i)=xav(i)+x(nc+i)/fn + 20 yav(i)=yav(i)+y(nc+i)/fn + 30 nc=nc+3 +c + do i=1,3 + t(i)=yav(i)-xav(i) + enddo + + rms=0.0d0 + do n=1,nn + do i=1,3 + rms=rms+(y(3*(n-1)+i)-x(3*(n-1)+i)-t(i))**2 + enddo + enddo + rms=dabs(rms/fn) + +c write(iout,*)'xav = ',(xav(j),j=1,3) +c write(iout,*)'yav = ',(yav(j),j=1,3) +c write(iout,*)'t = ',(t(j),j=1,3) +c write(iout,*)'rms=',rms + if (rms.lt.small) return + + + nc=0 + rms=0.0D0 + do 50 n=1,nn + do 40 i=1,3 + rms=rms+((x(nc+i)-xav(i))**2+(y(nc+i)-yav(i))**2)/fn + do 40 j=1,3 + b(j,i)=b(j,i)+(x(nc+i)-xav(i))*(y(nc+j)-yav(j))/fn + 40 c(j,i)=b(j,i) + 50 nc=nc+3 + call sivade(b,q,r,d,non_conv) + sn3=dsign(1.0d0,d) + do 120 i=1,3 + do 120 j=1,3 + 120 b(j,i)=-q(j,1)*r(i,1)-q(j,2)*r(i,2)-sn3*q(j,3)*r(i,3) + call mvvad(b,xav,yav,t) + do 130 i=1,3 + do 130 j=1,3 + rms=rms+2.0*c(j,i)*b(j,i) + 130 b(j,i)=-b(j,i) + if (dabs(rms).gt.small) go to 140 +* write (6,301) + return + 140 if (rms.gt.0.0d0) go to 150 +c write (iout,303) rms + rms=0.0d0 +* stop +c 150 write (iout,302) dsqrt(rms) + 150 continue + return + 301 format (5x,'rms deviation negligible') + 302 format (5x,'rms deviation ',f14.6) + 303 format (//,5x,'negative ms deviation - ',f14.6) + end + subroutine sivade(x,q,r,dt,non_conv) + implicit real*8(a-h,o-z) +c computes q,e and r such that q(t)xr = diag(e) + dimension x(3,3),q(3,3),r(3,3),e(3) + dimension h(3,3),p(3,3),u(3,3),d(3) + logical non_conv + eta = z00100000 + nit = 0 + small=25.0*10.e-10 +c small=25.0*eta +c small=2.0*rmdcon(3) + xnrm=0.0d0 + do 20 i=1,3 + do 10 j=1,3 + xnrm=xnrm+x(j,i)*x(j,i) + u(j,i)=0.0d0 + r(j,i)=0.0d0 + 10 h(j,i)=0.0d0 + u(i,i)=1.0 + 20 r(i,i)=1.0 + xnrm=dsqrt(xnrm) + do 110 n=1,2 + xmax=0.0d0 + do 30 j=n,3 + 30 if (dabs(x(j,n)).gt.xmax) xmax=dabs(x(j,n)) + a=0.0d0 + do 40 j=n,3 + h(j,n)=x(j,n)/xmax + 40 a=a+h(j,n)*h(j,n) + a=dsqrt(a) + den=a*(a+dabs(h(n,n))) + d(n)=1.0/den + h(n,n)=h(n,n)+dsign(a,h(n,n)) + do 70 i=n,3 + s=0.0d0 + do 50 j=n,3 + 50 s=s+h(j,n)*x(j,i) + s=d(n)*s + do 60 j=n,3 + 60 x(j,i)=x(j,i)-s*h(j,n) + 70 continue + if (n.gt.1) go to 110 + xmax=dmax1(dabs(x(1,2)),dabs(x(1,3))) + h(2,3)=x(1,2)/xmax + h(3,3)=x(1,3)/xmax + a=dsqrt(h(2,3)*h(2,3)+h(3,3)*h(3,3)) + den=a*(a+dabs(h(2,3))) + d(3)=1.0/den + h(2,3)=h(2,3)+sign(a,h(2,3)) + do 100 i=1,3 + s=0.0d0 + do 80 j=2,3 + 80 s=s+h(j,3)*x(i,j) + s=d(3)*s + do 90 j=2,3 + 90 x(i,j)=x(i,j)-s*h(j,3) + 100 continue + 110 continue + do 130 i=1,3 + do 120 j=1,3 + 120 p(j,i)=-d(1)*h(j,1)*h(i,1) + 130 p(i,i)=1.0+p(i,i) + do 140 i=2,3 + do 140 j=2,3 + u(j,i)=u(j,i)-d(2)*h(j,2)*h(i,2) + 140 r(j,i)=r(j,i)-d(3)*h(j,3)*h(i,3) + call mmmul(p,u,q) + 150 np=1 + nq=1 + nit=nit+1 + if (nit.gt.10000) then + print '(a)','!!!! Over 10000 iterations in SIVADE!!!!!' + non_conv=.true. + return + endif + if (dabs(x(2,3)).gt.small*(dabs(x(2,2))+abs(x(3,3)))) go to 160 + x(2,3)=0.0d0 + nq=nq+1 + 160 if (dabs(x(1,2)).gt.small*(dabs(x(1,1))+dabs(x(2,2)))) go to 180 + x(1,2)=0.0d0 + if (x(2,3).ne.0.0d0) go to 170 + nq=nq+1 + go to 180 + 170 np=np+1 + 180 if (nq.eq.3) go to 310 + npq=4-np-nq + if (np.gt.npq) go to 230 + n0=0 + do 220 n=np,npq + nn=n+np-1 + if (dabs(x(nn,nn)).gt.small*xnrm) go to 220 + x(nn,nn)=0.0d0 + if (x(nn,nn+1).eq.0.0d0) go to 220 + n0=n0+1 + go to (190,210,220),nn + 190 do 200 j=2,3 + 200 call givns(x,q,1,j) + go to 220 + 210 call givns(x,q,2,3) + 220 continue + if (n0.ne.0) go to 150 + 230 nn=3-nq + a=x(nn,nn)*x(nn,nn) + if (nn.gt.1) a=a+x(nn-1,nn)*x(nn-1,nn) + b=x(nn+1,nn+1)*x(nn+1,nn+1)+x(nn,nn+1)*x(nn,nn+1) + c=x(nn,nn)*x(nn,nn+1) + dd=0.5*(a-b) + xn2=c*c + rt=b-xn2/(dd+sign(dsqrt(dd*dd+xn2),dd)) + y=x(np,np)*x(np,np)-rt + z=x(np,np)*x(np,np+1) + do 300 n=np,nn + if (dabs(y).lt.dabs(z)) go to 240 + t=z/y + c=1.0/dsqrt(1.0d0+t*t) + s=c*t + go to 250 + 240 t=y/z + s=1.0/dsqrt(1.0d0+t*t) + c=s*t + 250 do 260 j=1,3 + v=x(j,n) + w=x(j,n+1) + x(j,n)=c*v+s*w + x(j,n+1)=-s*v+c*w + a=r(j,n) + b=r(j,n+1) + r(j,n)=c*a+s*b + 260 r(j,n+1)=-s*a+c*b + y=x(n,n) + z=x(n+1,n) + if (dabs(y).lt.dabs(z)) go to 270 + t=z/y + c=1.0/dsqrt(1.0+t*t) + s=c*t + go to 280 + 270 t=y/z + s=1.0/dsqrt(1.0+t*t) + c=s*t + 280 do 290 j=1,3 + v=x(n,j) + w=x(n+1,j) + a=q(j,n) + b=q(j,n+1) + x(n,j)=c*v+s*w + x(n+1,j)=-s*v+c*w + q(j,n)=c*a+s*b + 290 q(j,n+1)=-s*a+c*b + if (n.ge.nn) go to 300 + y=x(n,n+1) + z=x(n,n+2) + 300 continue + go to 150 + 310 do 320 i=1,3 + 320 e(i)=x(i,i) + nit=0 + 330 n0=0 + nit=nit+1 + if (nit.gt.10000) then + print '(a)','!!!! Over 10000 iterations in SIVADE!!!!!' + non_conv=.true. + return + endif + do 360 i=1,3 + if (e(i).ge.0.0d0) go to 350 + e(i)=-e(i) + do 340 j=1,3 + 340 q(j,i)=-q(j,i) + 350 if (i.eq.1) go to 360 + if (dabs(e(i)).lt.dabs(e(i-1))) go to 360 + call switch(i,1,q,r,e) + n0=n0+1 + 360 continue + if (n0.ne.0) go to 330 + if (dabs(e(3)).gt.small*xnrm) go to 370 + e(3)=0.0d0 + if (dabs(e(2)).gt.small*xnrm) go to 370 + e(2)=0.0d0 + 370 dt=det(q(1,1),q(1,2),q(1,3))*det(r(1,1),r(1,2),r(1,3)) +* write (1,501) (e(i),i=1,3) + return + 501 format (/,5x,'singular values - ',3e15.5) + end + subroutine givns(a,b,m,n) + implicit real*8 (a-h,o-z) + dimension a(3,3),b(3,3) + if (dabs(a(m,n)).lt.dabs(a(n,n))) go to 10 + t=a(n,n)/a(m,n) + s=1.0/dsqrt(1.0+t*t) + c=s*t + go to 20 + 10 t=a(m,n)/a(n,n) + c=1.0/dsqrt(1.0+t*t) + s=c*t + 20 do 30 j=1,3 + v=a(m,j) + w=a(n,j) + x=b(j,m) + y=b(j,n) + a(m,j)=c*v-s*w + a(n,j)=s*v+c*w + b(j,m)=c*x-s*y + 30 b(j,n)=s*x+c*y + return + end + subroutine switch(n,m,u,v,d) + implicit real*8 (a-h,o-z) + dimension u(3,3),v(3,3),d(3) + do 10 i=1,3 + tem=u(i,n) + u(i,n)=u(i,n-1) + u(i,n-1)=tem + if (m.eq.0) go to 10 + tem=v(i,n) + v(i,n)=v(i,n-1) + v(i,n-1)=tem + 10 continue + tem=d(n) + d(n)=d(n-1) + d(n-1)=tem + return + end + subroutine mvvad(b,xav,yav,t) + implicit real*8 (a-h,o-z) + dimension b(3,3),xav(3),yav(3),t(3) +c dimension a(3,3),b(3),c(3),d(3) +c do 10 j=1,3 +c d(j)=c(j) +c do 10 i=1,3 +c 10 d(j)=d(j)+a(j,i)*b(i) + do 10 j=1,3 + t(j)=yav(j) + do 10 i=1,3 + 10 t(j)=t(j)+b(j,i)*xav(i) + return + end + double precision function det (a,b,c) + implicit real*8 (a-h,o-z) + dimension a(3),b(3),c(3) + det=a(1)*(b(2)*c(3)-b(3)*c(2))+a(2)*(b(3)*c(1)-b(1)*c(3)) + 1 +a(3)*(b(1)*c(2)-b(2)*c(1)) + return + end + subroutine mmmul(a,b,c) + implicit real*8 (a-h,o-z) + dimension a(3,3),b(3,3),c(3,3) + do 10 i=1,3 + do 10 j=1,3 + c(i,j)=0.0d0 + do 10 k=1,3 + 10 c(i,j)=c(i,j)+a(i,k)*b(k,j) + return + end + subroutine matvec(uvec,tmat,pvec,nback) + implicit real*8 (a-h,o-z) + real*8 tmat(3,3),uvec(3,nback), pvec(3,nback) +c + do 2 j=1,nback + do 1 i=1,3 + uvec(i,j) = 0.0d0 + do 1 k=1,3 + 1 uvec(i,j)=uvec(i,j)+tmat(i,k)*pvec(k,j) + 2 continue + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/geomout.F b/source/wham/src-NEWSC-NEWCORR/geomout.F new file mode 100644 index 0000000..d52e23e --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/geomout.F @@ -0,0 +1,167 @@ + subroutine pdbout(ii,temp,efree,etot,entropy,rmsdev) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.HEADER' + include 'COMMON.SBRIDGE' + character*50 tytul + dimension ica(maxres) + write(ipdb,'("REMARK CONF",i8," TEMPERATURE",f7.1," RMS",0pf7.2)') + & ii,temp,rmsdev + write (ipdb,'("REMARK DIMENSIONLESS FREE ENERGY",1pe15.5)') + & efree + write (ipdb,'("REMARK ENERGY",1pe15.5," ENTROPY",1pe15.5)') + & etot,entropy + iatom=0 + do i=nnt,nct + ires=i-nnt+1 + iatom=iatom+1 + ica(i)=iatom + iti=itype(i) + write (ipdb,10) iatom,restyp(iti),ires,(c(j,i),j=1,3) + if (iti.ne.10) then + iatom=iatom+1 + write (ipdb,20) iatom,restyp(iti),ires,(c(j,nres+i),j=1,3) + endif + enddo + write (ipdb,'(a)') 'TER' + do i=nnt,nct-1 + if (itype(i).eq.10) then + write (ipdb,30) ica(i),ica(i+1) + else + write (ipdb,30) ica(i),ica(i+1),ica(i)+1 + endif + enddo + if (itype(nct).ne.10) then + write (ipdb,30) ica(nct),ica(nct)+1 + endif + do i=1,nss + write (ipdb,30) ica(ihpb(i))+1,ica(jhpb(i))+1 + enddo + write (ipdb,'(a)') "END" + 10 FORMAT ('ATOM',I7,' CA ',A3,I6,4X,3F8.3) + 20 FORMAT ('ATOM',I7,' CB ',A3,I6,4X,3F8.3) + 30 FORMAT ('CONECT',8I5) + return + end +c------------------------------------------------------------------------------ + subroutine MOL2out(etot,tytul) +C Prints the Cartesian coordinates of the alpha-carbons in the Tripos mol2 +C format. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.HEADER' + include 'COMMON.SBRIDGE' + character*32 tytul,fd + character*3 liczba + character*6 res_num,pom,ucase +#ifdef AIX + call fdate_(fd) +#else + call fdate(fd) +#endif + write (imol2,'(a)') '#' + write (imol2,'(a)') + & '# Creating user name: unres' + write (imol2,'(2a)') '# Creation time: ', + & fd + write (imol2,'(/a)') '\@MOLECULE' + write (imol2,'(a)') tytul + write (imol2,'(5i5)') nct-nnt+1,nct-nnt+nss+1,nct-nnt+nss+1,0,0 + write (imol2,'(a)') 'SMALL' + write (imol2,'(a)') 'USER_CHARGES' + write (imol2,'(a)') '\@ATOM' + do i=nnt,nct + write (liczba,*) i + pom=ucase(restyp(itype(i))) + res_num = pom(:3)//liczba(2:) + write (imol2,10) i,(c(j,i),j=1,3),i,res_num,0.0 + enddo + write (imol2,'(a)') '\@BOND' + do i=nnt,nct-1 + write (imol2,'(i5,2i6,i2)') i-nnt+1,i-nnt+1,i-nnt+2,1 + enddo + do i=1,nss + write (imol2,'(i5,2i6,i2)') nct-nnt+i,ihpb(i),jhpb(i),1 + enddo + write (imol2,'(a)') '\@SUBSTRUCTURE' + do i=nnt,nct + write (liczba,*) i + pom = ucase(restyp(itype(i))) + res_num = pom(:3)//liczba(2:) + write (imol2,30) i-nnt+1,res_num,i-nnt+1,0 + enddo + 10 FORMAT (I7,' CA ',3F10.4,' C.3',I8,1X,A,F11.4,' ****') + 30 FORMAT (I7,1x,A,I14,' RESIDUE',I13,' **** ****') + return + end +c------------------------------------------------------------------------ + subroutine intout + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.NAMES' + include 'COMMON.GEO' + write (iout,'(/a)') 'Geometry of the virtual chain.' + write (iout,'(7a)') ' Res ',' Dpep',' Theta', + & ' Phi',' Dsc',' Alpha',' Omega' + do i=1,nres + iti=itype(i) + write (iout,'(a3,i4,6f10.3)') restyp(iti),i,vbld(i+1), + & rad2deg*theta(i), + & rad2deg*phi(i),vbld(nres+i),rad2deg*alph(i),rad2deg*omeg(i) + enddo + return + end +c--------------------------------------------------------------------------- + subroutine briefout(it,ener) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.NAMES' + include 'COMMON.GEO' + include 'COMMON.SBRIDGE' + print '(a,i5)',intname,igeom +#if defined(AIX) || defined(PGI) + open (igeom,file=intname,position='append') +#else + open (igeom,file=intname,access='append') +#endif + IF (NSS.LE.9) THEN + WRITE (igeom,180) IT,ENER,NSS,(IHPB(I),JHPB(I),I=1,NSS) + ELSE + WRITE (igeom,180) IT,ENER,NSS,(IHPB(I),JHPB(I),I=1,9) + WRITE (igeom,190) (IHPB(I),JHPB(I),I=10,NSS) + ENDIF +c IF (nvar.gt.nphi) WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES) + WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES) + WRITE (igeom,200) (RAD2DEG*PHI(I),I=4,NRES) +c if (nvar.gt.nphi+ntheta) then + write (igeom,200) (rad2deg*alph(i),i=2,nres-1) + write (igeom,200) (rad2deg*omeg(i),i=2,nres-1) +c endif + close(igeom) + 180 format (I5,F12.3,I2,9(1X,2I3)) + 190 format (3X,11(1X,2I3)) + 200 format (8F10.4) + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/gnmr1.f b/source/wham/src-NEWSC-NEWCORR/gnmr1.f new file mode 100644 index 0000000..905e746 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/gnmr1.f @@ -0,0 +1,43 @@ + double precision function gnmr1(y,ymin,ymax) + implicit none + double precision y,ymin,ymax + double precision wykl /4.0d0/ + if (y.lt.ymin) then + gnmr1=(ymin-y)**wykl/wykl + else if (y.gt.ymax) then + gnmr1=(y-ymax)**wykl/wykl + else + gnmr1=0.0d0 + endif + return + end +c------------------------------------------------------------------------------ + double precision function gnmr1prim(y,ymin,ymax) + implicit none + double precision y,ymin,ymax + double precision wykl /4.0d0/ + if (y.lt.ymin) then + gnmr1prim=-(ymin-y)**(wykl-1) + else if (y.gt.ymax) then + gnmr1prim=(y-ymax)**(wykl-1) + else + gnmr1prim=0.0d0 + endif + return + end +c------------------------------------------------------------------------------ + double precision function harmonic(y,ymax) + implicit none + double precision y,ymax + double precision wykl /2.0d0/ + harmonic=(y-ymax)**wykl + return + end +c------------------------------------------------------------------------------- + double precision function harmonicprim(y,ymax) + double precision y,ymin,ymax + double precision wykl /2.0d0/ + harmonicprim=(y-ymax)*wykl + return + end +c--------------------------------------------------------------------------------- diff --git a/source/wham/src-NEWSC-NEWCORR/icant.f b/source/wham/src-NEWSC-NEWCORR/icant.f new file mode 100644 index 0000000..8dc1ec1 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/icant.f @@ -0,0 +1,9 @@ + INTEGER FUNCTION ICANT(I,J) + IF (I.GE.J) THEN + ICANT=(I*(I-1))/2+J + ELSE + ICANT=(J*(J-1))/2+I + ENDIF + RETURN + END + diff --git a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.CALC b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.CALC new file mode 100644 index 0000000..67b4bb9 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.CALC @@ -0,0 +1,15 @@ + integer i,j,k,l + double precision erij,rij,xj,yj,zj,dxi,dyi,dzi,dxj,dyj,dzj, + & chi1,chi2,chi12,chip1,chip2,chip12,alf1,alf2,alf12,om1,om2,om12, + & om1om2,chiom1,chiom2,chiom12,chipom1,chipom2,chipom12,eps1, + & faceps1,faceps1_inv,eps1_om12,facsig,sigsq,sigsq_om1,sigsq_om2, + & sigsq_om12,facp,facp_inv,facp1,eps2rt,eps2rt_om1,eps2rt_om2, + & eps2rt_om12,eps3rt,eom1,eom2,eom12,evdwij,eps2der,eps3der,sigder, + & dsci_inv,dscj_inv,gg + common /calc/ erij(3),rij,xj,yj,zj,dxi,dyi,dzi,dxj,dyj,dzj, + & chi1,chi2,chi12,chip1,chip2,chip12,alf1,alf2,alf12,om1,om2,om12, + & om1om2,chiom1,chiom2,chiom12,chipom1,chipom2,chipom12,eps1, + & faceps1,faceps1_inv,eps1_om12,facsig,sigsq,sigsq_om1,sigsq_om2, + & sigsq_om12,facp,facp_inv,facp1,eps2rt,eps2rt_om1,eps2rt_om2, + & eps2rt_om12,eps3rt,eom1,eom2,eom12,evdwij,eps2der,eps3der,sigder, + & dsci_inv,dscj_inv,gg(3),i,j diff --git a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.CONTACTS b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.CONTACTS new file mode 100644 index 0000000..d07a0f0 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.CONTACTS @@ -0,0 +1,68 @@ +C Change 12/1/95 - common block CONTACTS1 included. + integer ncont,ncont_ref,icont,icont_ref,num_cont,jcont + double precision facont,gacont + common /contacts/ ncont,ncont_ref,icont(2,maxcont), + & icont_ref(2,maxcont) + common /contacts1/ facont(maxconts,maxres), + & gacont(3,maxconts,maxres), + & num_cont(maxres),jcont(maxconts,maxres) +C 12/26/95 - H-bonding contacts + common /contacts_hb/ + & gacontp_hb1(3,maxconts,maxres),gacontp_hb2(3,maxconts,maxres), + & gacontp_hb3(3,maxconts,maxres), + & gacontm_hb1(3,maxconts,maxres),gacontm_hb2(3,maxconts,maxres), + & gacontm_hb3(3,maxconts,maxres), + & gacont_hbr(3,maxconts,maxres), + & grij_hb_cont(3,maxconts,maxres), + & facont_hb(maxconts,maxres),ees0p(maxconts,maxres), + & ees0m(maxconts,maxres),d_cont(maxconts,maxres), + & num_cont_hb(maxres),jcont_hb(maxconts,maxres) +C 9/23/99 Added improper rotation matrices and matrices of dipole-dipole +C interactions +C Interactions of pseudo-dipoles generated by loc-el interactions. + double precision dip,dipderg,dipderx + common /dipint/ dip(4,maxconts,maxres),dipderg(4,maxconts,maxres), + & dipderx(3,5,4,maxconts,maxres) +C 10/30/99 Added other pre-computed vectors and matrices needed +C to calculate three - six-order el-loc correlation terms + double precision Ug,Ugder,Ug2,Ug2der,obrot,obrot2,obrot_der, + & obrot2_der,Ub2,Ub2der,mu,muder,EUg,EUgder,CUg,CUgder, + & DUg,DUgder,DtUg2,DtUg2der,Ctobr,Ctobrder,Dtobr2,Dtobr2der + common /rotat/ Ug(2,2,maxres),Ugder(2,2,maxres),Ug2(2,2,maxres), + & Ug2der(2,2,maxres),obrot(2,maxres),obrot2(2,maxres), + & obrot_der(2,maxres),obrot2_der(2,maxres) +C This common block contains vectors and matrices dependent on a single +C amino-acid residue. + common /precomp1/ Ub2(2,maxres),Ub2der(2,maxres),mu(2,maxres), + & EUg(2,2,maxres),EUgder(2,2,maxres),CUg(2,2,maxres), + & CUgder(2,2,maxres),DUg(2,2,maxres),Dugder(2,2,maxres), + & DtUg2(2,2,maxres),DtUg2der(2,2,maxres),Ctobr(2,maxres), + & Ctobrder(2,maxres),Dtobr2(2,maxres),Dtobr2der(2,maxres) +C This common block contains vectors and matrices dependent on two +C consecutive amino-acid residues. + double precision Ug2Db1t,Ug2Db1tder,CUgb2,CUgb2der,EUgC, + & EUgCder,EUgD,EUgDder,DtUg2EUg,DtUg2EUgder + common /precomp2/ Ug2Db1t(2,maxres),Ug2Db1tder(2,maxres), + & CUgb2(2,maxres),CUgb2der(2,maxres),EUgC(2,2,maxres), + & EUgCder(2,2,maxres),EUgD(2,2,maxres),EUgDder(2,2,maxres), + & DtUg2EUg(2,2,maxres),DtUg2EUgder(2,2,2,maxres), + & Ug2DtEUg(2,2,maxres),Ug2DtEUgder(2,2,2,maxres) + double precision costab,sintab,costab2,sintab2 + common /rotat_old/ costab(maxres),sintab(maxres), + & costab2(maxres),sintab2(maxres),muder(2,maxres) +C This common block contains dipole-interaction matrices and their +C Cartesian derivatives. + double precision a_chuj,a_chuj_der + common /dipmat/ a_chuj(2,2,maxconts,maxres), + & a_chuj_der(2,2,3,5,maxconts,maxres) + double precision AEA,AEAderg,AEAderx,AECA,AECAderg,AECAderx, + & ADtEA,ADtEAderg,ADtEAderx,AEAb1,AEAb1derg,AEAb1derx, + & AEAb2,AEAb2derg,AEAb2derx + common /diploc/ AEA(2,2,2),AEAderg(2,2,2),AEAderx(2,2,3,5,2,2), + & EAEA(2,2,2), EAEAderg(2,2,2,2), EAEAderx(2,2,3,5,2,2), + & AECA(2,2,2),AECAderg(2,2,2),AECAderx(2,2,3,5,2,2), + & ADtEA(2,2,2),ADtEAderg(2,2,2,2),ADtEAderx(2,2,3,5,2,2), + & ADtEA1(2,2,2),ADtEA1derg(2,2,2,2),ADtEA1derx(2,2,3,5,2,2), + & AEAb1(2,2,2),AEAb1derg(2,2,2),AEAb1derx(2,3,5,2,2,2), + & AEAb2(2,2,2),AEAb2derg(2,2,2,2),AEAb2derx(2,3,5,2,2,2), + & g_contij(3,2),ekont diff --git a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.CONTPAR b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.CONTPAR new file mode 100644 index 0000000..97a73eb --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.CONTPAR @@ -0,0 +1,3 @@ + double precision sig_comp,chi_comp,chip_comp,sc_cutoff + common /contpar/ sig_comp(ntyp,ntyp),chi_comp(ntyp,ntyp), + & chip_comp(ntyp,ntyp),sc_cutoff(ntyp,ntyp) diff --git a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.DERIV b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.DERIV new file mode 100644 index 0000000..79f8630 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.DERIV @@ -0,0 +1,30 @@ + double precision dcdv,dxdv,dxds,gradx,gradc,gvdwc,gelc,gvdwpp, + & gradx_scp,gvdwc_scp,ghpbx,ghpbc,gloc,gvdwx,gradcorr,gradxorr, + & gradcorr5,gradcorr6,gel_loc,gcorr3_turn,gcorr4_turn,gcorr6_turn, + & gel_loc_loc,gel_loc_turn3,gel_loc_turn4,gel_loc_turn6,gcorr_loc, + & g_corr5_loc,g_corr6_loc,gradb,gradbx,gsccorc,gsccorx,gsccor_loc, + & gscloc,gsclocx + integer nfl,icg + logical calc_grad + common /derivat/ dcdv(6,maxdim),dxdv(6,maxdim),dxds(6,maxres), + & gradx(3,maxres,2),gradc(3,maxres,2),gvdwx(3,maxres), + & gvdwc(3,maxres),gelc(3,maxres),gvdwpp(3,maxres), + & gradx_scp(3,maxres), + & gvdwc_scp(3,maxres),ghpbx(3,maxres),ghpbc(3,maxres), + & gloc(maxvar,2),gradcorr(3,maxres),gradxorr(3,maxres), + & gradcorr5(3,maxres),gradcorr6(3,maxres), + & gel_loc(3,maxres),gcorr3_turn(3,maxres),gcorr4_turn(3,maxres), + & gcorr6_turn(3,maxres),gradb(3,maxres),gradbx(3,maxres), + & gel_loc_loc(maxvar),gel_loc_turn3(maxvar),gel_loc_turn4(maxvar), + & gel_loc_turn6(maxvar),gcorr_loc(maxvar), + & g_corr5_loc(maxvar),g_corr6_loc(maxvar),gsccorc(3,maxres), + & gsccorx(3,maxres),gsccor_loc(maxres), + & gscloc(3,maxres),gsclocx(3,maxres),nfl,icg,calc_grad + double precision derx,derx_turn + common /deriv_loc/ derx(3,5,2),derx_turn(3,5,2) + double precision dXX_C1tab(3,maxres),dYY_C1tab(3,maxres), + & dZZ_C1tab(3,maxres),dXX_Ctab(3,maxres),dYY_Ctab(3,maxres), + & dZZ_Ctab(3,maxres),dXX_XYZtab(3,maxres),dYY_XYZtab(3,maxres), + & dZZ_XYZtab(3,maxres) + common /deriv_scloc/ dXX_C1tab,dYY_C1tab,dZZ_C1tab,dXX_Ctab, + & dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,dZZ_XYZtab diff --git a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.FFIELD b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.FFIELD new file mode 100644 index 0000000..8292679 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.FFIELD @@ -0,0 +1,29 @@ +C----------------------------------------------------------------------- +C The following COMMON block selects the type of the force field used in +C calculations and defines weights of various energy terms. +C 12/1/95 wcorr added +C----------------------------------------------------------------------- + double precision wsc,wscp,welec,wstrain,wtor,wtor_d,wang,wscloc, + & wcorr,wcorr4,wcorr5,wcorr6,wsccor,wel_loc,wturn3,wturn4, + & wturn6,wvdwpp,wbond,weights,scal14,cutoff_corr,delt_corr, + & r0_corr + integer ipot,n_ene_comp + common /ffield/ wsc,wscp,welec,wstrain,wtor,wtor_d,wang,wscloc, + & wcorr,wcorr4,wcorr5,wcorr6,wsccor,wel_loc,wturn3,wturn4, + & wturn6,wvdwpp,wbond,weights(max_ene), + & scal14,cutoff_corr,delt_corr,r0_corr,ipot,n_ene_comp + common /potentials/ potname(6) + character*3 potname +C----------------------------------------------------------------------- +C wlong,welec,wtor,wang,wscloc are the weight of the energy terms +C corresponding to side-chain, electrostatic, torsional, valence-angle, +C and local side-chain terms. +C +C IPOT determines which SC...SC interaction potential will be used: +C 1 - LJ: 2n-n Lennard-Jones +C 2 - LJK: 2n-n Kihara type (shifted Lennard-Jones) +C 3 - BP; Berne-Pechukas (angular dependence) +C 4 - GB; Gay-Berne (angular dependence) +C 5 - GBV; Gay-Berne-Vorobjev; angularly-dependent Kihara potential +C 6 - MM; Momo's physics-based potentials +C------------------------------------------------------------------------ diff --git a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.FRAG b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.FRAG new file mode 100644 index 0000000..ee151f5 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.FRAG @@ -0,0 +1,5 @@ + integer nbfrag,bfrag,nhfrag,hfrag,bvar_frag,hvar_frag,nhpb0, + & nh310frag,h310frag + COMMON /c_frag/ nbfrag,bfrag(4,maxres/3),nhfrag,hfrag(2,maxres/3), + & nh310frag,h310frag(2,maxres/2) + COMMON /frag/ bvar_frag(mxio,6),hvar_frag(mxio,3) diff --git a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.GEO b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.GEO new file mode 100644 index 0000000..8cfbbde --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.GEO @@ -0,0 +1,2 @@ + double precision pi,dwapi,pipol,pi3,dwapi3,deg2rad,rad2deg,angmin + common /geo/ pi,dwapi,pipol,pi3,dwapi3,deg2rad,rad2deg,angmin diff --git a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.HEADER b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.HEADER new file mode 100644 index 0000000..7154812 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.HEADER @@ -0,0 +1,2 @@ + character*80 titel + common /header/ titel diff --git a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.INTERACT b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.INTERACT new file mode 100644 index 0000000..9adbda4 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.INTERACT @@ -0,0 +1,38 @@ + double precision aa,bb,augm,aad,bad,app,bpp,ael6,ael3, + & chis,alphasur,sigmap1,sigmap2,alphiso,rborn,sigiso1,sigiso2, + & sig0head,epshead,wquad,dhead,dtail,wqdip,alphapol,wstate, + & epsintab,eps_out + + integer nnt,nct,nint_gr,istart,iend,itype,itel,itypro,ielstart, + & ielend,nscp_gr,iscpstart,iscpend,iatsc_s,iatsc_e,iatel_s, + & iatel_e,iatscp_s,iatscp_e,ispp,iscp,nstate,icharge,expon,expon2 + common /interact/aa(ntyp,ntyp),bb(ntyp,ntyp),augm(ntyp,ntyp), + & chis(ntyp,ntyp),alphasur(4,ntyp,ntyp),sigmap1(ntyp,ntyp), + & sigmap2(ntyp,ntyp),alphiso(4,ntyp,ntyp),alphapol(ntyp,ntyp), + & rborn(ntyp,ntyp),sigiso1(ntyp,ntyp),sigiso2(ntyp,ntyp), + & epshead(ntyp,ntyp),wquad(ntyp,ntyp),dhead(2,2,ntyp,ntyp), + & dtail(2,ntyp,ntyp),wqdip(2,ntyp,ntyp),epsintab(ntyp,ntyp), + & eps_out,wstate(4,ntyp,ntyp),sig0head(ntyp,ntyp), + & aad(ntyp,2),bad(ntyp,2),app(2,2),bpp(2,2),ael6(2,2),ael3(2,2), + & expon,expon2,nnt,nct,nint_gr(maxres),istart(maxres,maxint_gr), + & iend(maxres,maxint_gr),itype(maxres),itel(maxres),itypro, + & ielstart(maxres),ielend(maxres),nscp_gr(maxres), + & iscpstart(maxres,maxint_gr),iscpend(maxres,maxint_gr), + & iatsc_s,iatsc_e,iatel_s,iatel_e,iatscp_s,iatscp_e,ispp,iscp, + & nstate(ntyp,ntyp) +C 12/1/95 Array EPS included in the COMMON block. + double precision eps,sigma,sigmaii,rs0,chi,chip,chip0,alp,sigma0, + & sigii,rr0,r0,r0e,r0d,rpp,epp,elpp6,elpp3,eps_scp,rscp, + & chipp,eps_orig + common /body/eps(ntyp,ntyp),sigma(0:ntyp,0:ntyp), + & sigmaii(ntyp,ntyp), + & rs0(ntyp,ntyp),chi(ntyp,ntyp),chipp(ntyp,ntyp),chip(ntyp), + & chip0(ntyp),alp(ntyp), + & sigma0(ntyp),sigii(ntyp),rr0(ntyp),r0(ntyp,ntyp),r0e(ntyp,ntyp), + & r0d(ntyp,2),rpp(2,2),epp(2,2),elpp6(2,2),elpp3(2,2), + & eps_scp(20,2),rscp(20,2),eps_orig(ntyp,ntyp),icharge(ntyp) +c 12/5/03 modified 09/18/03 Bond stretching parameters. + double precision vbldp0,vbldsc0,akp,aksc,abond0 + integer nbondterm + common /stretch/ vbldp0,vbldsc0(maxbondterm,ntyp),akp, + & aksc(maxbondterm,ntyp),abond0(maxbondterm,ntyp),nbondterm(ntyp) diff --git a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.LOCAL b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.LOCAL new file mode 100644 index 0000000..a248d99 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.LOCAL @@ -0,0 +1,36 @@ + double precision a0thet,athet,bthet,polthet,gthet,theta0,sig0, + & sigc0,dsc,dsc_inv,bsc,censc,gaussc,dsc0,vbl,vblinv,vblinv2, + & vbl_cis,vbl0,vbld_inv + integer nlob,loc_start,loc_end,ithet_start,ithet_end, + & iphi_start,iphi_end,itau_start,itau_end +C Parameters of the virtual-bond-angle probability distribution + common /thetas/ a0thet(ntyp),athet(2,ntyp),bthet(2,ntyp), + & polthet(0:3,ntyp),gthet(3,ntyp),theta0(ntyp),sig0(ntyp), + & sigc0(ntyp) +C Parameters of ab initio-derived potential of virtual-bond-angle bending + integer nthetyp,ntheterm,ntheterm2,ntheterm3,nsingle,ndouble, + & ithetyp(ntyp1),nntheterm + double precision aa0thet(maxthetyp1,maxthetyp1,maxthetyp1), + & aathet(maxtheterm,maxthetyp1,maxthetyp1,maxthetyp1), + & bbthet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), + & ccthet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), + & ddthet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), + & eethet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), + & ffthet(maxdouble,maxdouble,maxtheterm3,maxthetyp1,maxthetyp1, + & maxthetyp1), + & ggthet(maxdouble,maxdouble,maxtheterm3,maxthetyp1,maxthetyp1, + & maxthetyp1) + common /theta_abinitio/aa0thet,aathet,bbthet,ccthet,ddthet,eethet, + & ffthet, + & ggthet,ithetyp,nthetyp,ntheterm,ntheterm2,ntheterm3,nsingle, + & ndouble,nntheterm +C Parameters of the side-chain probability distribution + common /sclocal/ dsc(ntyp1),dsc_inv(ntyp1),bsc(maxlob,ntyp), + & censc(3,maxlob,ntyp),gaussc(3,3,maxlob,ntyp),dsc0(ntyp1), + & nlob(ntyp1) +C Virtual-bond lenghts + common /peptbond/ vbl,vblinv,vblinv2,vbl_cis,vbl0 + common /indices/ loc_start,loc_end,ithet_start,ithet_end, + & iphi_start,iphi_end,itau_start,itau_end +C Inverses of the actual virtual bond lengths + common /invlen/ vbld_inv(maxres2) diff --git a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.MINIM b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.MINIM new file mode 100644 index 0000000..b231b47 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.MINIM @@ -0,0 +1,3 @@ + double precision tolf,rtolf + integer maxfun,maxmin + common /minimm/ tolf,rtolf,maxfun,maxmin diff --git a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.NAMES b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.NAMES new file mode 100644 index 0000000..a266339 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.NAMES @@ -0,0 +1,7 @@ + character*3 restyp + character*1 onelet + common /names/ restyp(ntyp+1),onelet(ntyp+1) + character*10 ename,wname + integer nprint_ene,print_order + common /namterm/ ename(max_ene),wname(max_ene),nprint_ene, + & print_order(max_ene) diff --git a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.SBRIDGE b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.SBRIDGE new file mode 100644 index 0000000..7bba010 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.SBRIDGE @@ -0,0 +1,10 @@ + double precision ebr,d0cm,akcm,akth,akct,v1ss,v2ss,v3ss,dhpb, + & dhpb1,forcon,weidis + integer ns,nss,nfree,iss,ihpb,jhpb,nhpb,link_start,link_end, + & ibecarb + common /sbridge/ ebr,d0cm,akcm,akth,akct,v1ss,v2ss,v3ss,ns,nss, + & nfree,iss(maxss) + common /links/ dhpb(maxdim),dhpb1(maxdim),forcon(maxdim), + & ihpb(maxdim),jhpb(maxdim),ibecarb(maxdim),nhpb + common /restraints/ weidis + common /links_split/ link_start,link_end diff --git a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.SCCOR b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.SCCOR new file mode 100644 index 0000000..28d748a --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.SCCOR @@ -0,0 +1,18 @@ +cc Parameters of the SCCOR term + double precision v1sccor,v2sccor,vlor1sccor, + & vlor2sccor,vlor3sccor,gloc_sc, + & dcostau,dsintau,dtauangle,dcosomicron, + & domicron,v0sccor + integer nterm_sccor,isccortyp,nsccortyp,nlor_sccor + common /sccor/ v1sccor(maxterm_sccor,3,20,20), + & v2sccor(maxterm_sccor,3,20,20), + & v0sccor(ntyp,ntyp), + & vlor1sccor(maxterm_sccor,20,20), + & vlor2sccor(maxterm_sccor,20,20), + & vlor3sccor(maxterm_sccor,20,20),gloc_sc(3,0:maxres2,10), + & dcostau(3,3,3,maxres2),dsintau(3,3,3,maxres2), + & dtauangle(3,3,3,maxres2),dcosomicron(3,3,3,maxres2), + & domicron(3,3,3,maxres2), + & nterm_sccor(ntyp,ntyp),isccortyp(ntyp),nsccortyp, + & nlor_sccor(ntyp,ntyp) + diff --git a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.SCROT b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.SCROT new file mode 100644 index 0000000..2da7b8f --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.SCROT @@ -0,0 +1,3 @@ +C Parameters of the SC rotamers (local) term + double precision sc_parmin + common/scrot/sc_parmin(maxsccoef,20) diff --git a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.TIME1 b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.TIME1 new file mode 100644 index 0000000..f7f4849 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.TIME1 @@ -0,0 +1,13 @@ + DOUBLE PRECISION BATIME,TIMLIM,STIME,PREVTIM,SAFETY,RSTIME + INTEGER WhatsUp,ndelta + logical cutoffviol,cutoffeval,llocal + COMMON/TIME1/STIME,TIMLIM,BATIME,PREVTIM,SAFETY,RSTIME + COMMON/STOPTIM/WhatsUp,ndelta,cutoffviol,cutoffeval,llocal + double precision t_func,t_grad,t_fhel,t_fbet,t_ghel,t_gbet,t_viol, + & t_gviol,t_map,t_alamap,t_betamap + integer n_func,n_grad,n_fhel,n_fbet,n_ghel,n_gbet,n_viol,n_gviol, + & n_map,n_alamap,n_betamap + common /timing/ t_func,t_grad,t_fhel,t_fbet,t_ghel,t_gbet,t_viol, + & t_gviol,t_map,t_alamap,t_betamap, + & n_func,n_grad,n_fhel,n_fbet,n_ghel,n_gbet,n_viol,n_gviol, + & n_map,n_alamap,n_betamap diff --git a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.TORCNSTR b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.TORCNSTR new file mode 100644 index 0000000..f8fc3a1 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.TORCNSTR @@ -0,0 +1,5 @@ + integer ndih_constr,idih_constr(maxdih_constr) + integer ndih_nconstr,idih_nconstr(maxdih_constr) + double precision phi0(maxdih_constr),drange(maxdih_constr),ftors + common /torcnstr/ phi0,drange,ftors,ndih_constr,idih_constr, + & ndih_nconstr,idih_nconstr diff --git a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.TORSION b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.TORSION new file mode 100644 index 0000000..f4ba10b --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.TORSION @@ -0,0 +1,29 @@ +C Torsional constants of the rotation about virtual-bond dihedral angles + double precision v1,v2,vlor1,vlor2,vlor3,v0 + integer itortyp,ntortyp,nterm,nlor,nterm_old + common/torsion/v0(maxtor,maxtor),v1(maxterm,maxtor,maxtor), + & v2(maxterm,maxtor,maxtor),vlor1(maxlor,maxtor,maxtor), + & vlor2(maxlor,maxtor,maxtor),vlor3(maxlor,maxtor,maxtor), + & itortyp(ntyp),ntortyp,nterm(maxtor,maxtor),nlor(maxtor,maxtor) + & ,nterm_old +C 6/23/01 - constants for double torsionals + double precision v1c,v1s,v2c,v2s + integer ntermd_1,ntermd_2 + common /torsiond/ v1c(2,maxtermd_1,maxtor,maxtor,maxtor), + & v1s(2,maxtermd_1,maxtor,maxtor,maxtor), + & v2c(maxtermd_2,maxtermd_2,maxtor,maxtor,maxtor), + & v2s(maxtermd_2,maxtermd_2,maxtor,maxtor,maxtor), + & ntermd_1(maxtor,maxtor,maxtor),ntermd_2(maxtor,maxtor,maxtor) +C 9/18/99 - added Fourier coeffficients of the expansion of local energy +C surface + double precision b1,b2,cc,dd,ee,ctilde,dtilde,b1tilde, + & bnew1,bnew2,eenew,eeold + integer nloctyp + common/fourier/ b1(2,maxtor),b2(2,maxtor), + & bnew1(3,2,maxtor),bnew2(3,2,maxtor), + & cc(2,2,maxtor), + & dd(2,2,maxtor),eeold(2,2,maxtor),eenew(2,maxtor), + & ee(2,2,maxtor),ctilde(2,2,maxtor),dtilde(2,2,maxtor), + & b1tilde(2,maxtor),nloctyp + double precision b + common /fourier1/ b(13,maxtor) diff --git a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.VAR b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.VAR new file mode 100644 index 0000000..d560c87 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.VAR @@ -0,0 +1,21 @@ +C Store the geometric variables in the following COMMON block. + integer ntheta,nphi,nside,nvar,Origin,nstore,ialph,ivar, + & mask_theta,mask_phi,mask_side + double precision theta,phi,alph,omeg,varsave,esave,varall,vbld, + & thetaref,phiref,costtab,sinttab,cost2tab,sint2tab, + & xxtab,yytab,zztab,xxref,yyref,zzref + common /var/ theta(maxres),phi(maxres),alph(maxres),omeg(maxres), + & omicron(2,maxres),tauangle(3,maxres), + & vbld(2*maxres),thetaref(maxres),phiref(maxres), + & costtab(maxres), sinttab(maxres), cost2tab(maxres), + & sint2tab(maxres),xxtab(maxres),yytab(maxres), + & zztab(maxres),xxref(maxres),yyref(maxres),zzref(maxres), + & ialph(maxres,2),ivar(4*maxres2),ntheta,nphi,nside,nvar +C Store the angles and variables corresponding to old conformations (for use +C in MCM). + common /oldgeo/ varsave(maxvar,maxsave),esave(maxsave), + & Origin(maxsave),nstore +C freeze some variables + logical mask_r + common /restr/ varall(maxvar),mask_r,mask_theta(maxres), + & mask_phi(maxres),mask_side(maxres) diff --git a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.VECTORS b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.VECTORS new file mode 100644 index 0000000..d880c24 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.VECTORS @@ -0,0 +1,3 @@ + common /vectors/ uy(3,maxres),uz(3,maxres), + & uygrad(3,3,2,maxres),uzgrad(3,3,2,maxres) + diff --git a/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.WEIGHTS b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.WEIGHTS new file mode 100644 index 0000000..d7e6e23 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/include_unres/COMMON.WEIGHTS @@ -0,0 +1,22 @@ + double precision ww,ww0,ww_low,ww_up,ww_orig,x_orig, + & epp_low,epp_up,rpp_low,rpp_up,elpp6_low,elpp6_up,elpp3_low, + & elpp3_up,b_low,b_up,epscp_low,epscp_up,rscp_low,rscp_up, + & x_up,x_low,xm,xm1,xm2,epss_low,epss_up,epsp_low,epsp_up + integer imask,mask_elec,mask_fourier,mod_fourier,mask_scp,indz,iw, + & nsingle_sc,npair_sc,ityp_ssc,ityp_psc + logical mod_other_params,mod_elec,mod_scp,mod_side + common /chujec/ ww(max_ene),ww0(max_ene),ww_low(max_ene), + & ww_up(max_ene),ww_orig(max_ene),x_orig(max_paropt), + & epp_low(2,2),epp_up(2,2),rpp_low(2,2),rpp_up(2,2), + & elpp6_low(2,2),elpp6_up(2,2),elpp3_low(2,2),elpp3_up(2,2), + & b_low(13,3),b_up(13,3),x_up(max_paropt),x_low(max_paropt), + & epscp_low(0:20,2),epscp_up(0:20,2),rscp_low(0:20,2), + & rscp_up(0:20,2),epss_low(ntyp),epss_up(ntyp),epsp_low(nntyp), + & epsp_up(nntyp), + & xm(max_paropt,0:maxprot),xm1(max_paropt,0:maxprot), + & xm2(max_paropt,0:maxprot), + & imask(max_ene),nsingle_sc,npair_sc,ityp_ssc(ntyp), + & ityp_psc(2,nntyp),mask_elec(2,2,4), + & mask_fourier(13,3), + & mask_scp(0:20,2,2),mod_other_params,mod_fourier(0:3), + & mod_elec,mod_scp,mod_side,indz(maxbatch+1,maxprot),iw(max_ene) diff --git a/source/wham/src-NEWSC-NEWCORR/initialize_p.F b/source/wham/src-NEWSC-NEWCORR/initialize_p.F new file mode 100644 index 0000000..7ac8109 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/initialize_p.F @@ -0,0 +1,577 @@ + subroutine initialize +C +C Define constants and zero out tables. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + include 'COMMON.MINIM' + include 'COMMON.DERIV' + include "COMMON.WEIGHTS" + include "COMMON.NAMES" + include "COMMON.TIME1" +C +C The following is just to define auxiliary variables used in angle conversion +C + pi=4.0D0*datan(1.0D0) + dwapi=2.0D0*pi + dwapi3=dwapi/3.0D0 + pipol=0.5D0*pi + deg2rad=pi/180.0D0 + rad2deg=1.0D0/deg2rad + angmin=10.0D0*deg2rad +C +C Define I/O units. +C + inp= 1 + iout= 2 + ipdbin= 3 + ipdb= 7 + imol2= 4 + igeom= 8 + intin= 9 + ithep= 11 + irotam=12 + itorp= 13 + itordp= 23 + ielep= 14 + isidep=15 + isidep1=22 + iscpp=25 + icbase=16 + ifourier=20 + istat= 17 + ientin=18 + ientout=19 + ibond=28 + isccor=29 +C +C WHAM files +C + ihist=30 + iweight=31 + izsc=32 +C +C Set default weights of the energy terms. +C + wlong=1.0D0 + welec=1.0D0 + wtor =1.0D0 + wang =1.0D0 + wscloc=1.0D0 + wstrain=1.0D0 +C +C Zero out tables. +C + ndih_constr=0 + do i=1,maxres2 + do j=1,3 + c(j,i)=0.0D0 + dc(j,i)=0.0D0 + enddo + enddo + do i=1,maxres + do j=1,3 + xloc(j,i)=0.0D0 + enddo + enddo + do i=1,ntyp + do j=1,ntyp + aa(i,j)=0.0D0 + bb(i,j)=0.0D0 + augm(i,j)=0.0D0 + sigma(i,j)=0.0D0 + r0(i,j)=0.0D0 + chi(i,j)=0.0D0 + enddo + do j=1,2 + bad(i,j)=0.0D0 + enddo + chip(i)=0.0D0 + alp(i)=0.0D0 + sigma0(i)=0.0D0 + sigii(i)=0.0D0 + rr0(i)=0.0D0 + a0thet(i)=0.0D0 + do j=1,2 + athet(j,i)=0.0D0 + bthet(j,i)=0.0D0 + enddo + do j=0,3 + polthet(j,i)=0.0D0 + enddo + do j=1,3 + gthet(j,i)=0.0D0 + enddo + theta0(i)=0.0D0 + sig0(i)=0.0D0 + sigc0(i)=0.0D0 + do j=1,maxlob + bsc(j,i)=0.0D0 + do k=1,3 + censc(k,j,i)=0.0D0 + enddo + do k=1,3 + do l=1,3 + gaussc(l,k,j,i)=0.0D0 + enddo + enddo + nlob(i)=0 + enddo + enddo + nlob(ntyp1)=0 + dsc(ntyp1)=0.0D0 + do i=1,maxtor + itortyp(i)=0 + do j=1,maxtor + do k=1,maxterm + v1(k,j,i)=0.0D0 + v2(k,j,i)=0.0D0 + enddo + enddo + enddo + do i=1,maxres + itype(i)=0 + itel(i)=0 + enddo +C Initialize the bridge arrays + ns=0 + nss=0 + nhpb=0 + do i=1,maxss + iss(i)=0 + enddo + do i=1,maxdim + dhpb(i)=0.0D0 + enddo + do i=1,maxres + ihpb(i)=0 + jhpb(i)=0 + enddo +C +C Initialize timing. +C + call set_timers +C +C Initialize variables used in minimization. +C +c maxfun=5000 +c maxit=2000 + maxfun=500 + maxit=200 + tolf=1.0D-2 + rtolf=5.0D-4 +C +C Initialize the variables responsible for the mode of gradient storage. +C + nfl=0 + icg=1 + do i=1,14 + do j=1,14 + if (print_order(i).eq.j) then + iw(print_order(i))=j + goto 1121 + endif + enddo +1121 continue + enddo + calc_grad=.false. +C Set timers and counters for the respective routines + t_func = 0.0d0 + t_grad = 0.0d0 + t_fhel = 0.0d0 + t_fbet = 0.0d0 + t_ghel = 0.0d0 + t_gbet = 0.0d0 + t_viol = 0.0d0 + t_gviol = 0.0d0 + n_func = 0 + n_grad = 0 + n_fhel = 0 + n_fbet = 0 + n_ghel = 0 + n_gbet = 0 + n_viol = 0 + n_gviol = 0 + n_map = 0 +#ifndef SPLITELE + nprint_ene=nprint_ene-1 +#endif + return + end +c------------------------------------------------------------------------- + block data nazwy + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.NAMES' + include 'COMMON.WEIGHTS' + include 'COMMON.FFIELD' + include 'COMMON.INTERACT' + data restyp / + &'CYS','MET','PHE','ILE','LEU','VAL','TRP','TYR','ALA','GLY','THR', + &'SER','GLN','ASN','GLU','ASP','HIS','ARG','LYS','PRO','D'/ + data onelet / + &'C','M','F','I','L','V','W','Y','A','G','T', + &'S','Q','N','E','D','H','R','K','P','X'/ + data potname /'LJ','LJK','BP','GB','GBV','MM'/ + data ename / + & "EVDW SC-SC","EVDW2 SC-p","EES p-p","ECORR4 ","ECORR5 ", + & "ECORR6 ","EELLO ","ETURN3 ","ETURN4 ","ETURN6 ", + & "EBE bend","ESC SCloc","ETORS ","ETORSD ","EHPB","EVDWPP", + & "EVDW2_14","ESTR","ESCCOR","EDIHC","EVDW_T"/ + data wname / + & "WSC","WSCP","WELEC","WCORR","WCORR5","WCORR6","WEL_LOC", + & "WTURN3","WTURN4","WTURN6","WANG","WSCLOC","WTOR","WTORD", + & "WHPB","WVDWPP","WSCP14","WBOND","WSCCOR","WDIHC","WSC"/ + data ww0 /1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0, + & 1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,0.4d0,1.0d0,1.0d0, + & 0.0d0,0.0/ + data nprint_ene /21/ + data print_order /1,2,3,18,11,12,13,14,4,5,6,7,8,9,10,19, + & 16,15,17,20,21/ +c Dielectric constant of water + data eps_out /80.0d0/ + end +c--------------------------------------------------------------------------- + subroutine init_int_table + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' +#ifdef MPI + include 'mpif.h' +#endif +#ifdef MP + include 'COMMON.INFO' +#endif + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.LOCAL' + include 'COMMON.SBRIDGE' + include 'COMMON.IOUNITS' + logical scheck,lprint +#ifdef MPL + integer my_sc_int(0:max_fg_Procs-1),my_sc_intt(0:max_fg_Procs), + & 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. + lprint=.false. + if (lprint) + &write (iout,*) 'INIT_INT_TABLE nres=',nres,' nnt=',nnt,' nct=',nct + n_sc_int_tot=(nct-nnt+1)*(nct-nnt)/2-nss + MyRank=MyID-(MyGroup-1)*fgProcs + call int_bounds(n_sc_int_tot,my_sc_inds,my_sc_inde) + if (lprint) + & write (iout,*) 'Processor',MyID,' MyRank',MyRank, + & ' n_sc_int_tot',n_sc_int_tot,' my_sc_inds=',my_sc_inds, + & ' my_sc_inde',my_sc_inde + ind_sctint=0 + iatsc_s=0 + iatsc_e=0 +#endif + lprint=.false. + do i=1,maxres + nint_gr(i)=0 + nscp_gr(i)=0 + do j=1,maxint_gr + istart(i,1)=0 + iend(i,1)=0 + ielstart(i)=0 + ielend(i)=0 + iscpstart(i,1)=0 + iscpend(i,1)=0 + enddo + enddo + ind_scint=0 + ind_scint_old=0 +cd write (iout,*) 'ns=',ns,' nss=',nss,' ihpb,jhpb', +cd & (ihpb(i),jhpb(i),i=1,nss) + do i=nnt,nct-1 + scheck=.false. + do ii=1,nss + if (ihpb(ii).eq.i+nres) then + scheck=.true. + jj=jhpb(ii)-nres + goto 10 + endif + enddo + 10 continue +cd write (iout,*) 'i=',i,' scheck=',scheck,' jj=',jj + if (scheck) then + if (jj.eq.i+1) then +#ifdef MPL + write (iout,*) 'jj=i+1' + call int_partition(ind_scint,my_sc_inds,my_sc_inde,i, + & iatsc_s,iatsc_e,i+2,nct,nint_gr(i),istart(i,1),iend(i,1),*12) +#else + nint_gr(i)=1 + istart(i,1)=i+2 + iend(i,1)=nct +#endif + else if (jj.eq.nct) then +#ifdef MPL + write (iout,*) 'jj=nct' + call int_partition(ind_scint,my_sc_inds,my_sc_inde,i, + & iatsc_s,iatsc_e,i+1,nct-1,nint_gr(i),istart(i,1),iend(i,1),*12) +#else + nint_gr(i)=1 + istart(i,1)=i+1 + iend(i,1)=nct-1 +#endif + else +#ifdef MPL + call int_partition(ind_scint,my_sc_inds,my_sc_inde,i, + & iatsc_s,iatsc_e,i+1,jj-1,nint_gr(i),istart(i,1),iend(i,1),*12) + ii=nint_gr(i)+1 + call int_partition(ind_scint,my_sc_inds,my_sc_inde,i, + & iatsc_s,iatsc_e,jj+1,nct,nint_gr(i),istart(i,ii),iend(i,ii),*12) +#else + nint_gr(i)=2 + istart(i,1)=i+1 + iend(i,1)=jj-1 + istart(i,2)=jj+1 + iend(i,2)=nct +#endif + endif + else +#ifdef MPL + call int_partition(ind_scint,my_sc_inds,my_sc_inde,i, + & iatsc_s,iatsc_e,i+1,nct,nint_gr(i),istart(i,1),iend(i,1),*12) +#else + nint_gr(i)=1 + istart(i,1)=i+1 + iend(i,1)=nct + ind_scint=int_scint+nct-i +#endif + endif +#ifdef MPL + ind_scint_old=ind_scint +#endif + enddo + 12 continue +#ifndef MPL + iatsc_s=nnt + iatsc_e=nct-1 +#endif +#ifdef MPL + if (lprint) then + write (iout,*) 'Processor',MyID,' Group',MyGroup + write (iout,*) 'iatsc_s=',iatsc_s,' iatsc_e=',iatsc_e + endif +#endif + if (lprint) then + write (iout,'(a)') 'Interaction array:' + do i=iatsc_s,iatsc_e + write (iout,'(i3,2(2x,2i3))') + & i,(istart(i,iint),iend(i,iint),iint=1,nint_gr(i)) + enddo + endif + ispp=2 +#ifdef MPL +C Now partition the electrostatic-interaction array + npept=nct-nnt + nele_int_tot=(npept-ispp)*(npept-ispp+1)/2 + call int_bounds(nele_int_tot,my_ele_inds,my_ele_inde) + if (lprint) + & write (iout,*) 'Processor',MyID,' MyRank',MyRank, + & ' nele_int_tot',nele_int_tot,' my_ele_inds=',my_ele_inds, + & ' my_ele_inde',my_ele_inde + iatel_s=0 + iatel_e=0 + ind_eleint=0 + ind_eleint_old=0 + do i=nnt,nct-3 + ijunk=0 + call int_partition(ind_eleint,my_ele_inds,my_ele_inde,i, + & iatel_s,iatel_e,i+ispp,nct-1,ijunk,ielstart(i),ielend(i),*13) + enddo ! i + 13 continue +#else + iatel_s=nnt + iatel_e=nct-3 + do i=iatel_s,iatel_e + ielstart(i)=i+2 + ielend(i)=nct-1 + enddo +#endif + if (lprint) then + write (iout,'(a)') 'Electrostatic interaction array:' + do i=iatel_s,iatel_e + write (iout,'(i3,2(2x,2i3))') i,ielstart(i),ielend(i) + enddo + endif ! lprint +c iscp=3 + iscp=2 +C Partition the SC-p interaction array +#ifdef MPL + nscp_int_tot=(npept-iscp+1)*(npept-iscp+1) + call int_bounds(nscp_int_tot,my_scp_inds,my_scp_inde) + if (lprint) + & write (iout,*) 'Processor',MyID,' MyRank',MyRank, + & ' nscp_int_tot',nscp_int_tot,' my_scp_inds=',my_scp_inds, + & ' my_scp_inde',my_scp_inde + iatscp_s=0 + iatscp_e=0 + ind_scpint=0 + ind_scpint_old=0 + do i=nnt,nct-1 + if (i.lt.nnt+iscp) then +cd write (iout,*) 'i.le.nnt+iscp' + call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i, + & iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,1), + & iscpend(i,1),*14) + else if (i.gt.nct-iscp) then +cd write (iout,*) 'i.gt.nct-iscp' + call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i, + & iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1), + & iscpend(i,1),*14) + else + call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i, + & iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1), + & iscpend(i,1),*14) + ii=nscp_gr(i)+1 + call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i, + & iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,ii), + & iscpend(i,ii),*14) + endif + enddo ! i + 14 continue +#else + iatscp_s=nnt + iatscp_e=nct-1 + do i=nnt,nct-1 + if (i.lt.nnt+iscp) then + nscp_gr(i)=1 + iscpstart(i,1)=i+iscp + iscpend(i,1)=nct + elseif (i.gt.nct-iscp) then + nscp_gr(i)=1 + iscpstart(i,1)=nnt + iscpend(i,1)=i-iscp + else + nscp_gr(i)=2 + iscpstart(i,1)=nnt + iscpend(i,1)=i-iscp + iscpstart(i,2)=i+iscp + iscpend(i,2)=nct + endif + enddo ! i +#endif + if (lprint) then + write (iout,'(a)') 'SC-p interaction array:' + do i=iatscp_s,iatscp_e + write (iout,'(i3,2(2x,2i3))') + & i,(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i)) + enddo + endif ! lprint +C Partition local interactions +#ifdef MPL + call int_bounds(nres-2,loc_start,loc_end) + loc_start=loc_start+1 + loc_end=loc_end+1 + call int_bounds(nres-2,ithet_start,ithet_end) + ithet_start=ithet_start+2 + ithet_end=ithet_end+2 + call int_bounds(nct-nnt-2,iphi_start,iphi_end) + iphi_start=iphi_start+nnt+2 + iphi_end=iphi_end+nnt+2 + call int_bounds(nres-3,itau_start,itau_end) + itau_start=itau_start+3 + itau_end=itau_end+3 + if (lprint) then + write (iout,*) 'Processor:',MyID, + & ' loc_start',loc_start,' loc_end',loc_end, + & ' ithet_start',ithet_start,' ithet_end',ithet_end, + & ' iphi_start',iphi_start,' iphi_end',iphi_end + write (*,*) 'Processor:',MyID, + & ' loc_start',loc_start,' loc_end',loc_end, + & ' ithet_start',ithet_start,' ithet_end',ithet_end, + & ' iphi_start',iphi_start,' iphi_end',iphi_end + endif + if (fgprocs.gt.1 .and. MyID.eq.BossID) then + write(iout,'(i10,a,i10,a,i10,a/a,i3,a)') n_sc_int_tot,' SC-SC ', + & nele_int_tot,' electrostatic and ',nscp_int_tot, + & ' SC-p interactions','were distributed among',fgprocs, + & ' fine-grain processors.' + endif +#else + loc_start=2 + loc_end=nres-1 + ithet_start=3 + ithet_end=nres + iphi_start=nnt+3 + iphi_end=nct + itau_start=4 + itau_end=nres +#endif + return + end +c--------------------------------------------------------------------------- + subroutine int_partition(int_index,lower_index,upper_index,atom, + & at_start,at_end,first_atom,last_atom,int_gr,jat_start,jat_end,*) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + integer int_index,lower_index,upper_index,atom,at_start,at_end, + & first_atom,last_atom,int_gr,jat_start,jat_end + logical lprn + lprn=.false. + if (lprn) write (iout,*) 'int_index=',int_index + int_index_old=int_index + int_index=int_index+last_atom-first_atom+1 + if (lprn) + & write (iout,*) 'int_index=',int_index, + & ' int_index_old',int_index_old, + & ' lower_index=',lower_index, + & ' upper_index=',upper_index, + & ' atom=',atom,' first_atom=',first_atom, + & ' last_atom=',last_atom + if (int_index.ge.lower_index) then + int_gr=int_gr+1 + if (at_start.eq.0) then + at_start=atom + jat_start=first_atom-1+lower_index-int_index_old + else + jat_start=first_atom + endif + if (lprn) write (iout,*) 'jat_start',jat_start + if (int_index.ge.upper_index) then + at_end=atom + jat_end=first_atom-1+upper_index-int_index_old + return1 + else + jat_end=last_atom + endif + if (lprn) write (iout,*) 'jat_end',jat_end + endif + return + end +c------------------------------------------------------------------------------ + subroutine hpb_partition + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.SBRIDGE' + include 'COMMON.IOUNITS' +#ifdef MPL + include 'COMMON.INFO' + call int_bounds(nhpb,link_start,link_end) +#else + link_start=1 + link_end=nhpb +#endif +cd write (iout,*) 'Processor',MyID,' MyRank',MyRank, +cd & ' nhpb',nhpb,' link_start=',link_start, +cd & ' link_end',link_end + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/initialize_p.F.org b/source/wham/src-NEWSC-NEWCORR/initialize_p.F.org new file mode 100644 index 0000000..3e7d056 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/initialize_p.F.org @@ -0,0 +1,571 @@ + subroutine initialize +C +C Define constants and zero out tables. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + include 'COMMON.MINIM' + include 'COMMON.DERIV' + include "COMMON.WEIGHTS" + include "COMMON.NAMES" + include "COMMON.TIME1" +C +C The following is just to define auxiliary variables used in angle conversion +C + pi=4.0D0*datan(1.0D0) + dwapi=2.0D0*pi + dwapi3=dwapi/3.0D0 + pipol=0.5D0*pi + deg2rad=pi/180.0D0 + rad2deg=1.0D0/deg2rad + angmin=10.0D0*deg2rad +C +C Define I/O units. +C + inp= 1 + iout= 2 + ipdbin= 3 + ipdb= 7 + imol2= 4 + igeom= 8 + intin= 9 + ithep= 11 + irotam=12 + itorp= 13 + itordp= 23 + ielep= 14 + isidep=15 + iscpp=25 + icbase=16 + ifourier=20 + istat= 17 + ientin=18 + ientout=19 +C +C CSA I/O units (separated from others especially for Jooyoung) +C + icsa_rbank=30 + icsa_seed=31 + icsa_history=32 + icsa_bank=33 + icsa_bank1=34 + icsa_alpha=35 + icsa_alpha1=36 + icsa_bankt=37 + icsa_int=39 + icsa_bank_reminimized=38 + icsa_native_int=41 + icsa_in=40 +C +C Set default weights of the energy terms. +C + wlong=1.0D0 + welec=1.0D0 + wtor =1.0D0 + wang =1.0D0 + wscloc=1.0D0 + wstrain=1.0D0 +C +C Zero out tables. +C + ndih_constr=0 + do i=1,maxres2 + do j=1,3 + c(j,i)=0.0D0 + dc(j,i)=0.0D0 + enddo + enddo + do i=1,maxres + do j=1,3 + xloc(j,i)=0.0D0 + enddo + enddo + do i=1,ntyp + do j=1,ntyp + aa(i,j)=0.0D0 + bb(i,j)=0.0D0 + augm(i,j)=0.0D0 + sigma(i,j)=0.0D0 + r0(i,j)=0.0D0 + chi(i,j)=0.0D0 + enddo + do j=1,2 + bad(i,j)=0.0D0 + enddo + chip(i)=0.0D0 + alp(i)=0.0D0 + sigma0(i)=0.0D0 + sigii(i)=0.0D0 + rr0(i)=0.0D0 + a0thet(i)=0.0D0 + do j=1,2 + athet(j,i)=0.0D0 + bthet(j,i)=0.0D0 + enddo + do j=0,3 + polthet(j,i)=0.0D0 + enddo + do j=1,3 + gthet(j,i)=0.0D0 + enddo + theta0(i)=0.0D0 + sig0(i)=0.0D0 + sigc0(i)=0.0D0 + do j=1,maxlob + bsc(j,i)=0.0D0 + do k=1,3 + censc(k,j,i)=0.0D0 + enddo + do k=1,3 + do l=1,3 + gaussc(l,k,j,i)=0.0D0 + enddo + enddo + nlob(i)=0 + enddo + enddo + nlob(ntyp1)=0 + dsc(ntyp1)=0.0D0 + do i=1,maxtor + itortyp(i)=0 + do j=1,maxtor + do k=1,maxterm + v1(k,j,i)=0.0D0 + v2(k,j,i)=0.0D0 + enddo + enddo + enddo + do i=1,maxres + itype(i)=0 + itel(i)=0 + enddo +C Initialize the bridge arrays + ns=0 + nss=0 + nhpb=0 + do i=1,maxss + iss(i)=0 + enddo + do i=1,maxdim + dhpb(i)=0.0D0 + enddo + do i=1,maxres + ihpb(i)=0 + jhpb(i)=0 + enddo +C +C Initialize timing. +C + call set_timers +C +C Initialize variables used in minimization. +C +c maxfun=5000 +c maxit=2000 + maxfun=500 + maxit=200 + tolf=1.0D-2 + rtolf=5.0D-4 +C +C Initialize the variables responsible for the mode of gradient storage. +C + nfl=0 + icg=1 + do i=1,14 + do j=1,14 + if (print_order(i).eq.j) then + iw(print_order(i))=j + goto 1121 + endif + enddo +1121 continue + enddo + calc_grad=.false. +C Set timers and counters for the respective routines + t_func = 0.0d0 + t_grad = 0.0d0 + t_fhel = 0.0d0 + t_fbet = 0.0d0 + t_ghel = 0.0d0 + t_gbet = 0.0d0 + t_viol = 0.0d0 + t_gviol = 0.0d0 + n_func = 0 + n_grad = 0 + n_fhel = 0 + n_fbet = 0 + n_ghel = 0 + n_gbet = 0 + n_viol = 0 + n_gviol = 0 + n_map = 0 + return + end +c------------------------------------------------------------------------- + block data nazwy + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + data restyp / + &'CYS','MET','PHE','ILE','LEU','VAL','TRP','TYR','ALA','GLY','THR', + &'SER','GLN','ASN','GLU','ASP','HIS','ARG','LYS','PRO','D'/ + data onelet / + &'C','M','F','I','L','V','W','Y','A','G','T', + &'S','Q','N','E','D','H','R','K','P','X'/ + data potname /'LJ','LJK','BP','GB','GBV'/ + data ename / + & "EVDW SC-SC","EVDW2 SC-p","EES p-p","ECORR4 ","ECORR5 ", + & "ECORR6 ","EELLO ","ETURN3 ","ETURN4 ","ETURN6 ", + & "EBE bend","ESC SCloc","ETORS ","ETORSD ","EVDW2_14",2*" "/ + data wname / + & "WSC","WSCP","WELEC","WCORR","WCORR5","WCORR6","WEL_LOC", + & "WTURN3","WTURN4","WTURN6","WANG","WSCLOC","WTOR","WTORD", + & "SCAL14",2*" "/ +#ifdef SCP14 + data nprint_ene /15/ + data print_order /1,2,3,11,12,13,14,4,5,6,7,8,9,10,16,0/ +#else + data nprint_ene /14/ + data print_order /1,2,3,11,12,13,14,4,5,6,7,8,9,10,3*0/ +#endif + end +c--------------------------------------------------------------------------- + subroutine init_int_table + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' +#ifdef MPI + include 'mpif.h' +#endif +#ifdef MP + include 'COMMON.INFO' +#endif + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.LOCAL' + include 'COMMON.SBRIDGE' + include 'COMMON.IOUNITS' + logical scheck,lprint +#ifdef MPL + integer my_sc_int(0:max_fg_Procs-1),my_sc_intt(0:max_fg_Procs), + & 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. + lprint=.false. + if (lprint) + &write (iout,*) 'INIT_INT_TABLE nres=',nres,' nnt=',nnt,' nct=',nct + n_sc_int_tot=(nct-nnt+1)*(nct-nnt)/2-nss + MyRank=MyID-(MyGroup-1)*fgProcs + call int_bounds(n_sc_int_tot,my_sc_inds,my_sc_inde) + if (lprint) + & write (iout,*) 'Processor',MyID,' MyRank',MyRank, + & ' n_sc_int_tot',n_sc_int_tot,' my_sc_inds=',my_sc_inds, + & ' my_sc_inde',my_sc_inde + ind_sctint=0 + iatsc_s=0 + iatsc_e=0 +#endif + lprint=.false. + do i=1,maxres + nint_gr(i)=0 + nscp_gr(i)=0 + do j=1,maxint_gr + istart(i,1)=0 + iend(i,1)=0 + ielstart(i)=0 + ielend(i)=0 + iscpstart(i,1)=0 + iscpend(i,1)=0 + enddo + enddo + ind_scint=0 + ind_scint_old=0 +cd write (iout,*) 'ns=',ns,' nss=',nss,' ihpb,jhpb', +cd & (ihpb(i),jhpb(i),i=1,nss) + do i=nnt,nct-1 + scheck=.false. + do ii=1,nss + if (ihpb(ii).eq.i+nres) then + scheck=.true. + jj=jhpb(ii)-nres + goto 10 + endif + enddo + 10 continue +cd write (iout,*) 'i=',i,' scheck=',scheck,' jj=',jj + if (scheck) then + if (jj.eq.i+1) then +#ifdef MPL + write (iout,*) 'jj=i+1' + call int_partition(ind_scint,my_sc_inds,my_sc_inde,i, + & iatsc_s,iatsc_e,i+2,nct,nint_gr(i),istart(i,1),iend(i,1),*12) +#else + nint_gr(i)=1 + istart(i,1)=i+2 + iend(i,1)=nct +#endif + else if (jj.eq.nct) then +#ifdef MPL + write (iout,*) 'jj=nct' + call int_partition(ind_scint,my_sc_inds,my_sc_inde,i, + & iatsc_s,iatsc_e,i+1,nct-1,nint_gr(i),istart(i,1),iend(i,1),*12) +#else + nint_gr(i)=1 + istart(i,1)=i+1 + iend(i,1)=nct-1 +#endif + else +#ifdef MPL + call int_partition(ind_scint,my_sc_inds,my_sc_inde,i, + & iatsc_s,iatsc_e,i+1,jj-1,nint_gr(i),istart(i,1),iend(i,1),*12) + ii=nint_gr(i)+1 + call int_partition(ind_scint,my_sc_inds,my_sc_inde,i, + & iatsc_s,iatsc_e,jj+1,nct,nint_gr(i),istart(i,ii),iend(i,ii),*12) +#else + nint_gr(i)=2 + istart(i,1)=i+1 + iend(i,1)=jj-1 + istart(i,2)=jj+1 + iend(i,2)=nct +#endif + endif + else +#ifdef MPL + call int_partition(ind_scint,my_sc_inds,my_sc_inde,i, + & iatsc_s,iatsc_e,i+1,nct,nint_gr(i),istart(i,1),iend(i,1),*12) +#else + nint_gr(i)=1 + istart(i,1)=i+1 + iend(i,1)=nct + ind_scint=int_scint+nct-i +#endif + endif +#ifdef MPL + ind_scint_old=ind_scint +#endif + enddo + 12 continue +#ifndef MPL + iatsc_s=nnt + iatsc_e=nct-1 +#endif +#ifdef MPL + if (lprint) then + write (iout,*) 'Processor',MyID,' Group',MyGroup + write (iout,*) 'iatsc_s=',iatsc_s,' iatsc_e=',iatsc_e + endif +#endif + if (lprint) then + write (iout,'(a)') 'Interaction array:' + do i=iatsc_s,iatsc_e + write (iout,'(i3,2(2x,2i3))') + & i,(istart(i,iint),iend(i,iint),iint=1,nint_gr(i)) + enddo + endif + ispp=2 +#ifdef MPL +C Now partition the electrostatic-interaction array + npept=nct-nnt + nele_int_tot=(npept-ispp)*(npept-ispp+1)/2 + call int_bounds(nele_int_tot,my_ele_inds,my_ele_inde) + if (lprint) + & write (iout,*) 'Processor',MyID,' MyRank',MyRank, + & ' nele_int_tot',nele_int_tot,' my_ele_inds=',my_ele_inds, + & ' my_ele_inde',my_ele_inde + iatel_s=0 + iatel_e=0 + ind_eleint=0 + ind_eleint_old=0 + do i=nnt,nct-3 + ijunk=0 + call int_partition(ind_eleint,my_ele_inds,my_ele_inde,i, + & iatel_s,iatel_e,i+ispp,nct-1,ijunk,ielstart(i),ielend(i),*13) + enddo ! i + 13 continue +#else + iatel_s=nnt + iatel_e=nct-3 + do i=iatel_s,iatel_e + ielstart(i)=i+2 + ielend(i)=nct-1 + enddo +#endif + if (lprint) then + write (iout,'(a)') 'Electrostatic interaction array:' + do i=iatel_s,iatel_e + write (iout,'(i3,2(2x,2i3))') i,ielstart(i),ielend(i) + enddo + endif ! lprint +c iscp=3 + iscp=2 +C Partition the SC-p interaction array +#ifdef MPL + nscp_int_tot=(npept-iscp+1)*(npept-iscp+1) + call int_bounds(nscp_int_tot,my_scp_inds,my_scp_inde) + if (lprint) + & write (iout,*) 'Processor',MyID,' MyRank',MyRank, + & ' nscp_int_tot',nscp_int_tot,' my_scp_inds=',my_scp_inds, + & ' my_scp_inde',my_scp_inde + iatscp_s=0 + iatscp_e=0 + ind_scpint=0 + ind_scpint_old=0 + do i=nnt,nct-1 + if (i.lt.nnt+iscp) then +cd write (iout,*) 'i.le.nnt+iscp' + call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i, + & iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,1), + & iscpend(i,1),*14) + else if (i.gt.nct-iscp) then +cd write (iout,*) 'i.gt.nct-iscp' + call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i, + & iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1), + & iscpend(i,1),*14) + else + call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i, + & iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1), + & iscpend(i,1),*14) + ii=nscp_gr(i)+1 + call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i, + & iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,ii), + & iscpend(i,ii),*14) + endif + enddo ! i + 14 continue +#else + iatscp_s=nnt + iatscp_e=nct-1 + do i=nnt,nct-1 + if (i.lt.nnt+iscp) then + nscp_gr(i)=1 + iscpstart(i,1)=i+iscp + iscpend(i,1)=nct + elseif (i.gt.nct-iscp) then + nscp_gr(i)=1 + iscpstart(i,1)=nnt + iscpend(i,1)=i-iscp + else + nscp_gr(i)=2 + iscpstart(i,1)=nnt + iscpend(i,1)=i-iscp + iscpstart(i,2)=i+iscp + iscpend(i,2)=nct + endif + enddo ! i +#endif + if (lprint) then + write (iout,'(a)') 'SC-p interaction array:' + do i=iatscp_s,iatscp_e + write (iout,'(i3,2(2x,2i3))') + & i,(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i)) + enddo + endif ! lprint +C Partition local interactions +#ifdef MPL + call int_bounds(nres-2,loc_start,loc_end) + loc_start=loc_start+1 + loc_end=loc_end+1 + call int_bounds(nres-2,ithet_start,ithet_end) + ithet_start=ithet_start+2 + ithet_end=ithet_end+2 + call int_bounds(nct-nnt-2,iphi_start,iphi_end) + iphi_start=iphi_start+nnt+2 + iphi_end=iphi_end+nnt+2 + if (lprint) then + write (iout,*) 'Processor:',MyID, + & ' loc_start',loc_start,' loc_end',loc_end, + & ' ithet_start',ithet_start,' ithet_end',ithet_end, + & ' iphi_start',iphi_start,' iphi_end',iphi_end + write (*,*) 'Processor:',MyID, + & ' loc_start',loc_start,' loc_end',loc_end, + & ' ithet_start',ithet_start,' ithet_end',ithet_end, + & ' iphi_start',iphi_start,' iphi_end',iphi_end + endif + if (fgprocs.gt.1 .and. MyID.eq.BossID) then + write(iout,'(i10,a,i10,a,i10,a/a,i3,a)') n_sc_int_tot,' SC-SC ', + & nele_int_tot,' electrostatic and ',nscp_int_tot, + & ' SC-p interactions','were distributed among',fgprocs, + & ' fine-grain processors.' + endif +#else + loc_start=2 + loc_end=nres-1 + ithet_start=3 + ithet_end=nres + iphi_start=nnt+3 + iphi_end=nct +#endif + return + end +c--------------------------------------------------------------------------- + subroutine int_partition(int_index,lower_index,upper_index,atom, + & at_start,at_end,first_atom,last_atom,int_gr,jat_start,jat_end,*) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + integer int_index,lower_index,upper_index,atom,at_start,at_end, + & first_atom,last_atom,int_gr,jat_start,jat_end + logical lprn + lprn=.false. + if (lprn) write (iout,*) 'int_index=',int_index + int_index_old=int_index + int_index=int_index+last_atom-first_atom+1 + if (lprn) + & write (iout,*) 'int_index=',int_index, + & ' int_index_old',int_index_old, + & ' lower_index=',lower_index, + & ' upper_index=',upper_index, + & ' atom=',atom,' first_atom=',first_atom, + & ' last_atom=',last_atom + if (int_index.ge.lower_index) then + int_gr=int_gr+1 + if (at_start.eq.0) then + at_start=atom + jat_start=first_atom-1+lower_index-int_index_old + else + jat_start=first_atom + endif + if (lprn) write (iout,*) 'jat_start',jat_start + if (int_index.ge.upper_index) then + at_end=atom + jat_end=first_atom-1+upper_index-int_index_old + return1 + else + jat_end=last_atom + endif + if (lprn) write (iout,*) 'jat_end',jat_end + endif + return + end +c------------------------------------------------------------------------------ + subroutine hpb_partition + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.SBRIDGE' + include 'COMMON.IOUNITS' +#ifdef MPL + include 'COMMON.INFO' + call int_bounds(nhpb,link_start,link_end) +#else + link_start=1 + link_end=nhpb +#endif +cd write (iout,*) 'Processor',MyID,' MyRank',MyRank, +cd & ' nhpb',nhpb,' link_start=',link_start, +cd & ' link_end',link_end + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/int_from_cart.f b/source/wham/src-NEWSC-NEWCORR/int_from_cart.f new file mode 100644 index 0000000..c0cd6e7 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/int_from_cart.f @@ -0,0 +1,66 @@ + subroutine int_from_cart1(lprn) + implicit none + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + include 'COMMON.INTERACT' + include 'COMMON.LOCAL' + include 'COMMON.NAMES' + integer i,j + double precision dist,alpha,beta,dnorm1,dnorm2,be + logical lprn + if (lprn) write (iout,'(/a)') 'Recalculated internal coordinates' + vbld(nres+1)=0.0d0 + vbld(2*nres)=0.0d0 + vbld_inv(nres+1)=0.0d0 + vbld_inv(2*nres)=0.0d0 + do i=2,nres + dnorm1=dist(i-1,i) + dnorm2=dist(i,i+1) + do j=1,3 + c(j,maxres2)=0.5D0*(2*c(j,i)+(c(j,i-1)-c(j,i))/dnorm1 + & +(c(j,i+1)-c(j,i))/dnorm2) + enddo + be=0.0D0 + if (i.gt.2) phi(i+1)=beta(i-2,i-1,i,i+1) + if (i.gt.2) tauangle(3,i+1)=beta(i+nres-1,i-1,i,i+nres) + if (i.gt.2) tauangle(1,i+1)=beta(i-1+nres,i-1,i,i+1) + if (i.gt.2) tauangle(2,i+1)=beta(i-2,i-1,i,i+nres) + + omeg(i)=beta(nres+i,i,maxres2,i+1) + theta(i+1)=alpha(i-1,i,i+1) + alph(i)=alpha(nres+i,i,maxres2) + vbld(i)=dist(i-1,i) + vbld_inv(i)=1.0d0/vbld(i) + vbld(nres+i)=dist(nres+i,i) + if (itype(i).ne.10) then + vbld_inv(nres+i)=1.0d0/vbld(nres+i) + else + vbld_inv(nres+i)=0.0d0 + endif + enddo + do i=1,nres-1 + do j=1,3 + dc(j,i)=c(j,i+1)-c(j,i) + dc_norm(j,i)=dc(j,i)*vbld_inv(i+1) + enddo + enddo + do i=1,nres + do j=1,3 + dc(j,i+nres)=c(j,i+nres)-c(j,i) + dc_norm(j,i+nres)=dc(j,i+nres)*vbld_inv(i+nres) + enddo + enddo + if (lprn) then + do i=2,nres + write (iout,1212) restyp(itype(i)),i,vbld(i), + &rad2deg*theta(i),rad2deg*phi(i),vbld(nres+i), + &rad2deg*alph(i),rad2deg*omeg(i) + enddo + endif + 1212 format (a3,'(',i3,')',2(f15.10,2f10.2)) + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/intcor.f b/source/wham/src-NEWSC-NEWCORR/intcor.f new file mode 100644 index 0000000..04cbbbc --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/intcor.f @@ -0,0 +1,94 @@ +C +C------------------------------------------------------------------------------ +C + double precision function alpha(i1,i2,i3) +c +c Calculates the planar angle between atoms (i1), (i2), and (i3). +c + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.GEO' + include 'COMMON.CHAIN' + x12=c(1,i1)-c(1,i2) + x23=c(1,i3)-c(1,i2) + y12=c(2,i1)-c(2,i2) + y23=c(2,i3)-c(2,i2) + z12=c(3,i1)-c(3,i2) + z23=c(3,i3)-c(3,i2) + vnorm=dsqrt(x12*x12+y12*y12+z12*z12) + wnorm=dsqrt(x23*x23+y23*y23+z23*z23) + scalar=(x12*x23+y12*y23+z12*z23)/(vnorm*wnorm) + alpha=arcos(scalar) + return + end +C +C------------------------------------------------------------------------------ +C + double precision function beta(i1,i2,i3,i4) +c +c Calculates the dihedral angle between atoms (i1), (i2), (i3) and (i4) +c + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.GEO' + include 'COMMON.CHAIN' + x12=c(1,i1)-c(1,i2) + x23=c(1,i3)-c(1,i2) + x34=c(1,i4)-c(1,i3) + y12=c(2,i1)-c(2,i2) + y23=c(2,i3)-c(2,i2) + y34=c(2,i4)-c(2,i3) + z12=c(3,i1)-c(3,i2) + z23=c(3,i3)-c(3,i2) + z34=c(3,i4)-c(3,i3) +cd print '(2i3,3f10.5)',i1,i2,x12,y12,z12 +cd print '(2i3,3f10.5)',i2,i3,x23,y23,z23 +cd print '(2i3,3f10.5)',i3,i4,x34,y34,z34 + wx=-y23*z34+y34*z23 + wy=x23*z34-z23*x34 + wz=-x23*y34+y23*x34 + wnorm=dsqrt(wx*wx+wy*wy+wz*wz) + vx=y12*z23-z12*y23 + vy=-x12*z23+z12*x23 + vz=x12*y23-y12*x23 + vnorm=dsqrt(vx*vx+vy*vy+vz*vz) + if (vnorm.gt.1.0D-13 .and. wnorm.gt.1.0D-13) then + scalar=(vx*wx+vy*wy+vz*wz)/(vnorm*wnorm) + if (dabs(scalar).gt.1.0D0) + &scalar=0.99999999999999D0*scalar/dabs(scalar) + angle=dacos(scalar) +cd print '(2i4,10f7.3)',i2,i3,vx,vy,vz,wx,wy,wz,vnorm,wnorm, +cd &scalar,angle + else + angle=pi + endif +c if (angle.le.0.0D0) angle=pi+angle + tx=vy*wz-vz*wy + ty=-vx*wz+vz*wx + tz=vx*wy-vy*wx + scalar=tx*x23+ty*y23+tz*z23 + if (scalar.lt.0.0D0) angle=-angle + beta=angle + return + end +C +C------------------------------------------------------------------------------ +C + double precision function dist(i1,i2) +c +c Calculates the distance between atoms (i1) and (i2). +c + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.GEO' + include 'COMMON.CHAIN' + x12=c(1,i1)-c(1,i2) + y12=c(2,i1)-c(2,i2) + z12=c(3,i1)-c(3,i2) + dist=dsqrt(x12*x12+y12*y12+z12*z12) + return + end +C diff --git a/source/wham/src-NEWSC-NEWCORR/make_ensemble1.F b/source/wham/src-NEWSC-NEWCORR/make_ensemble1.F new file mode 100644 index 0000000..5d7b750 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/make_ensemble1.F @@ -0,0 +1,375 @@ + subroutine make_ensembles(islice,*) +! construct the conformational ensembles at REMD temperatures + implicit none + include "DIMENSIONS" + include "DIMENSIONS.ZSCOPT" + include "DIMENSIONS.FREE" +#ifdef MPI + include "mpif.h" + include "COMMON.MPI" + integer ierror,errcode,status(MPI_STATUS_SIZE) +#endif + include "COMMON.IOUNITS" + include "COMMON.CONTROL" + include "COMMON.FREE" + include "COMMON.ENERGIES" + include "COMMON.FFIELD" + include "COMMON.INTERACT" + include "COMMON.SBRIDGE" + include "COMMON.CHAIN" + include "COMMON.PROTFILES" + include "COMMON.PROT" + real*4 csingle(3,maxres2) + double precision fT(6),fTprim(6),fTbis(6),quot,quotl1,quotl,kfacl, + & eprim,ebis,temper,kfac/2.4d0/,T0/300.0d0/ + double precision etot,evdw,evdw_t,evdw2,ees,evdw1,ebe,etors, + & escloc, + & ehpb,ecorr,ecorr5,ecorr6,eello_turn4,eello_turn3, + & eturn6,eel_loc,edihcnstr,etors_d,estr,evdw2_14,esccor,tt + integer i,ii,ik,iproc,iscor,j,k,l,ib,iparm,iprot,nlist + double precision qfree,sumprob,eini,efree,rmsdev + character*80 bxname + character*2 licz1,licz2 + character*3 licz3,licz4 + character*5 ctemper + integer ilen + external ilen + real*4 Fdimless(MaxStr) + double precision enepot(MaxStr) + integer iperm(MaxStr) + integer islice + +#ifdef MPI + if (me.eq.Master) then +#endif + write (licz2,'(bz,i2.2)') islice + if (nslice.eq.1) then + if (.not.separate_parset) then + bxname = prefix(:ilen(prefix))//".bx" + else + write (licz3,'(bz,i3.3)') myparm + bxname = prefix(:ilen(prefix))//"_par"//licz3//".bx" + endif + else + if (.not.separate_parset) then + bxname = prefix(:ilen(prefix))//"_slice_"//licz2//".bx" + else + write (licz3,'(bz,i3.3)') myparm + bxname = prefix(:ilen(prefix))//"par_"//licz3// + & "_slice_"//licz2//".bx" + endif + endif + open (ientout,file=bxname,status="unknown", + & form="unformatted",access="direct",recl=lenrec1) +#ifdef MPI + endif +#endif + do iparm=1,nParmSet + if (iparm.ne.iparmprint) exit + call restore_parm(iparm) + do ib=1,nT_h(iparm) +#ifdef DEBUG + write (iout,*) "iparm",iparm," ib",ib +#endif + temper=1.0d0/(beta_h(ib,iparm)*1.987D-3) +c quot=1.0d0/(T0*beta_h(ib,iparm)*1.987D-3) +c quotl=1.0d0 +c kfacl=1.0d0 +c do l=1,5 +c quotl1=quotl +c quotl=quotl*quot +c kfacl=kfacl*kfac +c fT(l)=kfacl/(kfacl-1.0d0+quotl) +c enddo + if (rescale_mode.eq.1) then + quot=1.0d0/(T0*beta_h(ib,iparm)*1.987D-3) +#if defined(FUNCTH) + tt=1.0d0/(beta_h(ib,iparm)*1.987D-3) + ft(6)=(320.0d0+80.0d0*dtanh((tt-320.0d0)/80.0d0))/320.0d0 +#elif defined(FUNCT) + ft(6)=quot +#else + ft(6)=1.0d0 +#endif + quotl=1.0d0 + kfacl=1.0d0 + do l=1,5 + quotl1=quotl + quotl=quotl*quot + kfacl=kfacl*kfac + fT(l)=kfacl/(kfacl-1.0d0+quotl) + enddo + else if (rescale_mode.eq.2) then + quot=1.0d0/(T0*beta_h(ib,iparm)*1.987D-3) +#if defined(FUNCTH) + tt=1.0d0/(beta_h(ib,iparm)*1.987D-3) + ft(6)=(320.0d0+80.0d0*dtanh((tt-320.0d0)/80.0d0))/3200.d0 +#elif defined(FUNCT) + ft(6)=quot +#else + ft(6)=1.0d0 +#endif + quotl=1.0d0 + do l=1,5 + quotl=quotl*quot + fT(l)=1.12692801104297249644d0/ + & dlog(dexp(quotl)+dexp(-quotl)) + enddo +c write (iout,*) 1.0d0/(beta_h(ib,iparm)*1.987D-3),ft + else if (rescale_mode.eq.0) then + do l=1,5 + fT(l)=0.0d0 + enddo + else + write (iout,*) + & "Error in MAKE_ENSEMBLE: Wrong RESCALE_MODE:",rescale_mode + call flush(iout) + return1 + endif +#ifdef MPI + do i=1,scount(me1) +#else + do i=1,ntot(islice) +#endif + evdw=enetb(1,i,iparm) + evdw_t=enetb(21,i,iparm) +#ifdef SCP14 + evdw2_14=enetb(17,i,iparm) + evdw2=enetb(2,i,iparm)+evdw2_14 +#else + evdw2=enetb(2,i,iparm) + evdw2_14=0.0d0 +#endif +#ifdef SPLITELE + ees=enetb(3,i,iparm) + evdw1=enetb(16,i,iparm) +#else + ees=enetb(3,i,iparm) + evdw1=0.0d0 +#endif + ecorr=enetb(4,i,iparm) + ecorr5=enetb(5,i,iparm) + ecorr6=enetb(6,i,iparm) + eel_loc=enetb(7,i,iparm) + eello_turn3=enetb(8,i,iparm) + eello_turn4=enetb(9,i,iparm) + eturn6=enetb(10,i,iparm) + ebe=enetb(11,i,iparm) + escloc=enetb(12,i,iparm) + etors=enetb(13,i,iparm) + etors_d=enetb(14,i,iparm) + ehpb=enetb(15,i,iparm) + estr=enetb(18,i,iparm) + esccor=enetb(19,i,iparm) + edihcnstr=enetb(20,i,iparm) +#ifdef SPLITELE + etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2+ft(1)*welec*ees + & +wvdwpp*evdw1 + & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc + & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 + & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 + & +ft(2)*wturn3*eello_turn3 + & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc + & +edihcnstr+ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor + & +wbond*estr +#else + etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2 + & +ft(1)*welec*(ees+evdw1) + & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc + & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 + & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 + & +ft(2)*wturn3*eello_turn3 + & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc+edihcnstr + & +ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor + & +wbond*estr +#endif +#ifdef MPI + Fdimless(i)= + & beta_h(ib,iparm)*etot-entfac(i) + potE(i,iparm)=etot +#ifdef DEBUG + write (iout,*) i,indstart(me)+i-1,ib, + & 1.0d0/(1.987d-3*beta_h(ib,iparm)),potE(i,iparm), + & -entfac(i),Fdimless(i) +#endif +#else + Fdimless(i)=beta_h(ib,iparm)*etot-entfac(i) + potE(i,iparm)=etot +#endif + enddo ! i +#ifdef MPI + call MPI_Gatherv(Fdimless(1),scount(me), + & MPI_REAL,Fdimless(1), + & scount(0),idispl(0),MPI_REAL,Master, + & WHAM_COMM, IERROR) +#ifdef DEBUG + call MPI_Gatherv(potE(1,iparm),scount(me), + & MPI_DOUBLE_PRECISION,potE(1,iparm), + & scount(0),idispl(0),MPI_DOUBLE_PRECISION,Master, + & WHAM_COMM, IERROR) + call MPI_Gatherv(entfac(1),scount(me), + & MPI_DOUBLE_PRECISION,entfac(1), + & scount(0),idispl(0),MPI_DOUBLE_PRECISION,Master, + & WHAM_COMM, IERROR) +#endif + if (me.eq.Master) then +#ifdef DEBUG + write (iout,*) "The FDIMLESS array before sorting" + do i=1,ntot(islice) + write (iout,*) i,fdimless(i) + enddo +#endif +#endif + do i=1,ntot(islice) + iperm(i)=i + enddo + call mysort1(ntot(islice),Fdimless,iperm) +#ifdef DEBUG + write (iout,*) "The FDIMLESS array after sorting" + do i=1,ntot(islice) + write (iout,*) i,iperm(i),fdimless(i) + enddo +#endif + qfree=0.0d0 + do i=1,ntot(islice) + qfree=qfree+exp(-fdimless(i)+fdimless(1)) + enddo +c write (iout,*) "qfree",qfree + nlist=1 + sumprob=0.0 + do i=1,min0(ntot(islice),ensembles) + sumprob=sumprob+exp(-fdimless(i)+fdimless(1))/qfree +#ifdef DEBUG + write (iout,*) i,ib,beta_h(ib,iparm), + & 1.0d0/(1.987d-3*beta_h(ib,iparm)),iperm(i), + & potE(iperm(i),iparm), + & -entfac(iperm(i)),fdimless(i),sumprob +#endif + if (sumprob.gt.0.99d0) goto 122 + nlist=nlist+1 + enddo + 122 continue +#ifdef MPI + endif + call MPI_Bcast(nlist, 1, MPI_INTEGER, Master, WHAM_COMM, + & IERROR) + call MPI_Bcast(iperm,nlist,MPI_INTEGER,Master,WHAM_COMM, + & IERROR) + do i=1,nlist + ii=iperm(i) + iproc=0 + do while (ii.lt.indstart(iproc).or.ii.gt.indend(iproc)) + iproc=iproc+1 + enddo + if (iproc.ge.nprocs) then + write (iout,*) "Fatal error: processor out of range",iproc + call flush(iout) + if (bxfile) then + close (ientout) + else + close (ientout,status="delete") + endif + return1 + endif + ik=ii-indstart(iproc)+1 + if (iproc.ne.Master) then + if (me.eq.iproc) then +#ifdef DEBUG + write (iout,*) "i",i," ii",ii," iproc",iproc," ik",ik, + & " energy",potE(ik,iparm) +#endif + call MPI_Send(potE(ik,iparm),1,MPI_DOUBLE_PRECISION, + & Master,i,WHAM_COMM,IERROR) + else if (me.eq.Master) then + call MPI_Recv(enepot(i),1,MPI_DOUBLE_PRECISION,iproc,i, + & WHAM_COMM,STATUS,IERROR) + endif + else if (me.eq.Master) then + enepot(i)=potE(ik,iparm) + endif + enddo +#else + do i=1,nlist + enepot(i)=potE(iperm(i),iparm) + enddo +#endif +#ifdef MPI + if (me.eq.Master) then +#endif + write(licz3,'(bz,i3.3)') iparm + write(licz2,'(bz,i2.2)') islice + if (temper.lt.100.0d0) then + write(ctemper,'(f3.0)') temper + else if (temper.lt.1000.0) then + write (ctemper,'(f4.0)') temper + else + write (ctemper,'(f5.0)') temper + endif + if (nparmset.eq.1) then + if (separate_parset) then + write(licz4,'(bz,i3.3)') myparm + pdbname=prefix(:ilen(prefix))//"_par"//licz4 + else + pdbname=prefix(:ilen(prefix)) + endif + else + pdbname=prefix(:ilen(prefix))//"_parm_"//licz3 + endif + if (nslice.eq.1) then + pdbname=pdbname(:ilen(pdbname))//"_T_"// + & ctemper(:ilen(ctemper))//"pdb" + else + pdbname=pdbname(:ilen(pdbname))//"_slice_"//licz2//"_T_"// + & ctemper(:ilen(ctemper))//"pdb" + endif + open(ipdb,file=pdbname) + do i=1,nlist + read (ientout,rec=iperm(i)) + & ((csingle(l,k),l=1,3),k=1,nres), + & ((csingle(l,k+nres),l=1,3),k=nnt,nct), + & nss,(ihpb(k),jhpb(k),k=1,nss), + & eini,efree,rmsdev,iscor + do j=1,2*nres + do k=1,3 + c(k,j)=csingle(k,j) + enddo + enddo + eini=fdimless(i) + call pdbout(iperm(i),temper,eini,enepot(i),efree,rmsdev) + enddo +#ifdef MPI + endif +#endif + enddo ! ib + enddo ! iparm + if (bxfile) then + close(ientout) + else + close(ientout,status="delete") + endif + return + end +!-------------------------------------------------- + subroutine mysort1(n, x, ipermut) + implicit none + integer i,j,imax,ipm,n + real x(n) + integer ipermut(n) + real xtemp + do i=1,n + xtemp=x(i) + imax=i + do j=i+1,n + if (x(j).lt.xtemp) then + imax=j + xtemp=x(j) + endif + enddo + x(imax)=x(i) + x(i)=xtemp + ipm=ipermut(imax) + ipermut(imax)=ipermut(i) + ipermut(i)=ipm + enddo + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/match_contact.f b/source/wham/src-NEWSC-NEWCORR/match_contact.f new file mode 100644 index 0000000..3ec2036 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/match_contact.f @@ -0,0 +1,339 @@ + subroutine match_contact(ishif1,ishif2,nc_match,nc_match1_max, + & ncont_ref,icont_ref,ncont,icont,jfrag,n_shif1,n_shif2, + & nc_frac,nc_req_set,istr,llocal,lprn) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + integer ncont_ref,icont_ref(2,maxcont),ncont,icont(2,maxcont), + & ishift,ishif2,nc_match + double precision nc_frac + logical llocal,lprn + nc_match_max=0 + do i=1,ncont_ref + nc_match_max=nc_match_max+ + & min0(icont_ref(2,i)-icont_ref(1,i)-1,3) + enddo + if (istr.eq.3) then + nc_req=0 + else if (nc_req_set.eq.0) then + nc_req=nc_match_max*nc_frac + else + nc_req = dmin1(nc_match_max*nc_frac+0.5d0, + & dfloat(nc_req_set)+1.0d-7) + endif +c write (iout,*) "match_contact: nc_req:",nc_req +c write (iout,*) "nc_match_max",nc_match_max +c write (iout,*) "jfrag",jfrag," n_shif1",n_shif1, +c & " n_shif2",n_shif2 +C Match current contact map against reference contact map; exit, if at least +C half of the contacts match + call ncont_match(nc_match,nc_match1,0,0,ncont_ref,icont_ref, + & ncont,icont,jfrag,llocal,lprn) + nc_match1_max=nc_match1 + if (lprn .and. nc_match.gt.0) write (iout,*) + & "Shift:",0,0," nc_match1",nc_match1, + & " nc_match=",nc_match," req'd",nc_req + if (nc_req.gt.0 .and. nc_match.ge.nc_req .or. + & nc_req.eq.0 .and. nc_match.eq.1) then + ishif1=0 + ishif2=0 + return + endif +C If sufficient matches are not found, try to shift contact maps up to three +C positions. + if (n_shif1.gt.0) then + do is=1,n_shif1 +C The following four tries help to find shifted beta-sheet patterns +C Shift "left" strand backward + call ncont_match(nc_match,nc_match1,-is,0,ncont_ref, + & icont_ref,ncont,icont,jfrag,llocal,lprn) + if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 + if (lprn .and. nc_match.gt.0) write (iout,*) + & "Shift:",-is,0," nc_match1",nc_match1, + & " nc_match=",nc_match," req'd",nc_req + if (nc_req.gt.0 .and. nc_match.ge.nc_req .or. + & nc_req.eq.0 .and. nc_match.eq.1) then + ishif1=-is + ishif2=0 + return + endif +C Shift "left" strand forward + call ncont_match(nc_match,nc_match1,is,0,ncont_ref, + & icont_ref,ncont,icont,jfrag,llocal,lprn) + if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 + if (lprn .and. nc_match.gt.0) write (iout,*) + & "Shift:",is,0," nc_match1",nc_match1, + & " nc_match=",nc_match," req'd",nc_req + if (nc_req.gt.0 .and. nc_match.ge.nc_req .or. + & nc_req.eq.0 .and. nc_match.eq.1) then + ishif1=is + ishif2=0 + return + endif + enddo + if (nc_req.eq.0) return +C Shift "right" strand backward + do is=1,n_shif1 + call ncont_match(nc_match,nc_match1,0,-is,ncont_ref, + & icont_ref,ncont,icont,jfrag,llocal,lprn) + if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 + if (lprn .and. nc_match.gt.0) write (iout,*) + & "Shift:",0,-is," nc_match1",nc_match1, + & " nc_match=",nc_match," req'd",nc_req + if (nc_match.ge.nc_req) then + ishif1=0 + ishif2=-is + return + endif +C Shift "right" strand upward + call ncont_match(nc_match,nc_match1,0,is,ncont_ref, + & icont_ref,ncont,icont,jfrag,llocal,lprn) + if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 + if (lprn .and. nc_match.gt.0) write (iout,*) + & "Shift:",0,is," nc_match1",nc_match1, + & " nc_match=",nc_match," req'd",nc_req + if (nc_match.ge.nc_req) then + ishif1=0 + ishif2=is + return + endif + enddo ! is +C Now try to shift both residues in contacts. + do is=1,n_shif1 + do js=1,is + if (js.ne.is) then + call ncont_match(nc_match,nc_match1,-is,-js,ncont_ref, + & icont_ref,ncont,icont,jfrag,llocal,lprn) + if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 + if (lprn .and. nc_match.gt.0) write (iout,*) + & "Shift:",-is,-js," nc_match1",nc_match1, + & " nc_match=",nc_match," req'd",nc_req + if (nc_match.ge.nc_req) then + ishif1=-is + ishif2=-js + return + endif + call ncont_match(nc_match,nc_match1,is,js,ncont_ref, + & icont_ref,ncont,icont,jfrag,llocal,lprn) + if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 + if (lprn .and. nc_match.gt.0) write (iout,*) + & "Shift:",is,js," nc_match1",nc_match1, + & " nc_match=",nc_match," req'd",nc_req + if (nc_match.ge.nc_req) then + ishif1=is + ishif2=js + return + endif +c + call ncont_match(nc_match,nc_match1,-js,-is,ncont_ref, + & icont_ref,ncont,icont,jfrag,llocal,lprn) + if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 + if (lprn .and. nc_match.gt.0) write (iout,*) + & "Shift:",-js,-is," nc_match1",nc_match1, + & " nc_match=",nc_match," req'd",nc_req + if (nc_match.ge.nc_req) then + ishif1=-js + ishif2=-is + return + endif +c + call ncont_match(nc_match,nc_match1,js,is,ncont_ref, + & icont_ref,ncont,icont,jfrag,llocal,lprn) + if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 + if (lprn .and. nc_match.gt.0) write (iout,*) + & "Shift:",js,is," nc_match1",nc_match1, + & " nc_match=",nc_match," req'd",nc_req + if (nc_match.ge.nc_req) then + ishif1=js + ishif2=is + return + endif + endif +c + if (is+js.le.n_shif1) then + call ncont_match(nc_match,nc_match1,-is,js,ncont_ref, + & icont_ref,ncont,icont,jfrag,llocal,lprn) + if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 + if (lprn .and. nc_match.gt.0) write (iout,*) + & "Shift:",-is,js," nc_match1",nc_match1, + & " nc_match=",nc_match," req'd",nc_req + if (nc_match.ge.nc_req) then + ishif1=-is + ishif2=js + return + endif +c + call ncont_match(nc_match,nc_match1,js,-is,ncont_ref, + & icont_ref,ncont,icont,jfrag,llocal,lprn) + if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 + if (lprn .and. nc_match.gt.0) write (iout,*) + & "Shift:",js,-is," nc_match1",nc_match1, + & " nc_match=",nc_match," req'd",nc_req + if (nc_match.ge.nc_req) then + ishif1=js + ishif2=-is + return + endif + endif +c + enddo !js + enddo !is + endif + + if (n_shif2.gt.0) then + do is=1,n_shif2 + call ncont_match(nc_match,nc_match1,-is,-is,ncont_ref, + & icont_ref,ncont,icont,jfrag,llocal,lprn) + if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 + if (lprn .and. nc_match.gt.0) write (iout,*) + & "Shift:",-is,-is," nc_match1",nc_match1, + & " nc_match=",nc_match," req'd",nc_req + if (nc_match.ge.nc_req) then + ishif1=-is + ishif2=-is + return + endif + call ncont_match(nc_match,nc_match1,is,is,ncont_ref, + & icont_ref,ncont,icont,jfrag,llocal,lprn) + if (nc_match1.gt.nc_match1_max) nc_match1_max=nc_match1 + if (lprn .and. nc_match.gt.0) write (iout,*) + & "Shift:",is,is," nc_match1",nc_match1, + & " nc_match=",nc_match," req'd",nc_req + if (nc_match.ge.nc_req) then + ishif1=is + ishif2=is + return + endif + enddo + endif +C If this point is reached, the contact maps are different. + nc_match=0 + ishif1=0 + ishif2=0 + return + end +c------------------------------------------------------------------------- + subroutine ncont_match(nc_match,nc_match1,ishif1,ishif2, + & ncont_ref,icont_ref,ncont,icont,jfrag,llocal,lprn) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.COMPAR' + include 'COMMON.IOUNITS' + include 'COMMON.INTERACT' + include 'COMMON.GEO' + include 'COMMON.COMPAR' + logical llocal,lprn + integer ncont_ref,icont_ref(2,maxcont),ncont,icont(2,maxcont), + & icont_match(2,maxcont),ishift,ishif2,nang_pair, + & iang_pair(2,maxres) +C Compare the contact map against the reference contact map; they're stored +C in ICONT and ICONT_REF, respectively. The current contact map can be shifted. + if (lprn) write (iout,'(80(1h*))') + nc_match=0 + nc_match1=0 +c Check the local structure by comparing dihedral angles. +c write (iout,*) "ncont_match: ncont_ref",ncont_ref," llocal",llocal + if (llocal .and. ncont_ref.eq.0) then +c If there are no contacts just compare the dihedral angles and exit. + call angnorm(jfrag,ishif1,ishif2,ang_cut1(jfrag),diffang,fract, + & lprn) + if (lprn) write (iout,*) "diffang:",diffang*rad2deg, + & " ang_cut:",ang_cut(jfrag)*rad2deg," fract",fract + if (diffang.le.ang_cut(jfrag) .and. fract.ge.frac_min(jfrag)) + & then + nc_match=1 + else + nc_match=0 + endif + return + endif + nang_pair=0 + do i=1,ncont + ic1=icont(1,i)+ishif1 + ic2=icont(2,i)+ishif2 +c write (iout,*) "i",i," ic1",ic1," ic2",ic2 + if (ic1.lt.nnt .or. ic2.gt.nct) goto 10 + do j=1,ncont_ref + if (ic1.eq.icont_ref(1,j).and.ic2.eq.icont_ref(2,j)) then + nc_match=nc_match+min0(icont_ref(2,j)-icont_ref(1,j)-1,3) + nc_match1=nc_match1+1 + icont_match(1,nc_match1)=ic1 + icont_match(2,nc_match1)=ic2 +c call add_angpair(icont(1,i),icont_ref(1,j), +c & nang_pair,iang_pair) +c call add_angpair(icont(2,i),icont_ref(2,j), +c & nang_pair,iang_pair) + if (lprn) write (iout,*) "Contacts:",icont(1,i),icont(2,i), + & " match",icont_ref(1,j),icont_ref(2,j), + & " shifts",ishif1,ishif2 + goto 10 + endif + enddo + 10 continue + enddo + if (lprn) then + write (iout,*) "nc_match",nc_match," nc_match1",nc_match1 + write (iout,*) "icont_match" + do i=1,nc_match1 + write (iout,*) icont_match(1,i),icont_match(2,i) + enddo + endif + if (llocal .and. nc_match.gt.0) then + call angnorm2(jfrag,ishif1,ishif2,nc_match1,icont_match,lprn, + & ang_cut1(jfrag),diffang,fract) + if (lprn) write (iout,*) "diffang:",diffang*rad2deg, + & " ang_cut:",ang_cut(jfrag)*rad2deg, + & " ang_cut1",ang_cut1(jfrag)*rad2deg + if (diffang.gt.ang_cut(jfrag) + & .or. fract.lt.frac_min(jfrag)) nc_match=0 + endif +c if (nc_match.gt.0) then +c diffang = angnorm1(nang_pair,iang_pair,lprn) +c if (diffang.gt.ang_cut(jfrag)) nc_match=0 +c endif + if (lprn) write (iout,*) "ishif1",ishif1," ishif2",ishif2, + & " diffang",rad2deg*diffang," nc_match",nc_match + return + end +c------------------------------------------------------------------------------ + subroutine match_secondary(jfrag,isecstr,nsec_match,lprn) +c This subroutine compares the secondary structure (isecstr) of fragment jfrag +c conformation considered to that of the reference conformation. +c Returns the number of equivalent residues (nsec_match). + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.COMPAR' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.PEPTCONT' + include 'COMMON.COMPAR' + logical lprn + integer isecstr(maxres) + npart = npiece(jfrag,1) + nsec_match=0 + if (lprn) then + write (iout,*) "match_secondary jfrag",jfrag," ifrag", + & (ifrag(1,i,jfrag),ifrag(2,i,jfrag),i=1,npart) + write (iout,'(80i1)') (isec_ref(j),j=1,nres) + write (iout,'(80i1)') (isecstr(j),j=1,nres) + endif + do i=1,npart + do j=ifrag(1,i,jfrag),ifrag(2,i,jfrag) +c The residue has equivalent conformational state to that of the reference +c structure, if: +c a) the conformational states are equal or +c b) the reference state is a coil and that of the conformation considered +c is a strand or +c c) the conformational state of the conformation considered is a strand +c and that of the reference conformation is a coil. +c 10/28/02 - case (b) deleted. + if (isecstr(j).eq.isec_ref(j) .or. +c & isecstr(j).eq.0 .and. isec_ref(j).eq.1 .or. + & isec_ref(j).eq.0 .and. isecstr(j).eq.1) + & nsec_match=nsec_match+1 + enddo + enddo + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/matmult.f b/source/wham/src-NEWSC-NEWCORR/matmult.f new file mode 100644 index 0000000..e9257cf --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/matmult.f @@ -0,0 +1,18 @@ + SUBROUTINE MATMULT(A1,A2,A3) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + DIMENSION A1(3,3),A2(3,3),A3(3,3) + DIMENSION AI3(3,3) + DO 1 I=1,3 + DO 2 J=1,3 + A3IJ=0.0 + DO 3 K=1,3 + 3 A3IJ=A3IJ+A1(I,K)*A2(K,J) + AI3(I,J)=A3IJ + 2 CONTINUE + 1 CONTINUE + DO 4 I=1,3 + DO 4 J=1,3 + 4 A3(I,J)=AI3(I,J) + RETURN + END diff --git a/source/wham/src-NEWSC-NEWCORR/misc.f b/source/wham/src-NEWSC-NEWCORR/misc.f new file mode 100644 index 0000000..e189839 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/misc.f @@ -0,0 +1,203 @@ +C $Date: 1994/10/12 17:24:21 $ +C $Revision: 2.5 $ +C +C +C + logical function find_arg(ipos,line,errflag) + parameter (maxlen=80) + character*80 line + character*1 empty /' '/,equal /'='/ + logical errflag +* This function returns .TRUE., if an argument follows keyword keywd; if so +* IPOS will point to the first non-blank character of the argument. Returns +* .FALSE., if no argument follows the keyword; in this case IPOS points +* to the first non-blank character of the next keyword. + do while (line(ipos:ipos) .eq. empty .and. ipos.le.maxlen) + ipos=ipos+1 + enddo + errflag=.false. + if (line(ipos:ipos).eq.equal) then + find_arg=.true. + ipos=ipos+1 + do while (line(ipos:ipos) .eq. empty .and. ipos.le.maxlen) + ipos=ipos+1 + enddo + if (ipos.gt.maxlen) errflag=.true. + else + find_arg=.false. + endif + return + end + logical function find_group(iunit,jout,key1) + character*(*) key1 + character*80 karta,ucase + integer ilen + external ilen + logical lcom + rewind (iunit) + karta=' ' + ll=ilen(key1) + do while (index(ucase(karta),key1(1:ll)).eq.0.or.lcom(1,karta)) + read (iunit,'(a)',end=10) karta + enddo + write (jout,'(2a)') '> ',karta(1:78) + find_group=.true. + return + 10 find_group=.false. + return + end + logical function iblnk(charc) + character*1 charc + integer n + n = ichar(charc) + iblnk = (n.eq.9) .or. (n.eq.10) .or. (charc.eq. ' ') + return + end + integer function ilen(string) + character*(*) string + logical iblnk + + ilen = len(string) +1 if ( ilen .gt. 0 ) then + if ( iblnk( string(ilen:ilen) ) ) then + ilen = ilen - 1 + goto 1 + endif + endif + return + end + integer function in_keywd_set(nkey,ikey,narg,keywd,keywdset) + character*16 keywd,keywdset(1:nkey,0:nkey) + character*16 ucase + do i=1,narg + if (ucase(keywd).eq.keywdset(i,ikey)) then +* Match found + in_keywd_set=i + return + endif + enddo +* No match to the allowed set of keywords if this point is reached. + in_keywd_set=0 + return + end + character*(*) function lcase(string) + integer i, k, idiff + character*(*) string + character*1 c + character*40 chtmp +c + i = len(lcase) + k = len(string) + if (i .lt. k) then + k = i + if (string(k+1:) .ne. ' ') then + chtmp = string + endif + endif + idiff = ichar('a') - ichar('A') + lcase = string + do 99 i = 1, k + c = string(i:i) + if (lge(c,'A') .and. lle(c,'Z')) then + lcase(i:i) = char(ichar(c) + idiff) + endif + 99 continue + return + end + logical function lcom(ipos,karta) + character*80 karta + character koment(2) /'!','#'/ + lcom=.false. + do i=1,2 + if (karta(ipos:ipos).eq.koment(i)) lcom=.true. + enddo + return + end + logical function lower_case(ch) + character*(*) ch + lower_case=(ch.ge.'a' .and. ch.le.'z') + return + end + subroutine mykey(line,keywd,ipos,blankline,errflag) +* This subroutine seeks a non-empty substring keywd in the string LINE. +* The substring begins with the first character different from blank and +* "=" encountered right to the pointer IPOS (inclusively) and terminates +* at the character left to the first blank or "=". When the subroutine is +* exited, the pointer IPOS is moved to the position of the terminator in LINE. +* The logical variable BLANKLINE is set at .TRUE., if LINE(IPOS:) contains +* only separators or the maximum length of the data line (80) has been reached. +* The logical variable ERRFLAG is set at .TRUE. if the string +* consists only from a "=". + parameter (maxlen=80) + character*1 empty /' '/,equal /'='/,comma /','/ + character*(*) keywd + character*80 line + logical blankline,errflag,lcom + errflag=.false. + do while (line(ipos:ipos).eq.empty .and. (ipos.le.maxlen)) + ipos=ipos+1 + enddo + if (ipos.gt.maxlen .or. lcom(ipos,line) ) then +* At this point the rest of the input line turned out to contain only blanks +* or to be commented out. + blankline=.true. + return + endif + blankline=.false. + istart=ipos +* Checks whether the current char is a separator. + do while (line(ipos:ipos).ne.empty .and. line(ipos:ipos).ne.equal + & .and. line(ipos:ipos).ne.comma .and. ipos.le.maxlen) + ipos=ipos+1 + enddo + iend=ipos-1 +* Error flag set to .true., if the length of the keyword was found less than 1. + if (iend.lt.istart) then + errflag=.true. + return + endif + keywd=line(istart:iend) + return + end + subroutine numstr(inum,numm) + character*10 huj /'0123456789'/ + character*(*) numm + inumm=inum + inum1=inumm/10 + inum2=inumm-10*inum1 + inumm=inum1 + numm(3:3)=huj(inum2+1:inum2+1) + inum1=inumm/10 + inum2=inumm-10*inum1 + inumm=inum1 + numm(2:2)=huj(inum2+1:inum2+1) + inum1=inumm/10 + inum2=inumm-10*inum1 + inumm=inum1 + numm(1:1)=huj(inum2+1:inum2+1) + return + end + character*(*) function ucase(string) + integer i, k, idiff + character*(*) string + character*1 c + character*40 chtmp +c + i = len(ucase) + k = len(string) + if (i .lt. k) then + k = i + if (string(k+1:) .ne. ' ') then + chtmp = string + endif + endif + idiff = ichar('a') - ichar('A') + ucase = string + do 99 i = 1, k + c = string(i:i) + if (lge(c,'a') .and. lle(c,'z')) then + ucase(i:i) = char(ichar(c) - idiff) + endif + 99 continue + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/molread_zs.F b/source/wham/src-NEWSC-NEWCORR/molread_zs.F new file mode 100644 index 0000000..431680d --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/molread_zs.F @@ -0,0 +1,378 @@ + subroutine molread(*) +C +C Read molecular data. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.LOCAL' + include 'COMMON.NAMES' + include 'COMMON.CHAIN' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + include 'COMMON.TORCNSTR' + include 'COMMON.CONTROL' + character*4 sequence(maxres) + integer rescode + double precision x(maxvar) + character*320 controlcard,ucase + dimension itype_pdb(maxres) + logical seq_comp + call card_concat(controlcard,.true.) + call reada(controlcard,'SCAL14',scal14,0.4d0) + call reada(controlcard,'SCALSCP',scalscp,1.0d0) + call reada(controlcard,'CUTOFF',cutoff_corr,7.0d0) + call reada(controlcard,'DELT_CORR',delt_corr,0.5d0) + r0_corr=cutoff_corr-delt_corr + call readi(controlcard,"NRES",nres,0) + iscode=index(controlcard,"ONE_LETTER") + if (nres.le.0) then + write (iout,*) "Error: no residues in molecule" + return1 + endif + if (nres.gt.maxres) then + write (iout,*) "Error: too many residues",nres,maxres + endif + write(iout,*) 'nres=',nres +C Read sequence of the protein + if (iscode.gt.0) then + read (inp,'(80a1)') (sequence(i)(1:1),i=1,nres) + else + read (inp,'(20(1x,a3))') (sequence(i),i=1,nres) + endif +C Convert sequence to numeric code + do i=1,nres + itype(i)=rescode(i,sequence(i),iscode) + enddo + write (iout,*) "Numeric code:" + write (iout,'(20i4)') (itype(i),i=1,nres) + do i=1,nres-1 +#ifdef PROCOR + if (itype(i).eq.21 .or. itype(i+1).eq.21) then +#else + if (itype(i).eq.21) then +#endif + itel(i)=0 +#ifdef PROCOR + else if (itype(i+1).ne.20) then +#else + else if (itype(i).ne.20) then +#endif + itel(i)=1 + else + itel(i)=2 + endif + enddo + call read_bridge + + if (with_dihed_constr) then + + read (inp,*) ndih_constr + if (ndih_constr.gt.0) then + read (inp,*) ftors + write (iout,*) 'FTORS',ftors + read (inp,*) (idih_constr(i),phi0(i),drange(i),i=1,ndih_constr) + write (iout,*) + & 'There are',ndih_constr,' constraints on phi angles.' + do i=1,ndih_constr + write (iout,'(i5,2f8.3)') idih_constr(i),phi0(i),drange(i) + enddo + do i=1,ndih_constr + phi0(i)=deg2rad*phi0(i) + drange(i)=deg2rad*drange(i) + enddo + endif + + endif + + nnt=1 + nct=nres + if (itype(1).eq.21) nnt=2 + if (itype(nres).eq.21) nct=nct-1 + write(iout,*) 'NNT=',NNT,' NCT=',NCT +c Read distance restraints + if (constr_dist.gt.0) then + if (refstr) call read_ref_structure(*11) + call read_dist_constr + call hpb_partition + endif + + call setup_var + call init_int_table + if (ns.gt.0) then + write (iout,'(/a,i3,a)') 'The chain contains',ns, + & ' disulfide-bridging cysteines.' + write (iout,'(20i4)') (iss(i),i=1,ns) + write (iout,'(/a/)') 'Pre-formed links are:' + do i=1,nss + i1=ihpb(i)-nres + i2=jhpb(i)-nres + it1=itype(i1) + it2=itype(i2) + write (iout,'(2a,i3,3a,i3,a,3f10.3)') + & restyp(it1),'(',i1,') -- ',restyp(it2),'(',i2,')', + & dhpb(i),ebr,forcon(i) + enddo + endif + write (iout,'(a)') + return + 11 stop "Error reading reference structure" + end +c----------------------------------------------------------------------------- + logical function seq_comp(itypea,itypeb,length) + implicit none + integer length,itypea(length),itypeb(length) + integer i + do i=1,length + if (itypea(i).ne.itypeb(i)) then + seq_comp=.false. + return + endif + enddo + seq_comp=.true. + return + end +c----------------------------------------------------------------------------- + subroutine read_bridge +C Read information about disulfide bridges. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.NAMES' + include 'COMMON.CHAIN' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' +C Read bridging residues. + read (inp,*) ns,(iss(i),i=1,ns) + print *,'ns=',ns + write (iout,*) 'ns=',ns,' iss:',(iss(i),i=1,ns) +C Check whether the specified bridging residues are cystines. + do i=1,ns + if (itype(iss(i)).ne.1) then + write (iout,'(2a,i3,a)') + & 'Do you REALLY think that the residue ',restyp(iss(i)),i, + & ' can form a disulfide bridge?!!!' + write (*,'(2a,i3,a)') + & 'Do you REALLY think that the residue ',restyp(iss(i)),i, + & ' can form a disulfide bridge?!!!' + stop + endif + enddo +C Read preformed bridges. + if (ns.gt.0) then + read (inp,*) nss,(ihpb(i),jhpb(i),i=1,nss) + write (iout,*) 'nss=',nss,' ihpb,jhpb: ',(ihpb(i),jhpb(i),i=1,nss) + if (nss.gt.0) then + nhpb=nss +C Check if the residues involved in bridges are in the specified list of +C bridging residues. + do i=1,nss + do j=1,i-1 + if (ihpb(i).eq.ihpb(j).or.ihpb(i).eq.jhpb(j) + & .or.jhpb(i).eq.ihpb(j).or.jhpb(i).eq.jhpb(j)) then + write (iout,'(a,i3,a)') 'Disulfide pair',i, + & ' contains residues present in other pairs.' + write (*,'(a,i3,a)') 'Disulfide pair',i, + & ' contains residues present in other pairs.' + stop + endif + enddo + do j=1,ns + if (ihpb(i).eq.iss(j)) goto 10 + enddo + write (iout,'(a,i3,a)') 'Pair',i,' contains unknown cystine.' + 10 continue + do j=1,ns + if (jhpb(i).eq.iss(j)) goto 20 + enddo + write (iout,'(a,i3,a)') 'Pair',i,' contains unknown cystine.' + 20 continue + dhpb(i)=dbr + forcon(i)=fbr + enddo + do i=1,nss + ihpb(i)=ihpb(i)+nres + jhpb(i)=jhpb(i)+nres + enddo + endif + endif + return + end +c------------------------------------------------------------------------------ + subroutine read_angles(kanal,iscor,energ,iprot,*) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.INTERACT' + include 'COMMON.SBRIDGE' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + character*80 lineh + read(kanal,'(a80)',end=10,err=10) lineh + read(lineh(:5),*,err=8) ic + read(lineh(6:),*,err=8) energ + goto 9 + 8 ic=1 + print *,'error, assuming e=1d10',lineh + energ=1d10 + nss=0 + 9 continue + read(lineh(18:),*,end=10,err=10) nss + IF (NSS.LT.9) THEN + read (lineh(20:),*,end=10,err=10) + & (IHPB(I),JHPB(I),I=1,NSS),iscor + ELSE + read (lineh(20:),*,end=10,err=10) (IHPB(I),JHPB(I),I=1,8) + read (kanal,*,end=10,err=10) (IHPB(I),JHPB(I), + & I=9,NSS),iscor + ENDIF +c print *,"energy",energ," iscor",iscor + read (kanal,*,err=10,end=10) (theta(i),i=3,nres) + read (kanal,*,err=10,end=10) (phi(i),i=4,nres) + read (kanal,*,err=10,end=10) (alph(i),i=2,nres-1) + read (kanal,*,err=10,end=10) (omeg(i),i=2,nres-1) + do i=1,nres + theta(i)=deg2rad*theta(i) + phi(i)=deg2rad*phi(i) + alph(i)=deg2rad*alph(i) + omeg(i)=deg2rad*omeg(i) + enddo + return + 10 return1 + end +c------------------------------------------------------------------------------- + subroutine read_dist_constr + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.SBRIDGE' + integer ifrag_(2,100),ipair_(2,100) + double precision wfrag_(100),wpair_(100) + character*500 controlcard +c write (iout,*) "Calling read_dist_constr" +c write (iout,*) "nres",nres," nstart_sup",nstart_sup," nsup",nsup +c call flush(iout) + call card_concat(controlcard,.true.) + call readi(controlcard,"NFRAG",nfrag_,0) + call readi(controlcard,"NPAIR",npair_,0) + call readi(controlcard,"NDIST",ndist_,0) + call reada(controlcard,'DIST_CUT',dist_cut,5.0d0) + call multreadi(controlcard,"IFRAG",ifrag_(1,1),2*nfrag_,0) + call multreadi(controlcard,"IPAIR",ipair_(1,1),2*npair_,0) + call multreada(controlcard,"WFRAG",wfrag_(1),nfrag_,0.0d0) + call multreada(controlcard,"WPAIR",wpair_(1),npair_,0.0d0) + write (iout,*) "NFRAG",nfrag_," NPAIR",npair_," NDIST",ndist_ + write (iout,*) "IFRAG" + do i=1,nfrag_ + write (iout,*) i,ifrag_(1,i),ifrag_(2,i),wfrag_(i) + enddo + write (iout,*) "IPAIR" + do i=1,npair_ + write (iout,*) i,ipair_(1,i),ipair_(2,i),wpair_(i) + enddo + call flush(iout) + if (.not.refstr .and. nfrag_.gt.0) then + write (iout,*) + & "ERROR: no reference structure to compute distance restraints" + write (iout,*) + & "Restraints must be specified explicitly (NDIST=number)" + stop + endif + if (nfrag_.lt.2 .and. npair_.gt.0) then + write (iout,*) "ERROR: Less than 2 fragments specified", + & " but distance restraints between pairs requested" + stop + endif + call flush(iout) + do i=1,nfrag_ + if (ifrag_(1,i).lt.nstart_sup) ifrag_(1,i)=nstart_sup + if (ifrag_(2,i).gt.nstart_sup+nsup-1) + & ifrag_(2,i)=nstart_sup+nsup-1 +c write (iout,*) i,ifrag_(1,i),ifrag_(2,i),wfrag_(i) + call flush(iout) + if (wfrag_(i).gt.0.0d0) then + do j=ifrag_(1,i),ifrag_(2,i)-1 + do k=j+1,ifrag_(2,i) + write (iout,*) "j",j," k",k + ddjk=dist(j,k) + if (constr_dist.eq.1) then + nhpb=nhpb+1 + ihpb(nhpb)=j + jhpb(nhpb)=k + dhpb(nhpb)=ddjk + forcon(nhpb)=wfrag_(i) + else if (constr_dist.eq.2) then + if (ddjk.le.dist_cut) then + nhpb=nhpb+1 + ihpb(nhpb)=j + jhpb(nhpb)=k + dhpb(nhpb)=ddjk + forcon(nhpb)=wfrag_(i) + endif + else + nhpb=nhpb+1 + ihpb(nhpb)=j + jhpb(nhpb)=k + dhpb(nhpb)=ddjk + forcon(nhpb)=wfrag_(i)*dexp(-0.5d0*(ddjk/dist_cut)**2) + endif + write (iout,'(a,3i5,f8.2,1pe12.2)') "+dist.constr ", + & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) + enddo + enddo + endif + enddo + do i=1,npair_ + if (wpair_(i).gt.0.0d0) then + ii = ipair_(1,i) + jj = ipair_(2,i) + if (ii.gt.jj) then + itemp=ii + ii=jj + jj=itemp + endif + do j=ifrag_(1,ii),ifrag_(2,ii) + do k=ifrag_(1,jj),ifrag_(2,jj) + nhpb=nhpb+1 + ihpb(nhpb)=j + jhpb(nhpb)=k + forcon(nhpb)=wpair_(i) + dhpb(nhpb)=dist(j,k) + write (iout,'(a,3i5,f8.2,f10.1)') "+dist.constr ", + & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) + enddo + enddo + endif + enddo + do i=1,ndist_ + read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),dhpb(i),dhpb1(i), + & ibecarb(i),forcon(nhpb+1) + if (forcon(nhpb+1).gt.0.0d0) then + nhpb=nhpb+1 + if (ibecarb(i).gt.0) then + ihpb(i)=ihpb(i)+nres + jhpb(i)=jhpb(i)+nres + endif + if (dhpb(nhpb).eq.0.0d0) + & dhpb(nhpb)=dist(ihpb(nhpb),jhpb(nhpb)) + endif + enddo + do i=1,nhpb + write (iout,'(a,3i5,2f8.2,i2,f10.1)') "+dist.constr ", + & i,ihpb(i),jhpb(i),dhpb(i),dhpb1(i),ibecarb(i),forcon(i) + enddo + call flush(iout) + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/mygetenv.F b/source/wham/src-NEWSC-NEWCORR/mygetenv.F new file mode 100644 index 0000000..b5ea4a2 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/mygetenv.F @@ -0,0 +1,55 @@ + subroutine mygetenv(string,var) +C +C Version 1.0 +C +C This subroutine passes the environmental variables to FORTRAN program. +C If the flags -DMYGETENV and -DMPI are not for compilation, it calls the +C standard FORTRAN GETENV subroutine. If both flags are set, the subroutine +C reads the environmental variables from $HOME/.env +C +C Usage: As for the standard FORTRAN GETENV subroutine. +C +C Purpose: some versions/installations of MPI do not transfer the environmental +C variables to slave processors, if these variables are set in the shell script +C from which mpirun is called. +C +C A.Liwo, 7/29/01 +C + implicit none + character*(*) string,var +#if defined(MYGETENV) && defined(MPI) + include "DIMENSIONS.ZSCOPT" + include "mpif.h" + include "COMMON.MPI" + character*360 ucase + external ucase + character*360 string1(360),karta + character*240 home + integer i,n,ilen + external ilen + call getenv("HOME",home) + open(99,file=home(:ilen(home))//"/.env",status="OLD",err=112) + do while (.true.) + read (99,end=111,err=111,'(a)') karta + do i=1,80 + string1(i)=" " + enddo + call split_string(karta,string1,80,n) + if (ucase(string1(1)(:ilen(string1(1)))).eq."SETENV" .and. + & string1(2)(:ilen(string1(2))).eq.string(:ilen(string)) ) then + var=string1(3) + print *,"Processor",me,": ",var(:ilen(var)), + & " assigned to ",string(:ilen(string)) + close(99) + return + endif + enddo + 111 print *,"Environment variable ",string(:ilen(string))," not set." + close(99) + return + 112 print *,"Error opening environment file!" +#else + call getenv(string,var) +#endif + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/mysort.f b/source/wham/src-NEWSC-NEWCORR/mysort.f new file mode 100644 index 0000000..cb1bbe7 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/mysort.f @@ -0,0 +1,52 @@ + subroutine imysort(n, m, mm, x, y, z, z1, z2, z3, z4, z5, z6) + implicit none + integer n,m,mm + integer x(m,mm,n),y(n),z(n),z1(2,n),z6(n),xmin,xtemp + double precision z2(n),z3(n),z4(n),z5(n) + double precision xxtemp + integer i,j,k,imax + do i=1,n + xmin=x(1,1,i) + imax=i + do j=i+1,n + if (x(1,1,j).lt.xmin) then + imax=j + xmin=x(1,1,j) + endif + enddo + xxtemp=z2(imax) + z2(imax)=z2(i) + z2(i)=xxtemp + xxtemp=z3(imax) + z3(imax)=z3(i) + z3(i)=xxtemp + xxtemp=z4(imax) + z4(imax)=z4(i) + z4(i)=xxtemp + xxtemp=z5(imax) + z5(imax)=z5(i) + z5(i)=xxtemp + xtemp=y(imax) + y(imax)=y(i) + y(i)=xtemp + xtemp=z(imax) + z(imax)=z(i) + z(i)=xtemp + xtemp=z6(imax) + z6(imax)=z6(i) + z6(i)=xtemp + do j=1,2 + xtemp=z1(j,imax) + z1(j,imax)=z1(j,i) + z1(j,i)=xtemp + enddo + do j=1,m + do k=1,mm + xtemp=x(j,k,imax) + x(j,k,imax)=x(j,k,i) + x(j,k,i)=xtemp + enddo + enddo + enddo + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/odlodc.f b/source/wham/src-NEWSC-NEWCORR/odlodc.f new file mode 100644 index 0000000..c18ac72 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/odlodc.f @@ -0,0 +1,55 @@ + subroutine odlodc(r1,r2,a,b,uu,vv,aa,bb,dd) + implicit real*8 (a-h,o-z) + dimension r1(3),r2(3),a(3),b(3),x(3),y(3) + odl(u,v) = (r1(1)-r2(1))**2+(r1(2)-r2(2))**2+(r1(3)-r2(3))**2 + & + 2*ar*u - 2*br*v - 2*ab*u*v + aa*u**2 + bb*v**2 +c print *,"r1",(r1(i),i=1,3) +c print *,"r2",(r2(i),i=1,3) +c print *,"a",(a(i),i=1,3) +c print *,"b",(b(i),i=1,3) + aa = a(1)**2+a(2)**2+a(3)**2 + bb = b(1)**2+b(2)**2+b(3)**2 + ab = a(1)*b(1)+a(2)*b(2)+a(3)*b(3) + ar = a(1)*(r1(1)-r2(1))+a(2)*(r1(2)-r2(2))+a(3)*(r1(3)-r2(3)) + br = b(1)*(r1(1)-r2(1))+b(2)*(r1(2)-r2(2))+b(3)*(r1(3)-r2(3)) + det = aa*bb-ab**2 +c print *,'aa',aa,' bb',bb,' ab',ab,' ar',ar,' br',br,' det',det + uu = (-ar*bb+br*ab)/det + vv = (br*aa-ar*ab)/det +c print *,u,v + uu=dmin1(uu,1.0d0) + uu=dmax1(uu,0.0d0) + vv=dmin1(vv,1.0d0) + vv=dmax1(vv,0.0d0) + dd1 = odl(uu,vv) + dd2 = odl(0.0d0,0.0d0) + dd3 = odl(0.0d0,1.0d0) + dd4 = odl(1.0d0,0.0d0) + dd5 = odl(1.0d0,1.0d0) + dd = dsqrt(dmin1(dd1,dd2,dd3,dd4,dd5)) + if (dd.eq.dd2) then + uu=0.0d0 + vv=0.0d0 + else if (dd.eq.dd3) then + uu=0.0d0 + vv=1.0d0 + else if (dd.eq.dd4) then + uu=1.0d0 + vv=0.0d0 + else if (dd.eq.dd5) then + uu=1.0d0 + vv=1.0d0 + endif +c Control check +c do i=1,3 +c x(i)=r1(i)+u*a(i) +c y(i)=r2(i)+v*b(i) +c enddo +c dd1 = (x(1)-y(1))**2+(x(2)-y(2))**2+(x(3)-y(3))**2 +c dd1 = dsqrt(dd1) + aa = dsqrt(aa) + bb = dsqrt(bb) +c write (8,*) uu,vv,dd,dd1 +c print *,dd,dd1 + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/openunits.F b/source/wham/src-NEWSC-NEWCORR/openunits.F new file mode 100644 index 0000000..b9f54b7 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/openunits.F @@ -0,0 +1,105 @@ + subroutine openunits +#ifdef WIN + use dfport +#endif + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' +#ifdef MPI + include 'mpif.h' + include 'COMMON.MPI' + integer MyRank + character*3 liczba +#endif + include 'COMMON.IOUNITS' + integer lenpre,lenpot,ilen + external ilen + +#ifdef MPI + MyRank=Me +#endif + call mygetenv('PREFIX',prefix) + call mygetenv('SCRATCHDIR',scratchdir) + call mygetenv('POT',pot) + lenpre=ilen(prefix) + lenpot=ilen(pot) + call mygetenv('POT',pot) + entname=prefix(:lenpre)//'_'//pot(:lenpot)//'.entr' +C Get the names and open the input files + open (1,file=prefix(:ilen(prefix))//'.inp',status='old') +C Get parameter filenames and open the parameter files. + call mygetenv('BONDPAR',bondname) + open (ibond,file=bondname,status='old') + call mygetenv('THETPAR',thetname) + open (ithep,file=thetname,status='old') + call mygetenv('ROTPAR',rotname) + open (irotam,file=rotname,status='old') + call mygetenv('TORPAR',torname) + open (itorp,file=torname,status='old') + call mygetenv('TORDPAR',tordname) + open (itordp,file=tordname,status='old') + call mygetenv('FOURIER',fouriername) + open (ifourier,file=fouriername,status='old') + call mygetenv('SCCORPAR',sccorname) + open (isccor,file=sccorname,status='old') + call mygetenv('ELEPAR',elename) + open (ielep,file=elename,status='old') + call mygetenv('SIDEPAR',sidename) + open (isidep,file=sidename,status='old') + call mygetenv('SIDEP',sidepname) + open (isidep1,file=sidepname,status="old") +#ifndef OLDSCP +C +C 8/9/01 In the newest version SCp interaction constants are read from a file +C Use -DOLDSCP to use hard-coded constants instead. +C + call mygetenv('SCPPAR',scpname) + open (iscpp,file=scpname,status='old') +#endif +#ifdef MPL + if (MyID.eq.BossID) then + MyRank = MyID/fgProcs +#endif +#ifdef MPI + print *,'OpenUnits: processor',MyRank + call numstr(MyRank,liczba) + outname=prefix(:lenpre)//'.out_'//pot(:lenpot)//liczba +#else + outname=prefix(:lenpre)//'.out_'//pot(:lenpot) +#endif + open(iout,file=outname,status='unknown') + write (iout,'(80(1h-))') + write (iout,'(30x,a)') "FILE ASSIGNMENT" + write (iout,'(80(1h-))') + write (iout,*) "Input file : ", + & prefix(:ilen(prefix))//'.inp' + write (iout,*) "Output file : ", + & outname(:ilen(outname)) + write (iout,*) + write (iout,*) "Sidechain potential file : ", + & sidename(:ilen(sidename)) +#ifndef OLDSCP + write (iout,*) "SCp potential file : ", + & scpname(:ilen(scpname)) +#endif + write (iout,*) "Electrostatic potential file : ", + & elename(:ilen(elename)) + write (iout,*) "Cumulant coefficient file : ", + & fouriername(:ilen(fouriername)) + write (iout,*) "Torsional parameter file : ", + & torname(:ilen(torname)) + write (iout,*) "Double torsional parameter file : ", + & tordname(:ilen(tordname)) + write (iout,*) "Backbone-rotamer parameter file : ", + & sccorname(:ilen(sccorname)) + write (iout,*) "Bond & inertia constant file : ", + & bondname(:ilen(bondname)) + write (iout,*) "Bending parameter file : ", + & thetname(:ilen(thetname)) + write (iout,*) "Rotamer parameter file : ", + & rotname(:ilen(rotname)) + write (iout,'(80(1h-))') + write (iout,*) + return + end + diff --git a/source/wham/src-NEWSC-NEWCORR/parmread.F b/source/wham/src-NEWSC-NEWCORR/parmread.F new file mode 100644 index 0000000..ba6ec3e --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/parmread.F @@ -0,0 +1,1164 @@ + subroutine parmread(iparm,*) +C +C Read the parameters of the probability distributions of the virtual-bond +C valence angles and the side chains and energy parameters. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.FREE' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.FFIELD' + include 'COMMON.NAMES' + include 'COMMON.SBRIDGE' + include 'COMMON.WEIGHTS' + include 'COMMON.ENEPS' + include 'COMMON.SCCOR' + include 'COMMON.SCROT' + include 'COMMON.FREE' + character*1 t1,t2,t3 + character*1 onelett(4) /"G","A","P","D"/ + logical lprint + dimension blower(3,3,maxlob) + character*800 controlcard + character*256 bondname_t,thetname_t,rotname_t,torname_t, + & tordname_t,fouriername_t,elename_t,sidename_t,scpname_t, + & sccorname_t + integer ilen + external ilen + character*16 key + integer iparm + double precision ip,mp +C +C Body +C +C Set LPRINT=.TRUE. for debugging + dwa16=2.0d0**(1.0d0/6.0d0) + lprint=.true. + itypro=20 +C Assign virtual-bond length + vbl=3.8D0 + vblinv=1.0D0/vbl + vblinv2=vblinv*vblinv + call card_concat(controlcard,.true.) + wname(4)="WCORRH" + do i=1,n_ene + key = wname(i)(:ilen(wname(i))) + call reada(controlcard,key(:ilen(key)),ww(i),1.0d0) + enddo + + write (iout,*) "iparm",iparm," myparm",myparm +c If reading not own parameters, skip assignment + + if (iparm.eq.myparm .or. .not.separate_parset) then + +c +c Setup weights for UNRES +c + wsc=ww(1) + wscp=ww(2) + welec=ww(3) + wcorr=ww(4) + wcorr5=ww(5) + wcorr6=ww(6) + wel_loc=ww(7) + wturn3=ww(8) + wturn4=ww(9) + wturn6=ww(10) + wang=ww(11) + wscloc=ww(12) + wtor=ww(13) + wtor_d=ww(14) + wvdwpp=ww(16) + wstrain=ww(15) + wbond=ww(18) + wsccor=ww(19) + + endif + + call card_concat(controlcard,.false.) + +c Return if not own parameters + + if (iparm.ne.myparm .and. separate_parset) return + + call reads(controlcard,"BONDPAR",bondname_t,bondname) + open (ibond,file=bondname_t,status='old') + rewind(ibond) + call reads(controlcard,"THETPAR",thetname_t,thetname) + open (ithep,file=thetname_t,status='old') + rewind(ithep) + call reads(controlcard,"ROTPAR",rotname_t,rotname) + open (irotam,file=rotname_t,status='old') + rewind(irotam) + call reads(controlcard,"TORPAR",torname_t,torname) + open (itorp,file=torname_t,status='old') + rewind(itorp) + call reads(controlcard,"TORDPAR",tordname_t,tordname) + open (itordp,file=tordname_t,status='old') + rewind(itordp) + call reads(controlcard,"SCCORAR",sccorname_t,sccorname) + open (isccor,file=sccorname_t,status='old') + rewind(isccor) + call reads(controlcard,"FOURIER",fouriername_t,fouriername) + open (ifourier,file=fouriername_t,status='old') + rewind(ifourier) + call reads(controlcard,"ELEPAR",elename_t,elename) + open (ielep,file=elename_t,status='old') + rewind(ielep) + call reads(controlcard,"SIDEPAR",sidename_t,sidename) + open (isidep,file=sidename_t,status='old') + rewind(isidep) + call reads(controlcard,"SCPPAR",scpname_t,scpname) + open (iscpp,file=scpname_t,status='old') + rewind(iscpp) + write (iout,*) "Parameter set:",iparm + write (iout,*) "Energy-term weights:" + do i=1,n_ene + write (iout,'(a16,f10.5)') wname(i),ww(i) + enddo + write (iout,*) "Sidechain potential file : ", + & sidename_t(:ilen(sidename_t)) +#ifndef OLDSCP + write (iout,*) "SCp potential file : ", + & scpname_t(:ilen(scpname_t)) +#endif + write (iout,*) "Electrostatic potential file : ", + & elename_t(:ilen(elename_t)) + write (iout,*) "Cumulant coefficient file : ", + & fouriername_t(:ilen(fouriername_t)) + write (iout,*) "Torsional parameter file : ", + & torname_t(:ilen(torname_t)) + write (iout,*) "Double torsional parameter file : ", + & tordname_t(:ilen(tordname_t)) + write (iout,*) "Backbone-rotamer parameter file : ", + & sccorname(:ilen(sccorname)) + write (iout,*) "Bond & inertia constant file : ", + & bondname_t(:ilen(bondname_t)) + write (iout,*) "Bending parameter file : ", + & thetname_t(:ilen(thetname_t)) + write (iout,*) "Rotamer parameter file : ", + & rotname_t(:ilen(rotname_t)) + +c +c Read the virtual-bond parameters, masses, and moments of inertia +c and Stokes' radii of the peptide group and side chains +c +#ifdef CRYST_BOND + read (ibond,*,end=110,err=110) vbldp0,akp + do i=1,ntyp + nbondterm(i)=1 + read (ibond,*,end=110,err=110) vbldsc0(1,i),aksc(1,i) + dsc(i) = vbldsc0(1,i) + if (i.eq.10) then + dsc_inv(i)=0.0D0 + else + dsc_inv(i)=1.0D0/dsc(i) + endif + enddo +#else + read (ibond,*,end=110,err=110) ijunk,vbldp0,akp,rjunk + do i=1,ntyp + read (ibond,*,end=110,err=110) nbondterm(i),(vbldsc0(j,i), + & aksc(j,i),abond0(j,i), + & j=1,nbondterm(i)) + dsc(i) = vbldsc0(1,i) + if (i.eq.10) then + dsc_inv(i)=0.0D0 + else + dsc_inv(i)=1.0D0/dsc(i) + endif + enddo +#endif + if (lprint) then + write(iout,'(/a/)')"Force constants virtual bonds:" + write (iout,'(a10,a3,6a10)') 'Type','N','VBL','K', + & 'inertia','Pstok' + write(iout,'(a10,i3,6f10.5)') "p",1,vbldp0,akp,0.0d0 + do i=1,ntyp + write (iout,'(a10,i3,6f10.5)') restyp(i),nbondterm(i), + & vbldsc0(1,i),aksc(1,i),abond0(1,i) + do j=2,nbondterm(i) + write (iout,'(13x,3f10.5)') + & vbldsc0(j,i),aksc(j,i),abond0(j,i) + enddo + enddo + endif +#ifdef CRYST_THETA +C +C Read the parameters of the probability distribution/energy expression +C of the virtual-bond valence angles theta +C + do i=1,ntyp + read (ithep,*,end=111,err=111) a0thet(i),(athet(j,i),j=1,2), + & (bthet(j,i),j=1,2) + read (ithep,*,end=111,err=111) (polthet(j,i),j=0,3) + read (ithep,*,end=111,err=111) (gthet(j,i),j=1,3) + read (ithep,*,end=111,err=111) theta0(i),sig0(i),sigc0(i) + sigc0(i)=sigc0(i)**2 + enddo + close (ithep) + if (lprint) then +c write (iout,'(a)') +c & 'Parameters of the virtual-bond valence angles:' +c write (iout,'(/a/9x,5a/79(1h-))') 'Fourier coefficients:', +c & ' ATHETA0 ',' A1 ',' A2 ', +c & ' B1 ',' B2 ' +c do i=1,ntyp +c write(iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i, +c & a0thet(i),(athet(j,i),j=1,2),(bthet(j,i),j=1,2) +c enddo +c write (iout,'(/a/9x,5a/79(1h-))') +c & 'Parameters of the expression for sigma(theta_c):', +c & ' ALPH0 ',' ALPH1 ',' ALPH2 ', +c & ' ALPH3 ',' SIGMA0C ' +c do i=1,ntyp +c write (iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i, +c & (polthet(j,i),j=0,3),sigc0(i) +c enddo +c write (iout,'(/a/9x,5a/79(1h-))') +c & 'Parameters of the second gaussian:', +c & ' THETA0 ',' SIGMA0 ',' G1 ', +c & ' G2 ',' G3 ' +c do i=1,ntyp +c write (iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i,theta0(i), +c & sig0(i),(gthet(j,i),j=1,3) +c enddo + write (iout,'(a)') + & 'Parameters of the virtual-bond valence angles:' + write (iout,'(/a/9x,5a/79(1h-))') + & 'Coefficients of expansion', + & ' theta0 ',' a1*10^2 ',' a2*10^2 ', + & ' b1*10^1 ',' b2*10^1 ' + do i=1,ntyp + write(iout,'(a3,1h&,2x,5(f8.3,1h&))') restyp(i), + & a0thet(i),(100*athet(j,i),j=1,2),(10*bthet(j,i),j=1,2) + enddo + write (iout,'(/a/9x,5a/79(1h-))') + & 'Parameters of the expression for sigma(theta_c):', + & ' alpha0 ',' alph1 ',' alph2 ', + & ' alhp3 ',' sigma0c ' + do i=1,ntyp + write (iout,'(a3,1h&,2x,5(1pe12.3,1h&))') restyp(i), + & (polthet(j,i),j=0,3),sigc0(i) + enddo + write (iout,'(/a/9x,5a/79(1h-))') + & 'Parameters of the second gaussian:', + & ' theta0 ',' sigma0*10^2 ',' G1*10^-1', + & ' G2 ',' G3*10^1 ' + do i=1,ntyp + write (iout,'(a3,1h&,2x,5(f8.3,1h&))') restyp(i),theta0(i), + & 100*sig0(i),gthet(1,i)*0.1D0,gthet(2,i),gthet(3,i)*10.0D0 + enddo + endif +#else +C +C Read the parameters of Utheta determined from ab initio surfaces +C Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203 +C + read (ithep,*,end=111,err=111) nthetyp,ntheterm,ntheterm2, + & ntheterm3,nsingle,ndouble + nntheterm=max0(ntheterm,ntheterm2,ntheterm3) + read (ithep,*,end=111,err=111) (ithetyp(i),i=1,ntyp1) + do i=1,maxthetyp + do j=1,maxthetyp + do k=1,maxthetyp + aa0thet(i,j,k)=0.0d0 + do l=1,ntheterm + aathet(l,i,j,k)=0.0d0 + enddo + do l=1,ntheterm2 + do m=1,nsingle + bbthet(m,l,i,j,k)=0.0d0 + ccthet(m,l,i,j,k)=0.0d0 + ddthet(m,l,i,j,k)=0.0d0 + eethet(m,l,i,j,k)=0.0d0 + enddo + enddo + do l=1,ntheterm3 + do m=1,ndouble + do mm=1,ndouble + ffthet(mm,m,l,i,j,k)=0.0d0 + ggthet(mm,m,l,i,j,k)=0.0d0 + enddo + enddo + enddo + enddo + enddo + enddo + do i=1,nthetyp + do j=1,nthetyp + do k=1,nthetyp + read (ithep,'(3a)',end=111,err=111) res1,res2,res3 + read (ithep,*,end=111,err=111) aa0thet(i,j,k) + read (ithep,*,end=111,err=111)(aathet(l,i,j,k),l=1,ntheterm) + read (ithep,*,end=111,err=111) + & ((bbthet(lll,ll,i,j,k),lll=1,nsingle), + & (ccthet(lll,ll,i,j,k),lll=1,nsingle), + & (ddthet(lll,ll,i,j,k),lll=1,nsingle), + & (eethet(lll,ll,i,j,k),lll=1,nsingle),ll=1,ntheterm2) + read (ithep,*,end=111,err=111) + & (((ffthet(llll,lll,ll,i,j,k),ffthet(lll,llll,ll,i,j,k), + & ggthet(llll,lll,ll,i,j,k),ggthet(lll,llll,ll,i,j,k), + & llll=1,lll-1),lll=2,ndouble),ll=1,ntheterm3) + enddo + enddo + enddo +C +C For dummy ends assign glycine-type coefficients of theta-only terms; the +C coefficients of theta-and-gamma-dependent terms are zero. +C + do i=1,nthetyp + do j=1,nthetyp + do l=1,ntheterm + aathet(l,i,j,nthetyp+1)=aathet(l,i,j,1) + aathet(l,nthetyp+1,i,j)=aathet(l,1,i,j) + enddo + aa0thet(i,j,nthetyp+1)=aa0thet(i,j,1) + aa0thet(nthetyp+1,i,j)=aa0thet(1,i,j) + enddo + do l=1,ntheterm + aathet(l,nthetyp+1,i,nthetyp+1)=aathet(l,1,i,1) + enddo + aa0thet(nthetyp+1,i,nthetyp+1)=aa0thet(1,i,1) + enddo +C +C Control printout of the coefficients of virtual-bond-angle potentials +C + if (lprint) then + write (iout,'(//a)') 'Parameter of virtual-bond-angle potential' + do i=1,nthetyp+1 + do j=1,nthetyp+1 + do k=1,nthetyp+1 + write (iout,'(//4a)') + & 'Type ',onelett(i),onelett(j),onelett(k) + write (iout,'(//a,10x,a)') " l","a[l]" + write (iout,'(i2,1pe15.5)') 0,aa0thet(i,j,k) + write (iout,'(i2,1pe15.5)') + & (l,aathet(l,i,j,k),l=1,ntheterm) + do l=1,ntheterm2 + write (iout,'(//2h m,4(9x,a,3h[m,i1,1h]))') + & "b",l,"c",l,"d",l,"e",l + do m=1,nsingle + write (iout,'(i2,4(1pe15.5))') m, + & bbthet(m,l,i,j,k),ccthet(m,l,i,j,k), + & ddthet(m,l,i,j,k),eethet(m,l,i,j,k) + enddo + enddo + do l=1,ntheterm3 + write (iout,'(//3hm,n,4(6x,a,5h[m,n,i1,1h]))') + & "f+",l,"f-",l,"g+",l,"g-",l + do m=2,ndouble + do n=1,m-1 + write (iout,'(i1,1x,i1,4(1pe15.5))') n,m, + & ffthet(n,m,l,i,j,k),ffthet(m,n,l,i,j,k), + & ggthet(n,m,l,i,j,k),ggthet(m,n,l,i,j,k) + enddo + enddo + enddo + enddo + enddo + enddo + call flush(iout) + endif +#endif + +#ifdef CRYST_SC +C +C Read the parameters of the probability distribution/energy expression +C of the side chains. +C + do i=1,ntyp + read (irotam,'(3x,i3,f8.3)',end=112,err=112) nlob(i),dsc(i) + if (i.eq.10) then + dsc_inv(i)=0.0D0 + else + dsc_inv(i)=1.0D0/dsc(i) + endif + if (i.ne.10) then + do j=1,nlob(i) + do k=1,3 + do l=1,3 + blower(l,k,j)=0.0D0 + enddo + enddo + enddo + bsc(1,i)=0.0D0 + read(irotam,*,end=112,err=112)(censc(k,1,i),k=1,3), + & ((blower(k,l,1),l=1,k),k=1,3) + do j=2,nlob(i) + read (irotam,*,end=112,err=112) bsc(j,i) + read (irotam,*,end=112,err=112) (censc(k,j,i),k=1,3), + & ((blower(k,l,j),l=1,k),k=1,3) + enddo + do j=1,nlob(i) + do k=1,3 + do l=1,k + akl=0.0D0 + do m=1,3 + akl=akl+blower(k,m,j)*blower(l,m,j) + enddo + gaussc(k,l,j,i)=akl + gaussc(l,k,j,i)=akl + enddo + enddo + enddo + endif + enddo + close (irotam) + if (lprint) then + write (iout,'(/a)') 'Parameters of side-chain local geometry' + do i=1,ntyp + nlobi=nlob(i) + if (nlobi.gt.0) then + write (iout,'(/3a,i2,a,f8.3)') 'Residue type: ',restyp(i), + & ' # of gaussian lobes:',nlobi,' dsc:',dsc(i) +c write (iout,'(/a,8x,i1,4(25x,i1))') 'Lobe:',(j,j=1,nlobi) +c write (iout,'(a,f10.4,4(16x,f10.4))') +c & 'Center ',(bsc(j,i),j=1,nlobi) +c write (iout,'(5(2x,3f8.4))') ((censc(k,j,i),k=1,3),j=1,nlobi) + write (iout,'(1h&,a,3(2h&&,f8.3,2h&&))') + & 'log h',(bsc(j,i),j=1,nlobi) + write (iout,'(1h&,a,3(1h&,f8.3,1h&,f8.3,1h&,f8.3,1h&))') + & 'x',((censc(k,j,i),k=1,3),j=1,nlobi) +c write (iout,'(a)') +c do j=1,nlobi +c ind=0 +c do k=1,3 +c do l=1,k +c ind=ind+1 +c blower(k,l,j)=gaussc(ind,j,i) +c enddo +c enddo +c enddo + do k=1,3 + write (iout,'(2h& ,5(2x,1h&,3(f7.3,1h&)))') + & ((gaussc(k,l,j,i),l=1,3),j=1,nlobi) + enddo + endif + enddo + endif +#else +C +C Read scrot parameters for potentials determined from all-atom AM1 calculations +C added by Urszula Kozlowska 07/11/2007 +C + do i=1,ntyp + read (irotam,*,end=112,err=112) + if (i.eq.10) then + read (irotam,*,end=112,err=112) + else + do j=1,65 + read(irotam,*,end=112,err=112) sc_parmin(j,i) + enddo + endif + enddo +#endif + close(irotam) +#ifdef CRYST_TOR +C +C Read torsional parameters in old format +C + read (itorp,*,end=113,err=113) ntortyp,nterm_old + write (iout,*) 'ntortyp,nterm',ntortyp,nterm_old + read (itorp,*,end=113,err=113) (itortyp(i),i=1,ntyp) + do i=1,ntortyp + do j=1,ntortyp + read (itorp,'(a)',end=113,err=113) + do k=1,nterm_old + read (itorp,*,end=113,err=113) kk,v1(k,j,i),v2(k,j,i) + enddo + enddo + enddo + close (itorp) + if (lprint) then + write (iout,'(/a/)') 'Torsional constants:' + do i=1,ntortyp + do j=1,ntortyp + write (iout,'(2i3,6f10.5)') i,j,(v1(k,i,j),k=1,nterm_old) + write (iout,'(6x,6f10.5)') (v2(k,i,j),k=1,nterm_old) + enddo + enddo + endif + + +#else +C +C Read torsional parameters +C + read (itorp,*,end=113,err=113) ntortyp + read (itorp,*,end=113,err=113) (itortyp(i),i=1,ntyp) + write (iout,*) 'ntortyp',ntortyp + do i=1,ntortyp + do j=1,ntortyp + read (itorp,*,end=113,err=113) nterm(i,j),nlor(i,j) + v0ij=0.0d0 + si=-1.0d0 + do k=1,nterm(i,j) + read (itorp,*,end=113,err=113) kk,v1(k,i,j),v2(k,i,j) + v0ij=v0ij+si*v1(k,i,j) + si=-si + enddo + do k=1,nlor(i,j) + read (itorp,*,end=113,err=113) kk,vlor1(k,i,j),vlor2(k,i,j), + & vlor3(k,i,j) + v0ij=v0ij+vlor1(k,i,j)/(1+vlor3(k,i,j)**2) + enddo + v0(i,j)=v0ij + enddo + enddo + close (itorp) + if (lprint) then + write (iout,'(/a/)') 'Torsional constants:' + do i=1,ntortyp + do j=1,ntortyp + write (iout,*) 'ityp',i,' jtyp',j + write (iout,*) 'Fourier constants' + do k=1,nterm(i,j) + write (iout,'(2(1pe15.5))') v1(k,i,j),v2(k,i,j) + enddo + write (iout,*) 'Lorenz constants' + do k=1,nlor(i,j) + write (iout,'(3(1pe15.5))') + & vlor1(k,i,j),vlor2(k,i,j),vlor3(k,i,j) + enddo + enddo + enddo + endif +C +C 6/23/01 Read parameters for double torsionals +C + do i=1,ntortyp + do j=1,ntortyp + do k=1,ntortyp + read (itordp,'(3a1)',end=112,err=112) t1,t2,t3 + if (t1.ne.onelett(i) .or. t2.ne.onelett(j) + & .or. t3.ne.onelett(k)) then + write (iout,*) "Error in double torsional parameter file", + & i,j,k,t1,t2,t3 + stop "Error in double torsional parameter file" + endif + read (itordp,*,end=114,err=114) ntermd_1(i,j,k), + & ntermd_2(i,j,k) + read (itordp,*,end=114,err=114) (v1c(1,l,i,j,k), + & l=1,ntermd_1(i,j,k)) + read (itordp,*,end=114,err=114) (v1s(1,l,i,j,k),l=1, + & ntermd_1(i,j,k)) + read (itordp,*,end=114,err=114) (v1c(2,l,i,j,k), + & l=1,ntermd_1(i,j,k)) + read (itordp,*,end=114,err=114) (v1s(2,l,i,j,k),l=1, + & ntermd_1(i,j,k)) + read (itordp,*,end=114,err=114) ((v2c(l,m,i,j,k), + & v2c(m,l,i,j,k), + & v2s(l,m,i,j,k),v2s(m,l,i,j,k),m=1,l-1),l=1,ntermd_2(i,j,k)) + enddo + enddo + enddo + if (lprint) then + write (iout,*) + write (iout,*) 'Constants for double torsionals' + do i=1,ntortyp + do j=1,ntortyp + do k=1,ntortyp + write (iout,*) 'ityp',i,' jtyp',j,' ktyp',k, + & ' nsingle',ntermd_1(i,j,k),' ndouble',ntermd_2(i,j,k) + write (iout,*) + write (iout,*) 'Single angles:' + do l=1,ntermd_1(i,j,k) + write (iout,'(i5,2f10.5,5x,2f10.5)') l, + & v1c(1,l,i,j,k),v1s(1,l,i,j,k), + & v1c(2,l,i,j,k),v1s(2,l,i,j,k) + enddo + write (iout,*) + write (iout,*) 'Pairs of angles:' + write (iout,'(3x,20i10)') (l,l=1,ntermd_2(i,j,k)) + do l=1,ntermd_2(i,j,k) + write (iout,'(i5,20f10.5)') + & l,(v2c(l,m,i,j,k),m=1,ntermd_2(i,j,k)) + enddo + write (iout,*) + write (iout,'(3x,20i10)') (l,l=1,ntermd_2(i,j,k)) + do l=1,ntermd_2(i,j,k) + write (iout,'(i5,20f10.5)') + & l,(v2s(l,m,i,j,k),m=1,ntermd_2(i,j,k)) + enddo + write (iout,*) + enddo + enddo + enddo + endif +#endif +C Read of Side-chain backbone correlation parameters +C Modified 11 May 2012 by Adasko +CCC +C + read (isccor,*,end=119,err=119) nsccortyp + read (isccor,*,end=119,err=119) (isccortyp(i),i=1,ntyp) +c write (iout,*) 'ntortyp',ntortyp + maxinter=3 +cc maxinter is maximum interaction sites + do l=1,maxinter + do i=1,nsccortyp + do j=1,nsccortyp + read (isccor,*,end=119,err=119) nterm_sccor(i,j), + & nlor_sccor(i,j) + v0ijsccor=0.0d0 + si=-1.0d0 + do k=1,nterm_sccor(i,j) + read (isccor,*,end=119,err=119) kk,v1sccor(k,l,i,j) + & ,v2sccor(k,l,i,j) + v0ijsccor=v0ijsccor+si*v1sccor(k,l,i,j) + si=-si + enddo + do k=1,nlor_sccor(i,j) + read (isccor,*,end=119,err=119) kk,vlor1sccor(k,i,j), + & vlor2sccor(k,i,j),vlor3sccor(k,i,j) + v0ijsccor=v0ijsccor+vlor1sccor(k,i,j)/ + &(1+vlor3sccor(k,i,j)**2) + enddo + v0sccor(i,j)=v0ijsccor + enddo + enddo + enddo + close (isccor) + + if (lprint) then + write (iout,'(/a/)') 'Torsional constants:' + do i=1,nsccortyp + do j=1,nsccortyp + write (iout,*) 'ityp',i,' jtyp',j + write (iout,*) 'Fourier constants' + do k=1,nterm_sccor(i,j) + write(iout,'(2(1pe15.5))')(v1sccor(k,l,i,j),v2sccor(k,l,i,j), + & l=1,maxinter) + enddo + write (iout,*) 'Lorenz constants' + do k=1,nlor_sccor(i,j) + write (iout,'(3(1pe15.5))') + & vlor1sccor(k,i,j),vlor2sccor(k,i,j),vlor3sccor(k,i,j) + enddo + enddo + enddo + endif + +C +C 9/18/99 (AL) Read coefficients of the Fourier expansion of the local +C interaction energy of the Gly, Ala, and Pro prototypes. +C + read (ifourier,*,end=115,err=115) nloctyp + do i=1,nloctyp + read (ifourier,*,end=115,err=115) + read (ifourier,*,end=115,err=115) (b(ii,i),ii=1,13) +#ifdef NEWCORR + read (ifourier,*,end=115,err=115) (bnew1(ii,1,i),ii=1,3) + read (ifourier,*,end=115,err=115) (bnew2(ii,1,i),ii=1,3) + read (ifourier,*,end=115,err=115) (bnew1(ii,2,i),ii=1,1) + read (ifourier,*,end=115,err=115) (bnew2(ii,2,i),ii=1,1) + read (ifourier,*,end=115,err=115) (eenew(ii,i),ii=1,1) +#endif + if (lprint) then + write (iout,*) 'Type',i + write (iout,'(a,i2,a,f10.5)') ('b(',ii,')=',b(ii,i),ii=1,13) + endif +#ifdef NEWCORR + B1(1,i) = b(3,i) + B1(2,i) = b(5,i) + B1tilde(1,i) = b(3,i) + B1tilde(2,i) =-b(5,i) + B2(1,i) = b(2,i) + B2(2,i) = b(4,i) +#endif + CC(1,1,i)= b(7,i) + CC(2,2,i)=-b(7,i) + CC(2,1,i)= b(9,i) + CC(1,2,i)= b(9,i) + Ctilde(1,1,i)=b(7,i) + Ctilde(1,2,i)=b(9,i) + Ctilde(2,1,i)=-b(9,i) + Ctilde(2,2,i)=b(7,i) + DD(1,1,i)= b(6,i) + DD(2,2,i)=-b(6,i) + DD(2,1,i)= b(8,i) + DD(1,2,i)= b(8,i) + Dtilde(1,1,i)=b(6,i) + Dtilde(1,2,i)=b(8,i) + Dtilde(2,1,i)=-b(8,i) + Dtilde(2,2,i)=b(6,i) +#ifdef NEWCORR + EEold(1,1,i)= b(10,i)+b(11,i) + EEold(2,2,i)=-b(10,i)+b(11,i) + EEold(2,1,i)= b(12,i)-b(13,i) + EEold(1,2,i)= b(12,i)+b(13,i) + EEold(1,1,-i)= b(10,i)+b(11,i) + EEold(2,2,-i)=-b(10,i)+b(11,i) + EEold(2,1,-i)=-b(12,i)+b(13,i) + EEold(1,2,-i)=-b(12,i)-b(13,i) +#else + EE(1,1,i)= b(10,i)+b(11,i) + EE(2,2,i)=-b(10,i)+b(11,i) + EE(2,1,i)= b(12,i)-b(13,i) + EE(1,2,i)= b(12,i)+b(13,i) +#endif + enddo + if (lprint) then + do i=1,nloctyp + write (iout,*) 'Type',i + write (iout,*) 'B1' +c write (iout,'(f10.5)') B1(:,i) + write(iout,*) B1(1,i),B1(2,i) + write (iout,*) 'B2' +c write (iout,'(f10.5)') B2(:,i) + write(iout,*) B2(1,i),B2(2,i) + write (iout,*) 'CC' + do j=1,2 + write (iout,'(2f10.5)') CC(j,1,i),CC(j,2,i) + enddo + write(iout,*) 'DD' + do j=1,2 + write (iout,'(2f10.5)') DD(j,1,i),DD(j,2,i) + enddo + write(iout,*) 'EE' + do j=1,2 + write (iout,'(2f10.5)') EE(j,1,i),EE(j,2,i) + enddo + enddo + endif +C +C Read electrostatic-interaction parameters +C + if (lprint) then + write (iout,'(/a)') 'Electrostatic interaction constants:' + write (iout,'(1x,a,1x,a,10x,a,11x,a,11x,a,11x,a)') + & 'IT','JT','APP','BPP','AEL6','AEL3' + endif + read (ielep,*,end=116,err=116) ((epp(i,j),j=1,2),i=1,2) + read (ielep,*,end=116,err=116) ((rpp(i,j),j=1,2),i=1,2) + read (ielep,*,end=116,err=116) ((elpp6(i,j),j=1,2),i=1,2) + read (ielep,*,end=116,err=116) ((elpp3(i,j),j=1,2),i=1,2) + close (ielep) + do i=1,2 + do j=1,2 + rri=rpp(i,j)**6 + app (i,j)=epp(i,j)*rri*rri + bpp (i,j)=-2.0D0*epp(i,j)*rri + ael6(i,j)=elpp6(i,j)*4.2D0**6 + ael3(i,j)=elpp3(i,j)*4.2D0**3 + if (lprint) write(iout,'(2i3,4(1pe15.4))')i,j,app(i,j),bpp(i,j), + & ael6(i,j),ael3(i,j) + enddo + enddo +C +C Read side-chain interaction parameters. +C + read (isidep,*,end=117,err=117) ipot,expon + if (ipot.lt.1 .or. ipot.gt.6) then + write (iout,'(2a)') 'Error while reading SC interaction', + & 'potential file - unknown potential type.' + stop + endif + expon2=expon/2 + write(iout,'(/3a,2i3)') 'Potential is ',potname(ipot), + & ', exponents are ',expon,2*expon + goto (10,20,30,30,40,50) ipot +C----------------------- LJ potential --------------------------------- + 10 read (isidep,*,end=117,err=117)((eps(i,j),j=i,ntyp),i=1,ntyp), + & (sigma0(i),i=1,ntyp) + if (lprint) then + write (iout,'(/a/)') 'Parameters of the LJ potential:' + write (iout,'(a/)') 'The epsilon array:' + call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) + write (iout,'(/a)') 'One-body parameters:' + write (iout,'(a,4x,a)') 'residue','sigma' + write (iout,'(a3,6x,f10.5)') (restyp(i),sigma0(i),i=1,ntyp) + endif + goto 60 +C----------------------- LJK potential -------------------------------- + 20 read (isidep,*,end=116,err=116)((eps(i,j),j=i,ntyp),i=1,ntyp), + & (sigma0(i),i=1,ntyp),(rr0(i),i=1,ntyp) + if (lprint) then + write (iout,'(/a/)') 'Parameters of the LJK potential:' + write (iout,'(a/)') 'The epsilon array:' + call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) + write (iout,'(/a)') 'One-body parameters:' + write (iout,'(a,4x,2a)') 'residue',' sigma ',' r0 ' + write (iout,'(a3,6x,2f10.5)') (restyp(i),sigma0(i),rr0(i), + & i=1,ntyp) + endif + goto 60 +C---------------------- GB or BP potential ----------------------------- + 30 read (isidep,*,end=116,err=116)((eps(i,j),j=i,ntyp),i=1,ntyp), + & (sigma0(i),i=1,ntyp),(sigii(i),i=1,ntyp),(chip0(i),i=1,ntyp), + & (alp(i),i=1,ntyp) +C For the GB potential convert sigma'**2 into chi' + if (ipot.eq.4) then + do i=1,ntyp + chip(i)=(chip0(i)-1.0D0)/(chip0(i)+1.0D0) + enddo + endif + if (lprint) then + write (iout,'(/a/)') 'Parameters of the BP potential:' + write (iout,'(a/)') 'The epsilon array:' + call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) + write (iout,'(/a)') 'One-body parameters:' + write (iout,'(a,4x,4a)') 'residue',' sigma ','s||/s_|_^2', + & ' chip ',' alph ' + write (iout,'(a3,6x,4f10.5)') (restyp(i),sigma0(i),sigii(i), + & chip(i),alp(i),i=1,ntyp) + endif + goto 60 +C--------------------- GBV potential ----------------------------------- + 40 read (isidep,*,end=116,err=116)((eps(i,j),j=i,ntyp),i=1,ntyp), + & (sigma0(i),i=1,ntyp),(rr0(i),i=1,ntyp),(sigii(i),i=1,ntyp), + & (chip(i),i=1,ntyp),(alp(i),i=1,ntyp) + if (lprint) then + write (iout,'(/a/)') 'Parameters of the GBV potential:' + write (iout,'(a/)') 'The epsilon array:' + call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) + write (iout,'(/a)') 'One-body parameters:' + write (iout,'(a,4x,5a)') 'residue',' sigma ',' r0 ', + & 's||/s_|_^2',' chip ',' alph ' + write (iout,'(a3,6x,5f10.5)') (restyp(i),sigma0(i),rr0(i), + & sigii(i),chip(i),alp(i),i=1,ntyp) + endif + goto 60 +C--------------------- Momo potential ----------------------------------- + + 50 continue + + read (isidep,*,end=116,err=116) (icharge(i),i=1,ntyp) +c write (2,*) "icharge",(icharge(i),i=1,ntyp) + do i=1,ntyp + do j=1,i +c! write (*,*) "Im in ", i, " ", j + read(isidep,*,end=116,err=116) + & eps(i,j),sigma(i,j),chi(i,j),chi(j,i),chipp(i,j),chipp(j,i), + & (alphasur(k,i,j),k=1,4),sigmap1(i,j),sigmap2(i,j), + & chis(i,j),chis(j,i), + & nstate(i,j),(wstate(k,i,j),k=1,4), + & dhead(1,1,i,j), + & dhead(1,2,i,j), + & dhead(2,1,i,j), + & dhead(2,2,i,j), + & dtail(1,i,j),dtail(2,i,j), + & epshead(i,j),sig0head(i,j), + & rborn(i,j),rborn(j,i), + & (wqdip(k,i,j),k=1,2),wquad(i,j), + & alphapol(i,j),alphapol(j,i), + & (alphiso(k,i,j),k=1,4),sigiso1(i,j),sigiso2(i,j),epsintab(i,j) + END DO + END DO +c! write (*,*) "nstate gly-gly", nstate(10,10) +c! THIS LOOP FILLS PARAMETERS FOR PAIRS OF AA's NOT EXPLICITLY +c! DEFINED IN SCPARM.MOMO. IT DOES SO BY TAKING THEM FROM SYMMETRIC +c! PAIR, FOR EG. IF ARG-HIS IS BLANK, IT WILL TAKE PARAMETERS +c! FROM HIS-ARG. +c! +c! DISABLE IT AT >>YOUR OWN PERIL<< +c! + DO i = 1, ntyp + DO j = i+1, ntyp + eps(i,j) = eps(j,i) + sigma(i,j) = sigma(j,i) + nstate(i,j) = nstate(j,i) + sigmap1(i,j) = sigmap1(j,i) + sigmap2(i,j) = sigmap2(j,i) + sigiso1(i,j) = sigiso1(j,i) + sigiso2(i,j) = sigiso2(j,i) + + DO k = 1, 4 + alphasur(k,i,j) = alphasur(k,j,i) + wstate(k,i,j) = wstate(k,j,i) + alphiso(k,i,j) = alphiso(k,j,i) + END DO + + dhead(2,1,i,j) = dhead(1,1,j,i) + dhead(2,2,i,j) = dhead(1,2,j,i) + dhead(1,1,i,j) = dhead(2,1,j,i) + dhead(1,2,i,j) = dhead(2,2,j,i) + dtail(1,i,j) = dtail(1,j,i) + dtail(2,i,j) = dtail(2,j,i) +c! DO k = 1, 2 +c! DO l = 1, 2 +c! write (*,*) "dhead(k,l,j,i) = ", dhead(k,l,j,i) +c! write (*,*) "dhead(k,l,i,j) = ", dhead(k,l,i,j) +c! dhead(l,k,i,j) = dhead(k,l,j,i) +c! END DO +c! END DO + + epshead(i,j) = epshead(j,i) + sig0head(i,j) = sig0head(j,i) + + DO k = 1, 2 + wqdip(k,i,j) = wqdip(k,j,i) + END DO + + wquad(i,j) = wquad(j,i) + epsintab(i,j) = epsintab(j,i) + + END DO + END DO + + if (.not.lprint) goto 70 + write (iout,'(a)') + & "Parameters of the new physics-based SC-SC interaction potential" + write (iout,'(/7a)') 'Residues',' epsGB',' rGB', + & ' chi1GB',' chi2GB',' chip1GB',' chip2GB' + do i=1,ntyp + do j=1,i + write (iout,'(2(a3,1x),1pe10.3,5(0pf10.3))') + & restyp(i),restyp(j),eps(i,j),sigma(i,j),chi(i,j),chi(j,i), + & chipp(i,j),chipp(j,i) + enddo + enddo + write (iout,'(/9a)') 'Residues',' alphasur1',' alphasur2', + & ' alphasur3',' alphasur4',' sigmap1',' sigmap2', + & ' chis1',' chis2' + do i=1,ntyp + do j=1,i + write (iout,'(2(a3,1x),8(0pf10.3))') + & restyp(i),restyp(j),(alphasur(k,i,j),k=1,4), + & sigmap1(i,j),sigmap2(j,i),chis(i,j),chis(j,i) + enddo + enddo + write (iout,'(/14a)') 'Residues',' nst ',' wst1', + & ' wst2',' wst3',' wst4',' dh11',' dh21', + & ' dh12',' dh22',' dt1',' dt2',' epsh1', + & ' sigh' + do i=1,ntyp + do j=1,i + write (iout,'(2(a3,1x),i3,4f8.3,6f7.2,f9.5,f7.2)') + & restyp(i),restyp(j),nstate(i,j),(wstate(k,i,j),k=1,4), + & ((dhead(l,k,i,j),l=1,2),k=1,2),dtail(1,i,j),dtail(2,i,j), + & epshead(i,j),sig0head(i,j) + enddo + enddo + write (iout,'(/12a)') 'Residues',' ch1',' ch2', + & ' rborn1',' rborn2',' wqdip1',' wqdip2', + & ' wquad' + do i=1,ntyp + do j=1,i + write (iout,'(2(a3,1x),2i4,5f10.3)') + & restyp(i),restyp(j),icharge(i),icharge(j), + & rborn(i,j),rborn(j,i),(wqdip(k,i,j),k=1,2),wquad(i,j) + enddo + enddo + write (iout,'(/12a)') 'Residues', + & ' alphpol1', + & ' alphpol2',' alphiso1',' alpiso2', + & ' alpiso3',' alpiso4',' sigiso1',' sigiso2', + & ' epsin' + do i=1,ntyp + do j=1,i + write (iout,'(2(a3,1x),11f10.3)') + & restyp(i),restyp(j),alphapol(i,j),alphapol(j,i), + & (alphiso(k,i,j),k=1,4),sigiso1(i,j),sigiso2(j,i), + & epsintab(i,j) + enddo + enddo + goto 70 + + 60 continue + close (isidep) +C----------------------------------------------------------------------- +C Calculate the "working" parameters of SC interactions. + + IF (ipot.LT.6) THEN + do i=1,ntyp + do j=i,ntyp + sigma(i,j)=dsqrt(sigma0(i)**2+sigma0(j)**2) + sigma(j,i)=sigma(i,j) + rs0(i,j)=dwa16*sigma(i,j) + rs0(j,i)=rs0(i,j) + enddo + enddo + END IF + + 70 continue + write (iout,*) "IPOT=",ipot + if (lprint) write (iout,'(/a/10x,7a/72(1h-))') + & 'Working parameters of the SC interactions:', + & ' a ',' b ',' augm ',' sigma ',' r0 ', + & ' chi1 ',' chi2 ' + do i=1,ntyp + do j=i,ntyp + epsij=eps(i,j) + if (ipot.eq.1 .or. ipot.eq.3 .or. ipot.eq.4 .or. ipot.eq.6 ) THEN + rrij=sigma(i,j) + else + rrij=rr0(i)+rr0(j) + endif + r0(i,j)=rrij + r0(j,i)=rrij + rrij=rrij**expon + epsij=eps(i,j) + sigeps=dsign(1.0D0,epsij) + epsij=dabs(epsij) + aa(i,j)=epsij*rrij*rrij + bb(i,j)=-sigeps*epsij*rrij + aa(j,i)=aa(i,j) + bb(j,i)=bb(i,j) + IF ((ipot.gt.2).AND.(ipot.LT.6)) THEN + sigt1sq=sigma0(i)**2 + sigt2sq=sigma0(j)**2 + sigii1=sigii(i) + sigii2=sigii(j) + ratsig1=sigt2sq/sigt1sq + ratsig2=1.0D0/ratsig1 + chi(i,j)=(sigii1-1.0D0)/(sigii1+ratsig1) + if (j.gt.i) chi(j,i)=(sigii2-1.0D0)/(sigii2+ratsig2) + rsum_max=dsqrt(sigii1*sigt1sq+sigii2*sigt2sq) + else + rsum_max=sigma(i,j) + endif +c if (ipot.eq.1 .or. ipot.eq.3 .or. ipot.eq.4) then + sigmaii(i,j)=rsum_max + sigmaii(j,i)=rsum_max +c else +c sigmaii(i,j)=r0(i,j) +c sigmaii(j,i)=r0(i,j) +c endif +cd write (iout,*) i,j,r0(i,j),sigma(i,j),rsum_max + if ((ipot.eq.2 .or. ipot.eq.5) .and. r0(i,j).gt.rsum_max) then + r_augm=sigma(i,j)*(rrij-sigma(i,j))/rrij + augm(i,j)=epsij*r_augm**(2*expon) +c augm(i,j)=0.5D0**(2*expon)*aa(i,j) + augm(j,i)=augm(i,j) + else + augm(i,j)=0.0D0 + augm(j,i)=0.0D0 + endif + if (lprint) then + if (ipot.lt.6) then + write (iout,'(2(a3,2x),3(1pe10.3),5(0pf8.3))') + & restyp(i),restyp(j),aa(i,j),bb(i,j),augm(i,j), + & sigma(i,j),r0(i,j),chi(i,j),chi(j,i) + else + write (iout,'(2(a3,2x),3(1pe10.3),5(0pf8.3),2i3,10f8.4, + & i3,40f10.4)') + & restyp(i),restyp(j),aa(i,j),bb(i,j),augm(i,j), + & sigma(i,j),r0(i,j),chi(i,j),chi(j,i), + & icharge(i),icharge(j),chipp(i,j),chipp(j,i), + & (alphasur(k,i,j),k=1,4),sigmap1(i,j),sigmap2(j,i), + & chis(i,j),chis(j,i), + & nstate(i,j),(wstate(k,i,j),k=1,4), + & ((dhead(l,k,i,j),l=1,2),k=1,2),dtail(1,i,j),dtail(2,i,j), + & epshead(i,j),sig0head(i,j), + & rborn(i,j),(wqdip(k,i,j),k=1,2),wquad(i,j), + & alphapol(i,j),alphapol(j,i), + & (alphiso(k,i,j),k=1,4),sigiso1(i,j),sigiso2(i,j) + + endif + endif + enddo + enddo + +C +C Define the SC-p interaction constants +C +#ifdef OLDSCP + do i=1,20 +C "Soft" SC-p repulsion (causes helices to be too flat, but facilitates +C helix formation) +c aad(i,1)=0.3D0*4.0D0**12 +C Following line for constants currently implemented +C "Hard" SC-p repulsion (gives correct turn spacing in helices) + aad(i,1)=1.5D0*4.0D0**12 +c aad(i,1)=0.17D0*5.6D0**12 + aad(i,2)=aad(i,1) +C "Soft" SC-p repulsion + bad(i,1)=0.0D0 +C Following line for constants currently implemented +c aad(i,1)=0.3D0*4.0D0**6 +C "Hard" SC-p repulsion + bad(i,1)=3.0D0*4.0D0**6 +c bad(i,1)=-2.0D0*0.17D0*5.6D0**6 + bad(i,2)=bad(i,1) +c aad(i,1)=0.0D0 +c aad(i,2)=0.0D0 +c bad(i,1)=1228.8D0 +c bad(i,2)=1228.8D0 + enddo +#else +C +C 8/9/01 Read the SC-p interaction constants from file +C + do i=1,ntyp + read (iscpp,*,end=118,err=118) (eps_scp(i,j),rscp(i,j),j=1,2) + enddo + do i=1,ntyp + aad(i,1)=dabs(eps_scp(i,1))*rscp(i,1)**12 + aad(i,2)=dabs(eps_scp(i,2))*rscp(i,2)**12 + bad(i,1)=-2*eps_scp(i,1)*rscp(i,1)**6 + bad(i,2)=-2*eps_scp(i,2)*rscp(i,2)**6 + enddo + + if (lprint) then + write (iout,*) "Parameters of SC-p interactions:" + do i=1,20 + write (iout,'(4f8.3,4e12.4)') eps_scp(i,1),rscp(i,1), + & eps_scp(i,2),rscp(i,2),aad(i,1),bad(i,1),aad(i,2),bad(i,2) + enddo + endif +#endif +C +C Define the constants of the disulfide bridge +C + ebr=-5.50D0 +c +c Old arbitrary potential - commented out. +c +c dbr= 4.20D0 +c fbr= 3.30D0 +c +c Constants of the disulfide-bond potential determined based on the RHF/6-31G** +c energy surface of diethyl disulfide. +c A. Liwo and U. Kozlowska, 11/24/03 +c + D0CM = 3.78d0 + AKCM = 15.1d0 + AKTH = 11.0d0 + AKCT = 12.0d0 + V1SS =-1.08d0 + V2SS = 7.61d0 + V3SS = 13.7d0 + + if (lprint) then + write (iout,'(/a)') "Disulfide bridge parameters:" + write (iout,'(a,f10.2)') 'S-S bridge energy: ',ebr + write (iout,'(2(a,f10.2))') 'd0cm:',d0cm,' akcm:',akcm + write (iout,'(2(a,f10.2))') 'akth:',akth,' akct:',akct + write (iout,'(3(a,f10.2))') 'v1ss:',v1ss,' v2ss:',v2ss, + & ' v3ss:',v3ss + endif + return + 110 write (iout,*) "Error reading bond energy parameters." + goto 999 + 111 write (iout,*) "Error reading bending energy parameters." + goto 999 + 112 write (iout,*) "Error reading rotamer energy parameters." + goto 999 + 113 write (iout,*) "Error reading torsional energy parameters." + goto 999 + 114 write (iout,*) "Error reading double torsional energy parameters." + goto 999 + 115 write (iout,*) + & "Error reading cumulant (multibody energy) parameters." + goto 999 + 116 write (iout,*) "Error reading electrostatic energy parameters." + goto 999 + 117 write (iout,*) "Error reading side chain interaction parameters." + goto 999 + 118 write (iout,*) "Error reading SCp interaction parameters." + goto 999 + 119 write (iout,*) "Error reading SCCOR parameters" + 999 continue +#ifdef MPI + call MPI_Finalize(Ierror) +#endif + stop + end diff --git a/source/wham/src-NEWSC-NEWCORR/pinorm.f b/source/wham/src-NEWSC-NEWCORR/pinorm.f new file mode 100644 index 0000000..91392bf --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/pinorm.f @@ -0,0 +1,17 @@ + double precision function pinorm(x) + implicit real*8 (a-h,o-z) +c +c this function takes an angle (in radians) and puts it in the range of +c -pi to +pi. +c + integer n + include 'COMMON.GEO' + n = x / dwapi + pinorm = x - n * dwapi + if ( pinorm .gt. pi ) then + pinorm = pinorm - dwapi + else if ( pinorm .lt. - pi ) then + pinorm = pinorm + dwapi + end if + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/printmat.f b/source/wham/src-NEWSC-NEWCORR/printmat.f new file mode 100644 index 0000000..be2b38f --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/printmat.f @@ -0,0 +1,16 @@ + subroutine printmat(ldim,m,n,iout,key,a) + character*3 key(n) + double precision a(ldim,n) + do 1 i=1,n,8 + nlim=min0(i+7,n) + write (iout,1000) (key(k),k=i,nlim) + write (iout,1020) + 1000 format (/5x,8(6x,a3)) + 1020 format (/80(1h-)/) + do 2 j=1,n + write (iout,1010) key(j),(a(j,k),k=i,nlim) + 2 continue + 1 continue + 1010 format (a3,2x,8(f9.4)) + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/proc_cont.f b/source/wham/src-NEWSC-NEWCORR/proc_cont.f new file mode 100644 index 0000000..9269496 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/proc_cont.f @@ -0,0 +1,156 @@ + subroutine proc_cont + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.COMPAR' + include 'COMMON.IOUNITS' + include 'COMMON.TIME1' + include 'COMMON.SBRIDGE' + include 'COMMON.CONTROL' + include 'COMMON.COMPAR' + include 'COMMON.CHAIN' + include 'COMMON.HEADER' + include 'COMMON.CONTACTS1' + include 'COMMON.PEPTCONT' + include 'COMMON.GEO' + write (iout,*) "proc_cont: nlevel",nlevel + if (nlevel.lt.0) then + write (iout,*) "call define_fragments" + call define_fragments + else + write (iout,*) "call secondary2" + call secondary2(.true.,.false.,ncont_pept_ref,icont_pept_ref, + & isec_ref) + endif + write (iout,'(80(1h=))') + write (iout,*) "Electrostatic contacts" + call contacts_between_fragments(.true.,0,ncont_pept_ref, + & icont_pept_ref,ncont_frag_ref(1),icont_frag_ref(1,1,1)) + write (iout,'(80(1h=))') + write (iout,*) "Side chain contacts" + call contacts_between_fragments(.true.,0,ncont_ref, + & icont_ref,nsccont_frag_ref(1),isccont_frag_ref(1,1,1)) + if (nlevel.lt.0) then + do i=1,nfrag(1) + ind=icant(i,i) + len_cut=1000 + if (istruct(i).le.1) then + len_cut=max0(len_frag(i,1)*4/5,3) + else if (istruct(i).eq.2 .or. istruct(i).eq.4) then + len_cut=max0(len_frag(i,1)*2/5,3) + endif + write (iout,*) "i",i," istruct",istruct(i)," ncont_frag", + & ncont_frag_ref(ind)," len_cut",len_cut, + & " icont_single",icont_single," iloc_single",iloc_single + iloc(i)=iloc_single + if (iloc(i).gt.0) write (iout,*) + & "Local structure used to compare structure of fragment",i, + & " to native." + if (istruct(i).ne.3 .and. istruct(i).ne.0 + & .and. icont_single.gt.0 .and. + & ncont_frag_ref(ind).ge.len_cut) then + write (iout,*) "Electrostatic contacts used to compare", + & " structure of fragment",i," to native." + ielecont(i,1)=1 + isccont(i,1)=0 + else if (icont_single.gt.0 .and. nsccont_frag_ref(ind) + & .ge.len_cut) then + write (iout,*) "Side chain contacts used to compare", + & " structure of fragment",i," to native." + isccont(i,1)=1 + ielecont(i,1)=0 + else + write (iout,*) "Contacts not used to compare", + & " structure of fragment",i," to native." + ielecont(i,1)=0 + isccont(i,1)=0 + nc_req_setf(i,1)=0 + endif + if (irms_single.gt.0 .or. isccont(i,1).eq.0 + & .and. ielecont(i,1).eq.0) then + write (iout,*) "RMSD used to compare", + & " structure of fragment",i," to native." + irms(i,1)=1 + else + write (iout,*) "RMSD not used to compare", + & " structure of fragment",i," to native." + irms(i,1)=0 + endif + enddo + endif + if (nlevel.lt.-1) then + call define_pairs + nlevel = -nlevel + if (nlevel.gt.3) nlevel=3 + if (nlevel.eq.3) then + nfrag(3)=1 + npiece(1,3)=nfrag(1) + do i=1,nfrag(1) + ipiece(i,1,3)=i + enddo + ielecont(1,3)=0 + isccont(1,3)=0 + irms(1,3)=1 + n_shift(1,1,3)=0 + n_shift(2,1,3)=0 + endif + else if (nlevel.eq.-1) then + nlevel=1 + endif + isnfrag(1)=0 + do i=1,nlevel + isnfrag(i+1)=isnfrag(i)+nfrag(i) + enddo + ndigit=3*nfrag(1) + do i=2,nlevel + ndigit=ndigit+2*nfrag(i) + enddo + write (iout,*) "ndigit",ndigit + if (.not.binary .and. ndigit.gt.30) then + write (iout,*) "Highest class too large; switching to", + & " binary representation." + binary=.true. + endif + write (iout,*) "isnfrag",(isnfrag(i),i=1,nlevel+1) + write(iout,*) "rmscut_base_up",rmscut_base_up, + & " rmscut_base_low",rmscut_base_low," rmsup_lim",rmsup_lim + do i=1,nlevel + do j=1,nfrag(i) + length_frag = 0 + if (i.eq.1) then + do k=1,npiece(j,i) + length_frag=length_frag+ifrag(2,k,j)-ifrag(1,k,j)+1 + enddo + else + do k=1,npiece(j,i) + length_frag=length_frag+len_frag(ipiece(k,j,i),1) + enddo + endif + len_frag(j,i)=length_frag + rmscutfrag(1,j,i)=rmscut_base_up*length_frag + rmscutfrag(2,j,i)=rmscut_base_low*length_frag + if (rmscutfrag(1,j,i).lt.rmsup_lim) + & rmscutfrag(1,j,i)=rmsup_lim + if (rmscutfrag(1,j,i).gt.rmsupup_lim) + & rmscutfrag(1,j,i)=rmsupup_lim + enddo + enddo + write (iout,*) "Level",1," number of fragments:",nfrag(1) + do j=1,nfrag(1) + write (iout,*) npiece(j,1),(ifrag(1,k,j),ifrag(2,k,j), + & k=1,npiece(j,1)),len_frag(j,1),rmscutfrag(1,j,1), + & rmscutfrag(2,j,1),n_shift(1,j,1),n_shift(2,j,1), + & ang_cut(j)*rad2deg,ang_cut1(j)*rad2deg,frac_min(j), + & nc_fragm(j,1),nc_req_setf(j,1),istruct(j) + enddo + do i=2,nlevel + write (iout,*) "Level",i," number of fragments:",nfrag(i) + do j=1,nfrag(i) + write (iout,*) npiece(j,i),(ipiece(k,j,i), + & k=1,npiece(j,i)),len_frag(j,i),rmscutfrag(1,j,i), + & rmscutfrag(2,j,i),n_shift(1,j,i),n_shift(2,j,i), + & nc_fragm(j,i),nc_req_setf(j,i) + enddo + enddo + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/proc_proc.c b/source/wham/src-NEWSC-NEWCORR/proc_proc.c new file mode 100644 index 0000000..01c6bba --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/proc_proc.c @@ -0,0 +1,124 @@ +#include +#include +#include + +#ifdef LINUX +#ifdef PGI +void proc_proc_(long int *f, int *i) +#else +void proc_proc__(long int *f, int *i) +#endif +#endif +#ifdef SGI +void proc_proc_(long int *f, int *i) +#endif +#ifdef WIN +void _stdcall PROC_PROC(long int *f, int *i) +#endif +#if defined(AIX) || defined(WINPGI) +void proc_proc(long int *f, int *i) +#endif + +{ +static long int NaNQ; +static long int NaNQm; + +if(*i==-1) + { + NaNQ=*f; + NaNQm=0xffffffff; + return; + } +*i=0; +if(*f==NaNQ) + *i=1; +if(*f==NaNQm) + *i=1; +} + + +#ifdef LINUX +void proc_conv__(char *buf, int *i, int n) +#endif +#ifdef SGI +void proc_conv_(char *buf, int *i, int n) +#endif +#if defined(AIX) || defined(WINPGI) +void proc_conv(char *buf, int *i, int n) +#endif +#ifdef WIN +void _stdcall PROC_CONV(char *buf, int *i, int n) +#endif +{ +int j; + +sscanf(buf,"%d",&j); +*i=j; +return; +} + +#ifdef LINUX +void proc_conv_r__(char *buf, int *i, int n) +#endif +#ifdef SGI +void proc_conv_r_(char *buf, int *i, int n) +#endif +#if defined(AIX) || defined(WINPGI) +void proc_conv_r(char *buf, int *i, int n) +#endif +#ifdef WIN +void _stdcall PROC_CONV_R(char *buf, int *i, int n) +#endif + +{ + +/* sprintf(buf,"%d",*i); */ + +return; +} + +#ifndef IMSL +#ifdef LINUX +void dsvrgp__(int *n, double *tab1, double *tab2, int *itab) +#endif +#ifdef SGI +void dsvrgp_(int *n, double *tab1, double *tab2, int *itab) +#endif +#if defined(AIX) || defined(WINPGI) +void dsvrgp(int *n, double *tab1, double *tab2, int *itab) +#endif +#ifdef WIN +void _stdcall DSVRGP(int *n, double *tab1, double *tab2, int *itab) +#endif +{ +double t; +int i,j,k; + +if(tab1 != tab2) + { + for(i=0; i<*n; i++) + tab2[i]=tab1[i]; + } +k=0; +while(k<*n-1) + { + j=k; + t=tab2[k]; + for(i=k+1; i<*n; i++) + if(t>tab2[i]) + { + j=i; + t=tab2[i]; + } + if(j!=k) + { + tab2[j]=tab2[k]; + tab2[k]=t; + i=itab[j]; + itab[j]=itab[k]; + itab[k]=i; + } + k++; + } +} +#endif diff --git a/source/wham/src-NEWSC-NEWCORR/promienie.f b/source/wham/src-NEWSC-NEWCORR/promienie.f new file mode 100644 index 0000000..12a2e80 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/promienie.f @@ -0,0 +1,46 @@ + subroutine promienie(*) + implicit none + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.CONTPAR' + include 'COMMON.LOCAL' + integer i,j + real*8 facont /1.569D0/ ! facont = (2/(1-sqrt(1-1/4)))**(1/6) + character*8 contfunc + character*8 contfuncid(5)/'GB','DIST','CEN','ODC','SIG'/ + character*8 ucase + call getenv("CONTFUNC",contfunc) + contfunc=ucase(contfunc) + do icomparfunc=1,5 + if (contfunc.eq.contfuncid(icomparfunc)) goto 10 + enddo + 10 continue + write (iout,*) "Sidechain contact function is ",contfunc, + & "icomparfunc",icomparfunc + do i=1,ntyp + do j=1,ntyp + if (icomparfunc.lt.3) then + read(isidep1,*) chi_comp(i,j),chip_comp(i,j),sig_comp(i,j), + & sc_cutoff(i,j) + else if (icomparfunc.lt.5) then + read(isidep1,*) sc_cutoff(i,j) + else if (icomparfunc.eq.5) then + sc_cutoff(i,j)=dsqrt(sigma0(i)**2+sigma0(j)**2)*facont + else + write (iout,*) "Error - Unknown contact function" + return1 + endif + enddo + enddo + close (isidep1) + do i=1,ntyp1 + if (i.eq.10 .or. i.eq.21) then + dsc_inv(i)=0.0d0 + else + dsc_inv(i)=1.0d0/dsc(i) + endif + enddo + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/qwolynes.f b/source/wham/src-NEWSC-NEWCORR/qwolynes.f new file mode 100644 index 0000000..97b5efb --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/qwolynes.f @@ -0,0 +1,186 @@ + double precision function qwolynes(ilevel,jfrag) + implicit none + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.COMPAR' + include 'COMMON.IOUNITS' + include 'COMMON.COMPAR' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + integer ilevel,jfrag + integer i,j,jl,k,l,il,kl,nl,np,ip,kp + integer nsep /3/ + double precision dist + double precision qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM + logical lprn /.false./ + double precision sigm,x + sigm(x)=0.25d0*x +c write (iout,*) "QWolyes: " jfrag",jfrag, +c & " ilevel",ilevel + qq = 0.0d0 + if (ilevel.eq.0) then + if (lprn) write (iout,*) "Q computed for whole molecule" + nl=0 + do il=nnt+nsep,nct + do jl=nnt,il-nsep + dij=0.0d0 + dijCM=0.0d0 + d0ij=0.0d0 + d0ijCM=0.0d0 + qqij=0.0d0 + qqijCM=0.0d0 + nl=nl+1 + d0ij=dsqrt((cref(1,jl)-cref(1,il))**2+ + & (cref(2,jl)-cref(2,il))**2+ + & (cref(3,jl)-cref(3,il))**2) + dij=dist(il,jl) + qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2) + if (itype(il).ne.10 .or. itype(jl).ne.10) then + nl=nl+1 + d0ijCM=dsqrt( + & (cref(1,jl+nres)-cref(1,il+nres))**2+ + & (cref(2,jl+nres)-cref(2,il+nres))**2+ + & (cref(3,jl+nres)-cref(3,il+nres))**2) + dijCM=dist(il+nres,jl+nres) + qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2) + endif + qq = qq+qqij+qqijCM + if (lprn) then + write (iout,*) "il",il," jl",jl, + & " itype",itype(il),itype(jl) + write (iout,*)"d0ij",d0ij," dij",dij," d0ijCM",d0ijCM, + & " dijCM",dijCM," qqij",qqij," qqijCM",qqijCM + endif + enddo + enddo + qq = qq/nl + if (lprn) write (iout,*) "nl",nl," qq",qq + else if (ilevel.eq.1) then + if (lprn) write (iout,*) "Level",ilevel," fragment",jfrag + nl=0 +c write (iout,*) "nlist_frag",nlist_frag(jfrag) + do i=2,nlist_frag(jfrag) + do j=1,i-1 + il=list_frag(i,jfrag) + jl=list_frag(j,jfrag) + if (iabs(il-jl).gt.nsep) then + dij=0.0d0 + dijCM=0.0d0 + d0ij=0.0d0 + d0ijCM=0.0d0 + qqij=0.0d0 + qqijCM=0.0d0 + nl=nl+1 + d0ij=dsqrt((cref(1,jl)-cref(1,il))**2+ + & (cref(2,jl)-cref(2,il))**2+ + & (cref(3,jl)-cref(3,il))**2) + dij=dist(il,jl) + qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2) + if (itype(il).ne.10 .or. itype(jl).ne.10) then + nl=nl+1 + d0ijCM=dsqrt( + & (cref(1,jl+nres)-cref(1,il+nres))**2+ + & (cref(2,jl+nres)-cref(2,il+nres))**2+ + & (cref(3,jl+nres)-cref(3,il+nres))**2) + dijCM=dist(il+nres,jl+nres) + qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2) + endif + qq = qq+qqij+qqijCM + if (lprn) then + write (iout,*) "i",i," j",j," il",il," jl",jl, + & " itype",itype(il),itype(jl) + write (iout,*)"d0ij",d0ij," dij",dij," d0ijCM",d0ijCM, + & " dijCM",dijCM," qqij",qqij," qqijCM",qqijCM + endif + endif + enddo + enddo + qq = qq/nl + if (lprn) write (iout,*) "nl",nl," qq",qq + else if (ilevel.eq.2) then + np=npiece(jfrag,ilevel) + nl=0 + do i=2,np + ip=ipiece(i,jfrag,ilevel) + do j=1,nlist_frag(ip) + il=list_frag(j,ip) + do k=1,i-1 + kp=ipiece(k,jfrag,ilevel) + do l=1,nlist_frag(kp) + kl=list_frag(l,kp) + if (iabs(kl-il).gt.nsep) then + nl=nl+1 + dij=0.0d0 + dijCM=0.0d0 + d0ij=0.0d0 + d0ijCM=0.0d0 + qqij=0.0d0 + qqijCM=0.0d0 + d0ij=dsqrt((cref(1,kl)-cref(1,il))**2+ + & (cref(2,kl)-cref(2,il))**2+ + & (cref(3,kl)-cref(3,il))**2) + dij=dist(il,kl) + qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2) + if (itype(il).ne.10 .or. itype(kl).ne.10) then + nl=nl+1 + d0ijCM=dsqrt( + & (cref(1,kl+nres)-cref(1,il+nres))**2+ + & (cref(2,kl+nres)-cref(2,il+nres))**2+ + & (cref(3,kl+nres)-cref(3,il+nres))**2) + dijCM=dist(il+nres,kl+nres) + qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/ + & (sigm(d0ijCM)))**2) + endif + qq = qq+qqij+qqijCM + if (lprn) then + write (iout,*) "i",i," j",j," k",k," l",l," il",il, + & " kl",kl," itype",itype(il),itype(kl) + write (iout,*) " d0ij",d0ij," dij",dij," d0ijCM", + & d0ijCM," dijCM",dijCM," qqij",qqij," qqijCM",qqijCM + endif + endif + enddo ! l + enddo ! k + enddo ! j + enddo ! i + qq = qq/nl + if (lprn) write (iout,*) "nl",nl," qq",qq + else + write (iout,*)"Error: Q can be computed only for level 1 and 2." + endif + qwolynes=1.0d0-qq + return + end +c------------------------------------------------------------------------------- + subroutine fragment_list + implicit none + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.COMPAR' + include 'COMMON.IOUNITS' + include 'COMMON.COMPAR' + logical lprn /.true./ + integer i,ilevel,j,k,jfrag + do jfrag=1,nfrag(1) + nlist_frag(jfrag)=0 + do i=1,npiece(jfrag,1) + if (lprn) write (iout,*) "jfrag=",jfrag, + & "i=",i," fragment",ifrag(1,i,jfrag), + & ifrag(2,i,jfrag) + do j=ifrag(1,i,jfrag),ifrag(2,i,jfrag) + do k=1,nlist_frag(jfrag) + if (list_frag(k,jfrag).eq.j) goto 10 + enddo + nlist_frag(jfrag)=nlist_frag(jfrag)+1 + list_frag(nlist_frag(jfrag),jfrag)=j + enddo + 10 continue + enddo + enddo + write (iout,*) "Fragment list" + do j=1,nfrag(1) + write (iout,*)"Fragment",j," list",(list_frag(k,j), + & k=1,nlist_frag(j)) + enddo + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/read_ref_str.F b/source/wham/src-NEWSC-NEWCORR/read_ref_str.F new file mode 100644 index 0000000..4b56181 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/read_ref_str.F @@ -0,0 +1,165 @@ + subroutine read_ref_structure(*) +C +C Read the reference structure from the PDB file or from a PDB file or in the form of the dihedral +C angles. +C + implicit none + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.COMPAR' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.LOCAL' + include 'COMMON.NAMES' + include 'COMMON.CHAIN' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + include 'COMMON.HEADER' + include 'COMMON.CONTROL' + include 'COMMON.CONTACTS1' + include 'COMMON.PEPTCONT' + include 'COMMON.TIME1' + include 'COMMON.COMPAR' + character*4 sequence(maxres) + integer rescode + double precision x(maxvar) + integer itype_pdb(maxres) + logical seq_comp + integer i,j,k,nres_pdb,iaux + double precision ddsc,dist + integer ilen + external ilen +C + nres0=nres + write (iout,*) "pdbref",pdbref + if (pdbref) then + read(inp,'(a)') pdbfile + write (iout,'(2a,1h.)') 'PDB data will be read from file ', + & pdbfile(:ilen(pdbfile)) + open(ipdbin,file=pdbfile,status='old',err=33) + goto 34 + 33 write (iout,'(a)') 'Error opening PDB file.' + return1 + 34 continue + do i=1,nres + itype_pdb(i)=itype(i) + enddo + call readpdb(.true.) + do i=1,nres + iaux=itype_pdb(i) + itype_pdb(i)=itype(i) + itype(i)=iaux + enddo + close (ipdbin) + nres_pdb=nres + nres=nres0 + nstart_seq=nnt + if (nsup.le.(nct-nnt+1)) then + do i=0,nct-nnt+1-nsup + if (seq_comp(itype(nnt+i),itype_pdb(nstart_sup), + & nsup)) then + do j=nnt+nsup-1,nnt,-1 + do k=1,3 + cref(k,nres+j+i)=cref(k,nres_pdb+j) + enddo + enddo + do j=nnt+nsup-1,nnt,-1 + do k=1,3 + cref(k,j+i)=cref(k,j) + enddo + phi_ref(j+i)=phi_ref(j) + theta_ref(j+i)=theta_ref(j) + alph_ref(j+i)=alph_ref(j) + omeg_ref(j+i)=omeg_ref(j) + enddo +#ifdef DEBUG + do j=nnt,nct + write (iout,'(i5,3f10.5,5x,3f10.5)') + & j,(cref(k,j),k=1,3),(cref(k,j+nres),k=1,3) + enddo +#endif + nstart_seq=nnt+i + nstart_sup=nnt+i + goto 111 + endif + enddo + write (iout,'(a)') + & 'Error - sequences to be superposed do not match.' + return1 + else + do i=0,nsup-(nct-nnt+1) + if (seq_comp(itype(nnt),itype_pdb(nstart_sup+i), + & nct-nnt+1)) + & then + nstart_sup=nstart_sup+i + nsup=nct-nnt+1 + goto 111 + endif + enddo + write (iout,'(a)') + & 'Error - sequences to be superposed do not match.' + endif + 111 continue + write (iout,'(a,i5)') + & 'Experimental structure begins at residue',nstart_seq + else + call read_angles(inp,*38) + goto 39 + 38 write (iout,'(a)') 'Error reading reference structure.' + return1 + 39 call chainbuild + nstart_sup=nnt + nstart_seq=nnt + nsup=nct-nnt+1 + do i=1,2*nres + do j=1,3 + cref(j,i)=c(j,i) + enddo + enddo + endif + nend_sup=nstart_sup+nsup-1 + do i=1,2*nres + do j=1,3 + c(j,i)=cref(j,i) + enddo + enddo + do i=1,nres + do j=1,3 + dc(j,nres+i)=cref(j,nres+i)-cref(j,i) + enddo + if (itype(i).ne.10) then + ddsc = dist(i,nres+i) + do j=1,3 + dc_norm(j,nres+i)=dc(j,nres+i)/ddsc + enddo + else + do j=1,3 + dc_norm(j,nres+i)=0.0d0 + enddo + endif +c write (iout,*) "i",i," dc_norm",(dc_norm(k,nres+i),k=1,3), +c " norm",dc_norm(1,nres+i)**2+dc_norm(2,nres+i)**2+ +c dc_norm(3,nres+i)**2 + do j=1,3 + dc(j,i)=c(j,i+1)-c(j,i) + enddo + ddsc = dist(i,i+1) + do j=1,3 + dc_norm(j,i)=dc(j,i)/ddsc + enddo + enddo +c print *,"Calling contact" + call contact(.true.,ncont_ref,icont_ref(1,1), + & nstart_sup,nend_sup) +c print *,"Calling elecont" + call elecont(.true.,ncont_pept_ref, + & icont_pept_ref(1,1), + & nstart_sup,nend_sup) + write (iout,'(a,i3,a,i3,a,i3,a)') + & 'Number of residues to be superposed:',nsup, + & ' (from residue',nstart_sup,' to residue', + & nend_sup,').' + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/readpdb.f b/source/wham/src-NEWSC-NEWCORR/readpdb.f new file mode 100644 index 0000000..0b82476 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/readpdb.f @@ -0,0 +1,219 @@ + subroutine readpdb +C Read the PDB file and convert the peptide geometry into virtual-chain +C geometry. + implicit none + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.CONTROL' + include 'COMMON.LOCAL' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.NAMES' + character*3 seq,atom,res + character*80 card + double precision sccor(3,20) + integer i,j,iii,ibeg,ishift,ishift1,ity,ires,ires_old + double precision dcj + integer rescode + ibeg=1 + ishift1=0 + do i=1,10000 + read (ipdbin,'(a80)',end=10) card + if (card(:3).eq.'END' .or. card(:3).eq.'TER') goto 10 +C Fish out the ATOM cards. + if (index(card(1:4),'ATOM').gt.0) then + read (card(14:16),'(a3)') atom + if (atom.eq.'CA' .or. atom.eq.'CH3') then +C Calculate the CM of the preceding residue. + if (ibeg.eq.0) call sccenter(ires,iii,sccor) +C Start new residue. + ires_old=ires+ishift-ishift1 + read (card(23:26),*) ires +c print *,"ires_old",ires_old," ires",ires + if (card(27:27).eq."A" .or. card(27:27).eq."B") then +c ishift1=ishift1+1 + endif + read (card(18:20),'(a3)') res + if (ibeg.eq.1) then + ishift=ires-1 + if (res.ne.'GLY' .and. res.ne. 'ACE') then + ishift=ishift-1 + itype(1)=21 + endif + ibeg=0 + else + ishift=ishift+ires-ires_old-1 + endif + ires=ires-ishift+ishift1 + if (res.eq.'ACE') then + ity=10 + else + itype(ires)=rescode(ires,res,0) + endif + read(card(31:54),'(3f8.3)') (c(j,ires),j=1,3) + write (iout,'(2i3,2x,a,3f8.3)') + & ires,itype(ires),res,(c(j,ires),j=1,3) + iii=1 + do j=1,3 + sccor(j,iii)=c(j,ires) + enddo +c write (*,*) card(23:27),ires,itype(ires) + else if (atom.ne.'O '.and.atom(1:1).ne.'H' .and. + & atom.ne.'N ' .and. atom.ne.'C ') then + iii=iii+1 + read(card(31:54),'(3f8.3)') (sccor(j,iii),j=1,3) + endif + endif + enddo + 10 write (iout,'(a,i5)') ' Nres: ',ires +C Calculate the CM of the last side chain. + call sccenter(ires,iii,sccor) + nres=ires + nsup=nres + nstart_sup=1 + if (itype(nres).ne.10) then + nres=nres+1 + itype(nres)=21 + do j=1,3 + dcj=c(j,nres-2)-c(j,nres-3) + c(j,nres)=c(j,nres-1)+dcj + c(j,2*nres)=c(j,nres) + enddo + endif + do i=2,nres-1 + do j=1,3 + c(j,i+nres)=dc(j,i) + enddo + enddo + do j=1,3 + c(j,nres+1)=c(j,1) + c(j,2*nres)=c(j,nres) + enddo + if (itype(1).eq.21) then + nsup=nsup-1 + nstart_sup=2 + do j=1,3 + dcj=c(j,4)-c(j,3) + c(j,1)=c(j,2)-dcj + c(j,nres+1)=c(j,1) + enddo + endif +C Copy the coordinates to reference coordinates + do i=1,2*nres + do j=1,3 + cref(j,i)=c(j,i) + enddo + enddo +C Calculate internal coordinates. + do ires=1,nres + write (iout,'(2i3,2x,a,3f8.3,5x,3f8.3)') + & ires,itype(ires),restyp(itype(ires)),(c(j,ires),j=1,3), + & (c(j,ires+nres),j=1,3) + enddo + call flush(iout) + call int_from_cart(.true.,.true.) + do i=1,nres + phi_ref(i)=phi(i) + theta_ref(i)=theta(i) + alph_ref(i)=alph(i) + omeg_ref(i)=omeg(i) + enddo + ishift_pdb=ishift + return + end +c--------------------------------------------------------------------------- + subroutine int_from_cart(lside,lprn) + implicit none + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.LOCAL' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.NAMES' + character*3 seq,atom,res + character*80 card + double precision sccor(3,20) + integer rescode + double precision dist,alpha,beta,di + integer i,j,iti + logical lside,lprn + if (lprn) then + write (iout,'(/a)') + & 'Internal coordinates calculated from crystal structure.' + if (lside) then + write (iout,'(8a)') ' Res ',' dvb',' Theta', + & ' Phi',' Dsc_id',' Dsc',' Alpha', + & ' Omega' + else + write (iout,'(4a)') ' Res ',' dvb',' Theta', + & ' Phi' + endif + endif + do i=2,nres + iti=itype(i) + write (iout,*) i,i-1,(c(j,i),j=1,3),(c(j,i-1),j=1,3),dist(i,i-1) + if (itype(i-1).ne.21 .and. itype(i).ne.21 .and. + & (dist(i,i-1).lt.2.0D0 .or. dist(i,i-1).gt.5.0D0)) then + write (iout,'(a,i4)') 'Bad Cartesians for residue',i + stop + endif + theta(i+1)=alpha(i-1,i,i+1) + if (i.gt.2) phi(i+1)=beta(i-2,i-1,i,i+1) + enddo + if (itype(1).eq.21) then + do j=1,3 + c(j,1)=c(j,2)+(c(j,3)-c(j,4)) + enddo + endif + if (itype(nres).eq.21) then + do j=1,3 + c(j,nres)=c(j,nres-1)+(c(j,nres-2)-c(j,nres-3)) + enddo + endif + if (lside) then + do i=2,nres-1 + do j=1,3 + c(j,maxres2)=0.5D0*(c(j,i-1)+c(j,i+1)) + enddo + iti=itype(i) + di=dist(i,nres+i) + if (iti.ne.10) then + alph(i)=alpha(nres+i,i,maxres2) + omeg(i)=beta(nres+i,i,maxres2,i+1) + endif + if (lprn) + & write (iout,'(a3,i4,7f10.3)') restyp(iti),i,dist(i,i-1), + & rad2deg*theta(i),rad2deg*phi(i),dsc(iti),di, + & rad2deg*alph(i),rad2deg*omeg(i) + enddo + else if (lprn) then + do i=2,nres + iti=itype(i) + write (iout,'(a3,i4,7f10.3)') restyp(iti),i,dist(i,i-1), + & rad2deg*theta(i),rad2deg*phi(i) + enddo + endif + return + end +c--------------------------------------------------------------------------- + subroutine sccenter(ires,nscat,sccor) + implicit none + include 'DIMENSIONS' + include 'COMMON.CHAIN' + integer ires,nscat,i,j + double precision sccor(3,20),sccmj + do j=1,3 + sccmj=0.0D0 + do i=1,nscat + sccmj=sccmj+sccor(j,i) + enddo + dc(j,ires)=sccmj/nscat + enddo + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/readrtns.F b/source/wham/src-NEWSC-NEWCORR/readrtns.F new file mode 100644 index 0000000..006c111 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/readrtns.F @@ -0,0 +1,779 @@ + subroutine read_general_data(*) + implicit none + include "DIMENSIONS" + include "DIMENSIONS.ZSCOPT" + include "DIMENSIONS.FREE" + include "COMMON.TORSION" + include "COMMON.INTERACT" + include "COMMON.IOUNITS" + include "COMMON.TIME1" + include "COMMON.PROT" + include "COMMON.PROTFILES" + include "COMMON.CHAIN" + include "COMMON.NAMES" + include "COMMON.FFIELD" + include "COMMON.ENEPS" + include "COMMON.WEIGHTS" + include "COMMON.FREE" + include "COMMON.CONTROL" + include "COMMON.ENERGIES" + character*800 controlcard + integer i,j,k,ii,n_ene_found + integer ind,itype1,itype2,itypf,itypsc,itypp + integer ilen + external ilen + character*16 ucase + character*16 key + external ucase + + call card_concat(controlcard,.true.) + call readi(controlcard,"N_ENE",n_ene,max_ene) + if (n_ene.gt.max_ene) then + write (iout,*) "Error: parameter out of range: N_ENE",n_ene, + & max_ene + return1 + endif + call readi(controlcard,"NPARMSET",nparmset,1) + separate_parset = index(controlcard,"SEPARATE_PARSET").gt.0 + call readi(controlcard,"IPARMPRINT",iparmprint,1) + write (iout,*) "PARMPRINT",iparmprint + if (nparmset.gt.max_parm) then + write (iout,*) "Error: parameter out of range: NPARMSET", + & nparmset, Max_Parm + return1 + endif + energy_dec=index(controlcard,"ENERGY_DEC").gt.0 + call readi(controlcard,"MAXIT",maxit,5000) + call reada(controlcard,"FIMIN",fimin,1.0d-3) + call readi(controlcard,"ENSEMBLES",ensembles,0) + hamil_rep=index(controlcard,"HAMIL_REP").gt.0 + write (iout,*) "Number of energy parameter sets",nparmset + call multreadi(controlcard,"ISAMPL",isampl,nparmset,1) + write (iout,*) "MaxSlice",MaxSlice + call readi(controlcard,"NSLICE",nslice,1) + call flush(iout) + if (nslice.gt.MaxSlice) then + write (iout,*) "Error: parameter out of range: NSLICE",nslice, + & MaxSlice + return1 + endif + write (iout,*) "Frequency of storing conformations", + & (isampl(i),i=1,nparmset) + write (iout,*) "Maxit",maxit," Fimin",fimin + call readi(controlcard,"NQ",nQ,1) + if (nQ.gt.MaxQ) then + write (iout,*) "Error: parameter out of range: NQ",nq, + & maxq + return1 + endif + indpdb=0 + if (index(controlcard,"CLASSIFY").gt.0) indpdb=1 + call reada(controlcard,"DELTA",delta,1.0d-2) + call readi(controlcard,"EINICHECK",einicheck,2) + call reada(controlcard,"DELTRMS",deltrms,5.0d-2) + call readi(controlcard,"NGRIDT",NGridT,400) + call reada(controlcard,"STARTGRIDT",StartGridT,200.0d0) + call reada(controlcard,"DELTA_T",Delta_T,1.0d0) + call reada(controlcard,"DELTRGY",deltrgy,5.0d-2) + call readi(controlcard,"RESCALE",rescale_mode,1) + check_conf=index(controlcard,"NO_CHECK_CONF").eq.0 + write (iout,*) "delta",delta + write (iout,*) "einicheck",einicheck + write (iout,*) "rescale_mode",rescale_mode + call flush(iout) + bxfile=index(controlcard,"BXFILE").gt.0 + cxfile=index(controlcard,"CXFILE").gt.0 + if (nslice .eq. 1 .and. .not.bxfile .and. .not.cxfile) + & bxfile=.true. + histfile=index(controlcard,"HISTFILE").gt.0 + histout=index(controlcard,"HISTOUT").gt.0 + entfile=index(controlcard,"ENTFILE").gt.0 + zscfile=index(controlcard,"ZSCFILE").gt.0 + with_dihed_constr = index(controlcard,"WITH_DIHED_CONSTR").gt.0 + call readi(controlcard,'CONSTR_DIST',constr_dist,0) + write (iout,*) "with_dihed_constr ",with_dihed_constr, + & " CONSTR_DIST",constr_dist + refstr = index(controlcard,'REFSTR').gt.0 + pdbref = index(controlcard,'PDBREF').gt.0 + call flush(iout) + return + end +c------------------------------------------------------------------------------ + subroutine read_efree(*) +C +C Read molecular data +C + implicit none + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.COMPAR' + include 'DIMENSIONS.FREE' + include 'COMMON.IOUNITS' + include 'COMMON.TIME1' + include 'COMMON.SBRIDGE' + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.HEADER' + include 'COMMON.GEO' + include 'COMMON.FREE' + character*320 controlcard,ucase + integer iparm,ib,i,j,npars + integer ilen + external ilen + + if (hamil_rep) then + npars=1 + else + npars=nParmSet + endif + + do iparm=1,npars + + call card_concat(controlcard,.true.) + call readi(controlcard,'NT',nT_h(iparm),1) + write (iout,*) "iparm",iparm," nt",nT_h(iparm) + call flush(iout) + if (nT_h(iparm).gt.MaxT_h) then + write (iout,*) "Error: parameter out of range: NT",nT_h(iparm), + & MaxT_h + return1 + endif + replica(iparm)=index(controlcard,"REPLICA").gt.0 + umbrella(iparm)=index(controlcard,"UMBRELLA").gt.0 + read_iset(iparm)=index(controlcard,"READ_ISET").gt.0 + write (iout,*) "nQ",nQ," nT",nT_h(iparm)," replica ", + & replica(iparm)," umbrella ",umbrella(iparm), + & " read_iset",read_iset(iparm) + call flush(iout) + do ib=1,nT_h(iparm) + call card_concat(controlcard,.true.) + call readi(controlcard,'NR',nR(ib,iparm),1) + if (umbrella(iparm)) then + nRR(ib,iparm)=1 + else + nRR(ib,iparm)=nR(ib,iparm) + endif + if (nR(ib,iparm).gt.MaxR) then + write (iout,*) "Error: parameter out of range: NR", + & nR(ib,iparm),MaxR + return1 + endif + call reada(controlcard,'TEMP',beta_h(ib,iparm),298.0d0) + beta_h(ib,iparm)=1.0d0/(beta_h(ib,iparm)*1.987D-3) + call multreada(controlcard,'FI',f(1,ib,iparm),nR(ib,iparm), + & 0.0d0) + do i=1,nR(ib,iparm) + call card_concat(controlcard,.true.) + call multreada(controlcard,'KH',KH(1,i,ib,iparm),nQ, + & 100.0d0) + call multreada(controlcard,'Q0',Q0(1,i,ib,iparm),nQ, + & 0.0d0) + enddo + enddo + do ib=1,nT_h(iparm) + write (iout,*) "ib",ib," beta_h", + & 1.0d0/(0.001987*beta_h(ib,iparm)) + write (iout,*) "nR",nR(ib,iparm) + write (iout,*) "fi",(f(i,ib,iparm),i=1,nR(ib,iparm)) + do i=1,nR(ib,iparm) + write (iout,*) "i",i," Kh",(Kh(j,i,ib,iparm),j=1,nQ), + & "q0",(q0(j,i,ib,iparm),j=1,nQ) + enddo + call flush(iout) + enddo + + enddo + + if (hamil_rep) then + + do iparm=2,nParmSet + nT_h(iparm)=nT_h(1) + do ib=1,nT_h(iparm) + nR(ib,iparm)=nR(ib,1) + if (umbrella(iparm)) then + nRR(ib,iparm)=1 + else + nRR(ib,iparm)=nR(ib,1) + endif + beta_h(ib,iparm)=beta_h(ib,1) + do i=1,nR(ib,iparm) + f(i,ib,iparm)=f(i,ib,1) + do j=1,nQ + KH(j,i,ib,iparm)=KH(j,i,ib,1) + Q0(j,i,ib,iparm)=Q0(j,i,ib,1) + enddo + enddo + replica(iparm)=replica(1) + umbrella(iparm)=umbrella(1) + read_iset(iparm)=read_iset(1) + enddo + enddo + + endif + + return + end +c----------------------------------------------------------------------------- + subroutine read_protein_data(*) + implicit none + include "DIMENSIONS" + include "DIMENSIONS.ZSCOPT" + include "DIMENSIONS.FREE" +#ifdef MPI + include "mpif.h" + integer IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE) + include "COMMON.MPI" +#endif + include "COMMON.CHAIN" + include "COMMON.IOUNITS" + include "COMMON.PROT" + include "COMMON.PROTFILES" + include "COMMON.NAMES" + include "COMMON.FREE" + include "COMMON.OBCINKA" + character*64 nazwa + character*16000 controlcard + integer i,ii,ib,iR,iparm,ilen,iroof,nthr,npars + external ilen,iroof + if (hamil_rep) then + npars=1 + else + npars=nparmset + endif + + do iparm=1,npars + +C Read names of files with conformation data. + if (replica(iparm)) then + nthr = 1 + else + nthr = nT_h(iparm) + endif + do ib=1,nthr + do ii=1,nRR(ib,iparm) + write (iout,*) "Parameter set",iparm," temperature",ib, + & " window",ii + call flush(iout) + call card_concat(controlcard,.true.) + write (iout,*) controlcard(:ilen(controlcard)) + call readi(controlcard,"NFILE_BIN",nfile_bin(ii,ib,iparm),0) + call readi(controlcard,"NFILE_ASC",nfile_asc(ii,ib,iparm),0) + call readi(controlcard,"NFILE_CX",nfile_cx(ii,ib,iparm),0) + call readi(controlcard,"REC_START",rec_start(ii,ib,iparm),1) + call readi(controlcard,"REC_END",rec_end(ii,ib,iparm), + & maxstr*isampl(iparm)+rec_start(ii,ib,iparm)-1) + call reada(controlcard,"TIME_START", + & time_start_collect(ii,ib,iparm),0.0d0) + call reada(controlcard,"TIME_END",time_end_collect(ii,ib,iparm), + & 1.0d10) + write (iout,*) "rec_start",rec_start(ii,ib,iparm), + & " rec_end",rec_end(ii,ib,iparm) + write (iout,*) "time_start",time_start_collect(ii,ib,iparm), + & " time_end",time_end_collect(ii,ib,iparm) + call flush(iout) + if (replica(iparm)) then + call readi(controlcard,"TOTRAJ",totraj(ii,iparm),1) + write (iout,*) "Number of trajectories",totraj(ii,iparm) + call flush(iout) + endif + if (nfile_bin(ii,ib,iparm).lt.2 + & .and. nfile_asc(ii,ib,iparm).eq.0 + & .and. nfile_cx(ii,ib,iparm).eq.0) then + write (iout,*) "Error - no action specified!" + return1 + endif + if (nfile_bin(ii,ib,iparm).gt.0) then + call card_concat(controlcard,.false.) + call split_string(controlcard,protfiles(1,1,ii,ib,iparm), + & maxfile_prot,nfile_bin(ii,ib,iparm)) +#ifdef DEBUG + write(iout,*)"nfile_bin",nfile_bin(ii,ib,iparm) + write(iout,*) (protfiles(i,1,ii,ib,iparm), + & i=1,nfile_bin(ii,ib,iparm)) +#endif + endif + if (nfile_asc(ii,ib,iparm).gt.0) then + call card_concat(controlcard,.false.) + call split_string(controlcard,protfiles(1,2,ii,ib,iparm), + & maxfile_prot,nfile_asc(ii,ib,iparm)) +#ifdef DEBUG + write(iout,*) "nfile_asc(ii,ib,iparm)",nfile_asc(ii,ib,iparm) + write(iout,*) (protfiles(i,2,ii,ib,iparm), + & i=1,nfile_asc(ii,ib,iparm)) +#endif + else if (nfile_cx(ii,ib,iparm).gt.0) then + call card_concat(controlcard,.false.) + call split_string(controlcard,protfiles(1,2,ii,ib,iparm), + & maxfile_prot,nfile_cx(ii,ib,iparm)) +#ifdef DEBUG + write(iout,*) "nfile_cx(ii,ib,iparm)",nfile_cx(ii,ib,iparm) + write(iout,*) (protfiles(i,2,ii,ib,iparm), + & i=1,nfile_cx(ii,ib,iparm)) +#endif + endif + call flush(iout) + enddo + enddo + + enddo + + return + end +c------------------------------------------------------------------------------- + subroutine opentmp(islice,iunit,bprotfile_temp) + implicit none + include "DIMENSIONS" + include "DIMENSIONS.ZSCOPT" + include "DIMENSIONS.FREE" +#ifdef MPI + include "mpif.h" + integer IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE) + include "COMMON.MPI" +#endif + include "COMMON.IOUNITS" + include "COMMON.PROTFILES" + include "COMMON.PROT" + include "COMMON.FREE" + character*64 bprotfile_temp + character*3 liczba,liczba2 + character*2 liczba1 + integer iunit,islice + integer ilen,iroof + external ilen,iroof + logical lerr + + write (liczba1,'(bz,i2.2)') islice + write (liczba,'(bz,i3.3)') me +#ifdef MPI +c write (iout,*) "separate_parset ",separate_parset, +c & " myparm",myparm + if (separate_parset) then + write (liczba2,'(bz,i3.3)') myparm + bprotfile_temp = scratchdir(:ilen(scratchdir))//"/"// + & prefix(:ilen(prefix))//liczba//"_"//liczba2//".xbin.tmp"//liczba1 + open (iunit,file=bprotfile_temp,status="unknown", + & form="unformatted",access="direct",recl=lenrec) + else + bprotfile_temp = scratchdir(:ilen(scratchdir))//"/"// + & prefix(:ilen(prefix))//liczba//".xbin.tmp"//liczba1 + open (iunit,file=bprotfile_temp,status="unknown", + & form="unformatted",access="direct",recl=lenrec) + endif +#else + bprotfile_temp = scratchdir(:ilen(scratchdir))// + & "/"//prefix(:ilen(prefix))//".xbin.tmp"//liczba1 + open (iunit,file=bprotfile_temp,status="unknown", + & form="unformatted",access="direct",recl=lenrec) +#endif +c write (iout,*) "OpenTmp iunit",iunit," bprotfile_temp", +c & bprotfile_temp +c call flush(iout) + return + end +c------------------------------------------------------------------------------- + subroutine read_database(*) + implicit none + include "DIMENSIONS" + include "DIMENSIONS.ZSCOPT" + include "DIMENSIONS.FREE" +#ifdef MPI + include "mpif.h" + integer IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE) + include "COMMON.MPI" +#endif + include "COMMON.CHAIN" + include "COMMON.IOUNITS" + include "COMMON.PROTFILES" + include "COMMON.NAMES" + include "COMMON.VAR" + include "COMMON.GEO" + include "COMMON.ENEPS" + include "COMMON.PROT" + include "COMMON.INTERACT" + include "COMMON.FREE" + include "COMMON.SBRIDGE" + include "COMMON.OBCINKA" + real*4 csingle(3,maxres2) + character*64 nazwa,bprotfile_temp + character*3 liczba + character*2 liczba1 + integer i,j,ii,jj(maxslice),k,kk(maxslice),l, + & ll(maxslice),mm(maxslice),if + integer nrec,nlines,iscor,iunit,islice + double precision energ + integer ilen,iroof + external ilen,iroof + double precision rmsdev,energia(0:max_ene),efree,eini,temp + double precision prop(maxQ) + integer ntot_all(maxslice,0:maxprocs-1) + integer iparm,ib,iib,ir,nprop,nthr,npars + double precision etot,time + integer ixdrf,iret + logical lerr,linit + + lenrec1=12*(nres+nct-nnt+1)+4*(2*nss+2)+24 + lenrec2=12*(nres+nct-nnt+1)+4*(2*nss+2)+24+8*nQ + lenrec=lenrec2+8 + write (iout,*) "lenrec",lenrec," lenrec1",lenrec1, + & " lenrec2",lenrec2 + + do i=1,nQ + prop(i)=0.0d0 + enddo + do islice=1,nslice + ll(islice)=0 + mm(islice)=0 + enddo + write (iout,*) "nparmset",nparmset + if (hamil_rep) then + npars=1 + else + npars=nparmset + endif + do iparm=1,npars + + if (replica(iparm)) then + nthr = 1 + else + nthr = nT_h(iparm) + endif + + do ib=1,nthr + do iR=1,nRR(ib,iparm) + + write (iout,*) "iparm",iparm," ib",ib," iR",iR," nQ",nQ + do islice=1,nslice + jj(islice)=0 + kk(islice)=0 + enddo + + IF (NFILE_BIN(iR,ib,iparm).GT.0) THEN +c Read conformations from binary DA files (one per batch) and write them to +c a binary DA scratchfile. + write (liczba,'(bz,i3.3)') me + do if=1,nfile_bin(iR,ib,iparm) + nazwa=protfiles(if,1,iR,ib,iparm) + & (:ilen(protfiles(if,1,iR,ib,iparm)))//".bx" + open (ientin,file=nazwa,status="old",form="unformatted", + & access="direct",recl=lenrec2,err=1111) + ii=0 + do islice=1,nslice + call opentmp(islice,ientout,bprotfile_temp) + call bxread(nazwa,ii,jj(islice),kk(islice),ll(islice), + & mm(islice),iR,ib,iparm) + close(ientout) + enddo + close(ientin) + enddo + ENDIF ! NFILE_BIN>0 +c + IF (NFILE_ASC(iR,ib,iparm).GT.0) THEN +c Read conformations from multiple ASCII int files and write them to a binary +c DA scratchfile. + do if=1,nfile_asc(iR,ib,iparm) + nazwa=protfiles(if,2,iR,ib,iparm) + & (:ilen(protfiles(if,2,iR,ib,iparm)))//".x" + open(unit=ientin,file=nazwa,status='old',err=1111) + write(iout,*) "reading ",nazwa(:ilen(nazwa)) + ii=0 + call xread(nazwa,ii,jj,kk,ll,mm,iR,ib,iparm) + enddo ! if + ENDIF + IF (NFILE_CX(iR,ib,iparm).gt.0) THEN +c Read conformations from cx files and write them to a binary +c DA scratchfile. + do if=1,nfile_cx(iR,ib,iparm) + nazwa=protfiles(if,2,iR,ib,iparm) + & (:ilen(protfiles(if,2,iR,ib,iparm)))//".cx" + write(iout,*) "reading ",nazwa(:ilen(nazwa)) + ii=0 + print *,"Calling cxread" + call cxread(nazwa,ii,jj,kk,ll,mm,iR,ib,iparm, + & *1111) + close(ientout) + write (iout,*) "exit cxread" + call flush(iout) + enddo + ENDIF + + do islice=1,nslice + stot(islice)=stot(islice)+jj(islice) + enddo + + enddo + enddo + write (iout,*) "IPARM",iparm + enddo + + if (nslice.eq.1) then +#ifdef MPI + write (liczba,'(bz,i3.3)') me + bprotfile_temp = scratchdir(:ilen(scratchdir))//"/"// + & prefix(:ilen(prefix))//liczba//".xbin.tmp" +#else + bprotfile_temp = scratchdir(:ilen(scratchdir))// + & "/"//prefix(:ilen(prefix))//".xbin.tmp" +#endif + write(iout,*) mm(1)," conformations read",ll(1), + & " conformations written to ", + & bprotfile_temp(:ilen(bprotfile_temp)) + else + do islice=1,nslice + write (liczba1,'(bz,i2.2)') islice +#ifdef MPI + write (liczba,'(bz,i3.3)') me + bprotfile_temp = scratchdir(:ilen(scratchdir))//"/"// + & prefix(:ilen(prefix))//liczba//".xbin.tmp"//liczba1 +#else + bprotfile_temp = scratchdir(:ilen(scratchdir))// + & "/"//prefix(:ilen(prefix))//".xbin.tmp"//liczba1 +#endif + write(iout,*) mm(islice)," conformations read",ll(islice), + & " conformations written to ", + & bprotfile_temp(:ilen(bprotfile_temp)) + enddo + endif + +#ifdef MPI +c Check if everyone has the same number of conformations + call MPI_Allgather(stot(1),maxslice,MPI_INTEGER, + & ntot_all(1,0),maxslice,MPI_INTEGER,MPI_Comm_World,IERROR) + lerr=.false. + do i=0,nprocs-1 + if (i.ne.me) then + do islice=1,nslice + if (stot(islice).ne.ntot_all(islice,i)) then + write (iout,*) "Number of conformations at processor",i, + & " differs from that at processor",me, + & stot(islice),ntot_all(islice,i)," slice",islice + lerr = .true. + endif + enddo + endif + enddo + if (lerr) then + write (iout,*) + write (iout,*) "Numbers of conformations read by processors" + write (iout,*) + do i=0,nprocs-1 + write (iout,'(8i10)') i,(ntot_all(islice,i),islice=1,nslice) + enddo + write (iout,*) "Calculation terminated." + call flush(iout) + return1 + endif + do islice=1,nslice + ntot(islice)=stot(islice) + enddo + return +#endif + 1111 write(iout,*) "Error opening coordinate file ",nazwa(:ilen(nazwa)) + call flush(iout) + return1 + end +c------------------------------------------------------------------------------ + subroutine card_concat(card,to_upper) + implicit none + include 'DIMENSIONS.ZSCOPT' + include "COMMON.IOUNITS" + character*(*) card + character*80 karta,ucase + logical to_upper + integer ilen + external ilen + read (inp,'(a)') karta + if (to_upper) karta=ucase(karta) + card=' ' + do while (karta(80:80).eq.'&') + card=card(:ilen(card)+1)//karta(:79) + read (inp,'(a)') karta + if (to_upper) karta=ucase(karta) + enddo + card=card(:ilen(card)+1)//karta + return + end +c------------------------------------------------------------------------------ + subroutine readi(rekord,lancuch,wartosc,default) + implicit none + character*(*) rekord,lancuch + integer wartosc,default + integer ilen,iread + external ilen + iread=index(rekord,lancuch(:ilen(lancuch))//"=") + if (iread.eq.0) then + wartosc=default + return + endif + iread=iread+ilen(lancuch)+1 + read (rekord(iread:),*) wartosc + return + end +c---------------------------------------------------------------------------- + subroutine reada(rekord,lancuch,wartosc,default) + implicit none + character*(*) rekord,lancuch + character*80 aux + double precision wartosc,default + integer ilen,iread + external ilen + iread=index(rekord,lancuch(:ilen(lancuch))//"=") + if (iread.eq.0) then + wartosc=default + return + endif + iread=iread+ilen(lancuch)+1 + read (rekord(iread:),*) wartosc + return + end +c---------------------------------------------------------------------------- + subroutine multreadi(rekord,lancuch,tablica,dim,default) + implicit none + integer dim,i + integer tablica(dim),default + character*(*) rekord,lancuch + character*80 aux + integer ilen,iread + external ilen + do i=1,dim + tablica(i)=default + enddo + iread=index(rekord,lancuch(:ilen(lancuch))//"=") + if (iread.eq.0) return + iread=iread+ilen(lancuch)+1 + read (rekord(iread:),*,end=10,err=10) (tablica(i),i=1,dim) + 10 return + end +c---------------------------------------------------------------------------- + subroutine multreada(rekord,lancuch,tablica,dim,default) + implicit none + integer dim,i + double precision tablica(dim),default + character*(*) rekord,lancuch + character*80 aux + integer ilen,iread + external ilen + do i=1,dim + tablica(i)=default + enddo + iread=index(rekord,lancuch(:ilen(lancuch))//"=") + if (iread.eq.0) return + iread=iread+ilen(lancuch)+1 + read (rekord(iread:),*,end=10,err=10) (tablica(i),i=1,dim) + 10 return + end +c---------------------------------------------------------------------------- + subroutine reads(rekord,lancuch,wartosc,default) + implicit none + character*(*) rekord,lancuch,wartosc,default + character*80 aux + integer ilen,lenlan,lenrec,iread,ireade + external ilen + logical iblnk + external iblnk + lenlan=ilen(lancuch) + lenrec=ilen(rekord) + iread=index(rekord,lancuch(:lenlan)//"=") +c print *,"rekord",rekord," lancuch",lancuch +c print *,"iread",iread," lenlan",lenlan," lenrec",lenrec + if (iread.eq.0) then + wartosc=default + return + endif + iread=iread+lenlan+1 +c print *,"iread",iread +c print *,"|",rekord(iread:iread),"|",iblnk(rekord(iread:iread)) + do while (iread.le.lenrec .and. iblnk(rekord(iread:iread))) + iread=iread+1 +c print *,"|",rekord(iread:iread),"|",iblnk(rekord(iread:iread)) + enddo +c print *,"iread",iread + if (iread.gt.lenrec) then + wartosc=default + return + endif + ireade=iread+1 +c print *,"ireade",ireade + do while (ireade.lt.lenrec .and. + & .not.iblnk(rekord(ireade:ireade))) + ireade=ireade+1 + enddo + wartosc=rekord(iread:ireade) + return + end +c---------------------------------------------------------------------------- + subroutine multreads(rekord,lancuch,tablica,dim,default) + implicit none + integer dim,i + character*(*) rekord,lancuch,tablica(dim),default + character*80 aux + integer ilen,lenlan,lenrec,iread,ireade + external ilen + logical iblnk + external iblnk + do i=1,dim + tablica(i)=default + enddo + lenlan=ilen(lancuch) + lenrec=ilen(rekord) + iread=index(rekord,lancuch(:lenlan)//"=") +c print *,"rekord",rekord," lancuch",lancuch +c print *,"iread",iread," lenlan",lenlan," lenrec",lenrec + if (iread.eq.0) return + iread=iread+lenlan+1 + do i=1,dim +c print *,"iread",iread +c print *,"|",rekord(iread:iread),"|",iblnk(rekord(iread:iread)) + do while (iread.le.lenrec .and. iblnk(rekord(iread:iread))) + iread=iread+1 +c print *,"|",rekord(iread:iread),"|",iblnk(rekord(iread:iread)) + enddo +c print *,"iread",iread + if (iread.gt.lenrec) return + ireade=iread+1 +c print *,"ireade",ireade + do while (ireade.lt.lenrec .and. + & .not.iblnk(rekord(ireade:ireade))) + ireade=ireade+1 + enddo + tablica(i)=rekord(iread:ireade) + iread=ireade+1 + enddo + end +c---------------------------------------------------------------------------- + subroutine split_string(rekord,tablica,dim,nsub) + implicit none + integer dim,nsub,i,ii,ll,kk + character*(*) tablica(dim) + character*(*) rekord + integer ilen + external ilen + do i=1,dim + tablica(i)=" " + enddo + ii=1 + ll = ilen(rekord) + nsub=0 + do i=1,dim +C Find the start of term name + kk = 0 + do while (ii.le.ll .and. rekord(ii:ii).eq." ") + ii = ii+1 + enddo +C Parse the name into TABLICA(i) until blank found + do while (ii.le.ll .and. rekord(ii:ii).ne." ") + kk = kk+1 + tablica(i)(kk:kk)=rekord(ii:ii) + ii = ii+1 + enddo + if (kk.gt.0) nsub=nsub+1 + if (ii.gt.ll) return + enddo + return + end +c-------------------------------------------------------------------------------- + integer function iroof(n,m) + ii = n/m + if (ii*m .lt. n) ii=ii+1 + iroof = ii + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/readrtns.F.org b/source/wham/src-NEWSC-NEWCORR/readrtns.F.org new file mode 100644 index 0000000..1fa6e46 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/readrtns.F.org @@ -0,0 +1,691 @@ + subroutine read_general_data(*) + implicit none + include "DIMENSIONS" + include "DIMENSIONS.ZSCOPT" + include "DIMENSIONS.FREE" + include "COMMON.TORSION" + include "COMMON.INTERACT" + include "COMMON.IOUNITS" + include "COMMON.TIME1" + include "COMMON.PROT" + include "COMMON.PROTFILES" + include "COMMON.CHAIN" + include "COMMON.NAMES" + include "COMMON.FFIELD" + include "COMMON.ENEPS" + include "COMMON.WEIGHTS" + include "COMMON.FREE" + include "COMMON.CONTROL" + include "COMMON.ENERGIES" + character*800 controlcard + integer i,j,k,ii,n_ene_found + integer ind,itype1,itype2,itypf,itypsc,itypp + integer ilen + external ilen + character*16 ucase + character*16 key + external ucase + + call card_concat(controlcard,.true.) + call readi(controlcard,"N_ENE",n_ene,max_ene) + if (n_ene.gt.max_ene) then + write (iout,*) "Error: parameter out of range: N_ENE",n_ene, + & max_ene + return1 + endif + call readi(controlcard,"NPARMSET",nparmset,1) + if (nparmset.gt.max_parm) then + write (iout,*) "Error: parameter out of range: NPARMSET", + & nparmset, Max_Parm + return1 + endif + call readi(controlcard,"MAXIT",maxit,5000) + call reada(controlcard,"FIMIN",fimin,1.0d-3) + call readi(controlcard,"ENSEMBLES",ensembles,0) + write (iout,*) "Number of energy parameter sets",nparmset + call multreadi(controlcard,"ISAMPL",isampl,nparmset,1) + write (iout,*) "MaxSlice",MaxSlice + call readi(controlcard,"NSLICE",nslice,1) + call flush(iout) + if (nslice.gt.MaxSlice) then + write (iout,*) "Error: parameter out of range: NSLICE",nslice, + & MaxSlice + return1 + endif + write (iout,*) "Frequency of storing conformations", + & (isampl(i),i=1,nparmset) + write (iout,*) "Maxit",maxit," Fimin",fimin + call readi(controlcard,"NQ",nQ,1) + if (nQ.gt.MaxQ) then + write (iout,*) "Error: parameter out of range: NQ",nq, + & maxq + return1 + endif + indpdb=0 + if (index(controlcard,"CLASSIFY").gt.0) indpdb=1 + call reada(controlcard,"DELTA",delta,1.0d-2) + call readi(controlcard,"EINICHECK",einicheck,2) + call reada(controlcard,"DELTRMS",deltrms,5.0d-2) + call reada(controlcard,"DELTRGY",deltrgy,5.0d-2) + call readi(controlcard,"RESCALE",rescale_mode,1) + write (iout,*) "delta",delta + write (iout,*) "einicheck",einicheck + write (iout,*) "rescale_mode",rescale_mode + call flush(iout) + bxfile=index(controlcard,"BXFILE").gt.0 + cxfile=index(controlcard,"CXFILE").gt.0 + if (nslice .eq. 1 .and. .not.bxfile .and. .not.cxfile) + & bxfile=.true. + histfile=index(controlcard,"HISTFILE").gt.0 + entfile=index(controlcard,"ENTFILE").gt.0 + zscfile=index(controlcard,"ZSCFILE").gt.0 + return + end +c------------------------------------------------------------------------------ + subroutine read_efree(iparm,*) +C +C Read molecular data +C + implicit none + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.COMPAR' + include 'DIMENSIONS.FREE' + include 'COMMON.IOUNITS' + include 'COMMON.TIME1' + include 'COMMON.SBRIDGE' + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.HEADER' + include 'COMMON.GEO' + include 'COMMON.FREE' + character*320 controlcard,ucase + integer iparm,ib,i,j + integer ilen + external ilen + call card_concat(controlcard,.true.) + call readi(controlcard,'NT',nT_h(iparm),1) + if (nT_h(iparm).gt.MaxT_h) then + write (iout,*) "Error: parameter out of range: NT",nT_h(iparm), + & MaxT_h + return1 + endif + replica(iparm)=index(controlcard,"REPLICA").gt.0 + umbrella(iparm)=index(controlcard,"UMBRELLA").gt.0 + read_iset(iparm)=index(controlcard,"READ_ISET").gt.0 + write (iout,*) "nQ",nQ," nT",nT_h(iparm)," replica ", + & replica(iparm)," umbrella ",umbrella(iparm), + & " read_iset",read_iset(iparm) + call flush(iout) + do ib=1,nT_h(iparm) + call card_concat(controlcard,.true.) + call readi(controlcard,'NR',nR(ib,iparm),1) + if (umbrella(iparm)) then + nRR(ib,iparm)=1 + else + nRR(ib,iparm)=nR(ib,iparm) + endif + if (nR(ib,iparm).gt.MaxR) then + write (iout,*) "Error: parameter out of range: NR", + & nR(ib,iparm),MaxR + return1 + endif + call reada(controlcard,'TEMP',beta_h(ib,iparm),298.0d0) + beta_h(ib,iparm)=1.0d0/(beta_h(ib,iparm)*1.987D-3) + call multreada(controlcard,'FI',f(1,ib,iparm),nR(ib,iparm), + & 0.0d0) + do i=1,nR(ib,iparm) + call card_concat(controlcard,.true.) + call multreada(controlcard,'KH',KH(1,i,ib,iparm),nQ, + & 100.0d0) + call multreada(controlcard,'Q0',Q0(1,i,ib,iparm),nQ, + & 0.0d0) + enddo + enddo + do ib=1,nT_h(iparm) + write (iout,*) "ib",ib," beta_h", + & 1.0d0/(0.001987*beta_h(ib,iparm)) + write (iout,*) "nR",nR(ib,iparm) + write (iout,*) "fi",(f(i,ib,iparm),i=1,nR(ib,iparm)) + do i=1,nR(ib,iparm) + write (iout,*) "i",i," Kh",(Kh(j,i,ib,iparm),j=1,nQ), + & "q0",(q0(j,i,ib,iparm),j=1,nQ) + enddo + call flush(iout) + enddo + return + end +c----------------------------------------------------------------------------- + subroutine read_protein_data(iparm,*) + implicit none + include "DIMENSIONS" + include "DIMENSIONS.ZSCOPT" + include "DIMENSIONS.FREE" +#ifdef MPI + include "mpif.h" + integer IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE) + include "COMMON.MPI" +#endif + include "COMMON.CHAIN" + include "COMMON.IOUNITS" + include "COMMON.PROT" + include "COMMON.PROTFILES" + include "COMMON.NAMES" + include "COMMON.FREE" + include "COMMON.OBCINKA" + character*64 nazwa + character*16000 controlcard + integer i,ii,ib,iR,iparm,ilen,iroof,nthr + external ilen,iroof + call flush(iout) +C Read names of files with conformation data. + if (replica(iparm)) then + nthr = 1 + else + nthr = nT_h(iparm) + endif + do ib=1,nthr + do ii=1,nRR(ib,iparm) + write (iout,*) "Parameter set",iparm," temperature",ib, + & " window",ii + call card_concat(controlcard,.true.) + write (iout,*) controlcard(:ilen(controlcard)) + call readi(controlcard,"NFILE_BIN",nfile_bin(ii,ib,iparm),0) + call readi(controlcard,"NFILE_ASC",nfile_asc(ii,ib,iparm),0) + call readi(controlcard,"NFILE_CX",nfile_cx(ii,ib,iparm),0) + call readi(controlcard,"REC_START",rec_start(ii,ib,iparm),1) + call readi(controlcard,"REC_END",rec_end(ii,ib,iparm), + & maxstr*isampl(iparm)+rec_start(ii,ib,iparm)-1) + call reada(controlcard,"TIME_START", + & time_start_collect(ii,ib,iparm),0.0d0) + call reada(controlcard,"TIME_END",time_end_collect(ii,ib,iparm), + & 1.0d10) + write (iout,*) "rec_start",rec_start(ii,ib,iparm), + & " rec_end",rec_end(ii,ib,iparm) + write (iout,*) "time_start",time_start_collect(ii,ib,iparm), + & " time_end",time_end_collect(ii,ib,iparm) + call flush(iout) + if (replica(iparm)) then + call readi(controlcard,"TOTRAJ",totraj(ii,iparm),1) + write (iout,*) "Number of trajectories",totraj(ii,iparm) + call flush(iout) + endif + if (nfile_bin(ii,ib,iparm).lt.2 + & .and. nfile_asc(ii,ib,iparm).eq.0 + & .and. nfile_cx(ii,ib,iparm).eq.0) then + write (iout,*) "Error - no action specified!" + return1 + endif + if (nfile_bin(ii,ib,iparm).gt.0) then + call card_concat(controlcard,.false.) + call split_string(controlcard,protfiles(1,1,ii,ib,iparm), + & maxfile_prot,nfile_bin(ii,ib,iparm)) +#ifdef DEBUG + write(iout,*)"nfile_bin",nfile_bin(ii,ib,iparm) + write(iout,*) (protfiles(i,1,ii,ib,iparm), + & i=1,nfile_bin(ii,ib,iparm)) +#endif + endif + if (nfile_asc(ii,ib,iparm).gt.0) then + call card_concat(controlcard,.false.) + call split_string(controlcard,protfiles(1,2,ii,ib,iparm), + & maxfile_prot,nfile_asc(ii,ib,iparm)) +#ifdef DEBUG + write(iout,*) "nfile_asc(ii,ib,iparm)",nfile_asc(ii,ib,iparm) + write(iout,*) (protfiles(i,2,ii,ib,iparm), + & i=1,nfile_asc(ii,ib,iparm)) +#endif + else if (nfile_cx(ii,ib,iparm).gt.0) then + call card_concat(controlcard,.false.) + call split_string(controlcard,protfiles(1,2,ii,ib,iparm), + & maxfile_prot,nfile_cx(ii,ib,iparm)) +#ifdef DEBUG + write(iout,*) "nfile_cx(ii,ib,iparm)",nfile_cx(ii,ib,iparm) + write(iout,*) (protfiles(i,2,ii,ib,iparm), + & i=1,nfile_cx(ii,ib,iparm)) +#endif + endif + call flush(iout) + enddo + enddo + return + end +c------------------------------------------------------------------------------- + subroutine opentmp(islice,iunit,bprotfile_temp) + implicit none + include "DIMENSIONS" + include "DIMENSIONS.ZSCOPT" + include "DIMENSIONS.FREE" +#ifdef MPI + include "mpif.h" + integer IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE) + include "COMMON.MPI" +#endif + include "COMMON.IOUNITS" + include "COMMON.PROTFILES" + include "COMMON.PROT" + character*64 bprotfile_temp + character*3 liczba + character*2 liczba1 + integer iunit,islice + integer ilen,iroof + external ilen,iroof + logical lerr + + write (liczba1,'(bz,i2.2)') islice +#ifdef MPI + write (liczba,'(bz,i3.3)') me + bprotfile_temp = scratchdir(:ilen(scratchdir))//"/"// + & prefix(:ilen(prefix))//liczba//".xbin.tmp"//liczba1 + open (iunit,file=bprotfile_temp,status="unknown", + & form="unformatted",access="direct",recl=lenrec) +#else + bprotfile_temp = scratchdir(:ilen(scratchdir))// + & "/"//prefix(:ilen(prefix))//".xbin.tmp"//liczba1 + open (iunit,file=bprotfile_temp,status="unknown", + & form="unformatted",access="direct",recl=lenrec) +#endif + return + end +c------------------------------------------------------------------------------- + subroutine read_database(*) + implicit none + include "DIMENSIONS" + include "DIMENSIONS.ZSCOPT" + include "DIMENSIONS.FREE" +#ifdef MPI + include "mpif.h" + integer IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE) + include "COMMON.MPI" +#endif + include "COMMON.CHAIN" + include "COMMON.IOUNITS" + include "COMMON.PROTFILES" + include "COMMON.NAMES" + include "COMMON.VAR" + include "COMMON.GEO" + include "COMMON.ENEPS" + include "COMMON.PROT" + include "COMMON.INTERACT" + include "COMMON.FREE" + include "COMMON.SBRIDGE" + include "COMMON.OBCINKA" + real*4 csingle(3,maxres2) + character*64 nazwa,bprotfile_temp + character*3 liczba + character*2 liczba1 + integer i,j,ii,jj(maxslice),k,kk(maxslice),l, + & ll(maxslice),mm(maxslice),if + integer nrec,nlines,iscor,iunit,islice + double precision energ + integer ilen,iroof + external ilen,iroof + double precision rmsdev,energia(0:max_ene),efree,eini,temp + double precision prop(maxQ) + integer ntot_all(maxslice,0:maxprocs-1) + integer iparm,ib,iib,ir,nprop,nthr + double precision etot,time + integer ixdrf,iret + logical lerr,linit + + lenrec1=12*(nres+nct-nnt+1)+4*(2*nss+2)+24 + lenrec2=12*(nres+nct-nnt+1)+4*(2*nss+2)+24+8*nQ + lenrec=lenrec2+8 + write (iout,*) "lenrec",lenrec," lenrec1",lenrec1, + & " lenrec2",lenrec2 + + do i=1,nQ + prop(i)=0.0d0 + enddo + do islice=1,nslice + ll(islice)=0 + mm(islice)=0 + enddo + write (iout,*) "nparmset",nparmset + do iparm=1,nparmset + + if (replica(iparm)) then + nthr = 1 + else + nthr = nT_h(iparm) + endif + + do ib=1,nthr + do iR=1,nRR(ib,iparm) + + write (iout,*) "iparm",iparm," ib",ib," iR",iR," nQ",nQ + do islice=1,nslice + jj(islice)=0 + kk(islice)=0 + enddo + + IF (NFILE_BIN(iR,ib,iparm).GT.0) THEN +c Read conformations from binary DA files (one per batch) and write them to +c a binary DA scratchfile. + write (liczba,'(bz,i3.3)') me + do if=1,nfile_bin(iR,ib,iparm) + nazwa=protfiles(if,1,iR,ib,iparm) + & (:ilen(protfiles(if,1,iR,ib,iparm)))//".bx" + open (ientin,file=nazwa,status="old",form="unformatted", + & access="direct",recl=lenrec2,err=1111) + ii=0 + do islice=1,nslice + call opentmp(islice,ientout,bprotfile_temp) + call bxread(nazwa,ii,jj(islice),kk(islice),ll(islice), + & mm(islice),iR,ib,iparm) + close(ientout) + enddo + close(ientin) + enddo + ENDIF ! NFILE_BIN>0 +c + IF (NFILE_ASC(iR,ib,iparm).GT.0) THEN +c Read conformations from multiple ASCII int files and write them to a binary +c DA scratchfile. + do if=1,nfile_asc(iR,ib,iparm) + nazwa=protfiles(if,2,iR,ib,iparm) + & (:ilen(protfiles(if,2,iR,ib,iparm)))//".x" + open(unit=ientin,file=nazwa,status='old',err=1111) + write(iout,*) "reading ",nazwa(:ilen(nazwa)) + ii=0 + call xread(nazwa,ii,jj,kk,ll,mm,iR,ib,iparm) + enddo ! if + ENDIF + IF (NFILE_CX(iR,ib,iparm).gt.0) THEN +c Read conformations from cx files and write them to a binary +c DA scratchfile. + do if=1,nfile_cx(iR,ib,iparm) + nazwa=protfiles(if,2,iR,ib,iparm) + & (:ilen(protfiles(if,2,iR,ib,iparm)))//".cx" + write(iout,*) "reading ",nazwa(:ilen(nazwa)) + ii=0 + print *,"Calling cxread" + call cxread(nazwa,ii,jj,kk,ll,mm,iR,ib,iparm, + & *1111) + close(ientout) + write (iout,*) "exit cxread" + call flush(iout) + enddo + ENDIF + + do islice=1,nslice + stot(islice)=stot(islice)+jj(islice) + enddo + + enddo + enddo + write (iout,*) "IPARM",iparm + enddo + + if (nslice.eq.1) then +#ifdef MPI + write (liczba,'(bz,i3.3)') me + bprotfile_temp = scratchdir(:ilen(scratchdir))//"/"// + & prefix(:ilen(prefix))//liczba//".xbin.tmp" +#else + bprotfile_temp = scratchdir(:ilen(scratchdir))// + & "/"//prefix(:ilen(prefix))//".xbin.tmp" +#endif + write(iout,*) mm(1)," conformations read",ll(1), + & " conformations written to ", + & bprotfile_temp(:ilen(bprotfile_temp)) + else + do islice=1,nslice + write (liczba1,'(bz,i2.2)') islice +#ifdef MPI + write (liczba,'(bz,i3.3)') me + bprotfile_temp = scratchdir(:ilen(scratchdir))//"/"// + & prefix(:ilen(prefix))//liczba//".xbin.tmp"//liczba1 +#else + bprotfile_temp = scratchdir(:ilen(scratchdir))// + & "/"//prefix(:ilen(prefix))//".xbin.tmp"//liczba1 +#endif + write(iout,*) mm(islice)," conformations read",ll(islice), + & " conformations written to ", + & bprotfile_temp(:ilen(bprotfile_temp)) + enddo + endif + +#ifdef MPI +c Check if everyone has the same number of conformations + call MPI_Allgather(stot(1),maxslice,MPI_INTEGER, + & ntot_all(1,0),maxslice,MPI_INTEGER,MPI_Comm_World,IERROR) + lerr=.false. + do i=0,nprocs-1 + if (i.ne.me) then + do islice=1,nslice + if (stot(islice).ne.ntot_all(islice,i)) then + write (iout,*) "Number of conformations at processor",i, + & " differs from that at processor",me, + & stot(islice),ntot_all(islice,i)," slice",islice + lerr = .true. + endif + enddo + endif + enddo + if (lerr) then + write (iout,*) + write (iout,*) "Numbers of conformations read by processors" + write (iout,*) + do i=0,nprocs-1 + write (iout,'(8i10)') i,(ntot_all(islice,i),islice=1,nslice) + enddo + write (iout,*) "Calculation terminated." + call flush(iout) + return1 + endif + do islice=1,nslice + ntot(islice)=stot(islice) + enddo + return +#endif + 1111 write(iout,*) "Error opening coordinate file ",nazwa(:ilen(nazwa)) + call flush(iout) + return1 + end +c------------------------------------------------------------------------------ + subroutine card_concat(card,to_upper) + implicit none + include 'DIMENSIONS.ZSCOPT' + include "COMMON.IOUNITS" + character*(*) card + character*80 karta,ucase + logical to_upper + integer ilen + external ilen + read (inp,'(a)') karta + if (to_upper) karta=ucase(karta) + card=' ' + do while (karta(80:80).eq.'&') + card=card(:ilen(card)+1)//karta(:79) + read (inp,'(a)') karta + if (to_upper) karta=ucase(karta) + enddo + card=card(:ilen(card)+1)//karta + return + end +c------------------------------------------------------------------------------ + subroutine readi(rekord,lancuch,wartosc,default) + implicit none + character*(*) rekord,lancuch + integer wartosc,default + integer ilen,iread + external ilen + iread=index(rekord,lancuch(:ilen(lancuch))//"=") + if (iread.eq.0) then + wartosc=default + return + endif + iread=iread+ilen(lancuch)+1 + read (rekord(iread:),*) wartosc + return + end +c---------------------------------------------------------------------------- + subroutine reada(rekord,lancuch,wartosc,default) + implicit none + character*(*) rekord,lancuch + character*80 aux + double precision wartosc,default + integer ilen,iread + external ilen + iread=index(rekord,lancuch(:ilen(lancuch))//"=") + if (iread.eq.0) then + wartosc=default + return + endif + iread=iread+ilen(lancuch)+1 + read (rekord(iread:),*) wartosc + return + end +c---------------------------------------------------------------------------- + subroutine multreadi(rekord,lancuch,tablica,dim,default) + implicit none + integer dim,i + integer tablica(dim),default + character*(*) rekord,lancuch + character*80 aux + integer ilen,iread + external ilen + do i=1,dim + tablica(i)=default + enddo + iread=index(rekord,lancuch(:ilen(lancuch))//"=") + if (iread.eq.0) return + iread=iread+ilen(lancuch)+1 + read (rekord(iread:),*,end=10,err=10) (tablica(i),i=1,dim) + 10 return + end +c---------------------------------------------------------------------------- + subroutine multreada(rekord,lancuch,tablica,dim,default) + implicit none + integer dim,i + double precision tablica(dim),default + character*(*) rekord,lancuch + character*80 aux + integer ilen,iread + external ilen + do i=1,dim + tablica(i)=default + enddo + iread=index(rekord,lancuch(:ilen(lancuch))//"=") + if (iread.eq.0) return + iread=iread+ilen(lancuch)+1 + read (rekord(iread:),*,end=10,err=10) (tablica(i),i=1,dim) + 10 return + end +c---------------------------------------------------------------------------- + subroutine reads(rekord,lancuch,wartosc,default) + implicit none + character*(*) rekord,lancuch,wartosc,default + character*80 aux + integer ilen,lenlan,lenrec,iread,ireade + external ilen + logical iblnk + external iblnk + lenlan=ilen(lancuch) + lenrec=ilen(rekord) + iread=index(rekord,lancuch(:lenlan)//"=") +c print *,"rekord",rekord," lancuch",lancuch +c print *,"iread",iread," lenlan",lenlan," lenrec",lenrec + if (iread.eq.0) then + wartosc=default + return + endif + iread=iread+lenlan+1 +c print *,"iread",iread +c print *,"|",rekord(iread:iread),"|",iblnk(rekord(iread:iread)) + do while (iread.le.lenrec .and. iblnk(rekord(iread:iread))) + iread=iread+1 +c print *,"|",rekord(iread:iread),"|",iblnk(rekord(iread:iread)) + enddo +c print *,"iread",iread + if (iread.gt.lenrec) then + wartosc=default + return + endif + ireade=iread+1 +c print *,"ireade",ireade + do while (ireade.lt.lenrec .and. + & .not.iblnk(rekord(ireade:ireade))) + ireade=ireade+1 + enddo + wartosc=rekord(iread:ireade) + return + end +c---------------------------------------------------------------------------- + subroutine multreads(rekord,lancuch,tablica,dim,default) + implicit none + integer dim,i + character*(*) rekord,lancuch,tablica(dim),default + character*80 aux + integer ilen,lenlan,lenrec,iread,ireade + external ilen + logical iblnk + external iblnk + do i=1,dim + tablica(i)=default + enddo + lenlan=ilen(lancuch) + lenrec=ilen(rekord) + iread=index(rekord,lancuch(:lenlan)//"=") +c print *,"rekord",rekord," lancuch",lancuch +c print *,"iread",iread," lenlan",lenlan," lenrec",lenrec + if (iread.eq.0) return + iread=iread+lenlan+1 + do i=1,dim +c print *,"iread",iread +c print *,"|",rekord(iread:iread),"|",iblnk(rekord(iread:iread)) + do while (iread.le.lenrec .and. iblnk(rekord(iread:iread))) + iread=iread+1 +c print *,"|",rekord(iread:iread),"|",iblnk(rekord(iread:iread)) + enddo +c print *,"iread",iread + if (iread.gt.lenrec) return + ireade=iread+1 +c print *,"ireade",ireade + do while (ireade.lt.lenrec .and. + & .not.iblnk(rekord(ireade:ireade))) + ireade=ireade+1 + enddo + tablica(i)=rekord(iread:ireade) + iread=ireade+1 + enddo + end +c---------------------------------------------------------------------------- + subroutine split_string(rekord,tablica,dim,nsub) + implicit none + integer dim,nsub,i,ii,ll,kk + character*(*) tablica(dim) + character*(*) rekord + integer ilen + external ilen + do i=1,dim + tablica(i)=" " + enddo + ii=1 + ll = ilen(rekord) + nsub=0 + do i=1,dim +C Find the start of term name + kk = 0 + do while (ii.le.ll .and. rekord(ii:ii).eq." ") + ii = ii+1 + enddo +C Parse the name into TABLICA(i) until blank found + do while (ii.le.ll .and. rekord(ii:ii).ne." ") + kk = kk+1 + tablica(i)(kk:kk)=rekord(ii:ii) + ii = ii+1 + enddo + if (kk.gt.0) nsub=nsub+1 + if (ii.gt.ll) return + enddo + return + end +c-------------------------------------------------------------------------------- + integer function iroof(n,m) + ii = n/m + if (ii*m .lt. n) ii=ii+1 + iroof = ii + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/readrtns_compar.F b/source/wham/src-NEWSC-NEWCORR/readrtns_compar.F new file mode 100644 index 0000000..8e03f15 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/readrtns_compar.F @@ -0,0 +1,160 @@ + subroutine read_compar +C +C Read molecular data +C + implicit none + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.COMPAR' + include 'DIMENSIONS.FREE' + include 'COMMON.IOUNITS' + include 'COMMON.TIME1' + include 'COMMON.SBRIDGE' + include 'COMMON.CONTROL' + include 'COMMON.COMPAR' + include 'COMMON.CHAIN' + include 'COMMON.HEADER' + include 'COMMON.GEO' + include 'COMMON.FREE' + character*320 controlcard,ucase + character*64 wfile + integer ilen + external ilen + integer i,j,k + + call card_concat(controlcard,.true.) + pdbref=(index(controlcard,'PDBREF').gt.0) + call reada(controlcard,'CUTOFF_UP',rmscut_base_up,4.0d0) + call reada(controlcard,'CUTOFF_LOW',rmscut_base_low,3.0d0) + call reada(controlcard,'RMSUP_LIM',rmsup_lim,4.0d0) + call reada(controlcard,'RMSUPUP_LIM',rmsupup_lim,7.5d0) + verbose = index(controlcard,"VERBOSE").gt.0 + lgrp=index(controlcard,"STATIN").gt.0 + lgrp_out=index(controlcard,"STATOUT").gt.0 + merge_helices=index(controlcard,"DONT_MERGE_HELICES").eq.0 + binary = index(controlcard,"BINARY").gt.0 + rmscut_base_up=rmscut_base_up/50 + rmscut_base_low=rmscut_base_low/50 + call reada(controlcard,"FRAC_SEC",frac_sec,0.66666666d0) + call readi(controlcard,'NLEVEL',nlevel,1) + if (nlevel.lt.0) goto 121 +c Read the data pertaining to elementary fragments (level 1) + call readi(controlcard,'NFRAG',nfrag(1),0) + write(iout,*)"nfrag(1)",nfrag(1) + do j=1,nfrag(1) + call card_concat(controlcard,.true.) + write (iout,*) controlcard(:ilen(controlcard)) + call readi(controlcard,'NPIECE',npiece(j,1),0) + call readi(controlcard,'N_SHIFT1',n_shift(1,j,1),0) + call readi(controlcard,'N_SHIFT2',n_shift(2,j,1),0) + call reada(controlcard,'ANGCUT',ang_cut(j),50.0d0) + call reada(controlcard,'MAXANG',ang_cut1(j),360.0d0) + call reada(controlcard,'FRAC_MIN',frac_min(j),0.666666d0) + call reada(controlcard,'NC_FRAC',nc_fragm(j,1),0.5d0) + call readi(controlcard,'NC_REQ',nc_req_setf(j,1),0) + call readi(controlcard,'RMS',irms(j,1),0) + call readi(controlcard,'LOCAL',iloc(j),1) + call readi(controlcard,'ELCONT',ielecont(j,1),1) + if (ielecont(j,1).eq.0) then + call readi(controlcard,'SCCONT',isccont(j,1),1) + endif + ang_cut(j)=ang_cut(j)*deg2rad + ang_cut1(j)=ang_cut1(j)*deg2rad + do k=1,npiece(j,1) + call card_concat(controlcard,.true.) + call readi(controlcard,'IFRAG1',ifrag(1,k,j),0) + call readi(controlcard,'IFRAG2',ifrag(2,k,j),0) + enddo + write(iout,*)"j",j," npiece",npiece(j,1)," ifrag", + & (ifrag(1,k,j),ifrag(2,k,j), + & k=1,npiece(j,1))," ang_cut",ang_cut(j)*rad2deg, + & " ang_cut1",ang_cut1(j)*rad2deg + write(iout,*)"n_shift",n_shift(1,j,1),n_shift(2,j,1) + write(iout,*)"nc_frac",nc_fragm(j,1)," nc_req",nc_req_setf(j,1) + write(iout,*)"irms",irms(j,1)," ielecont",ielecont(j,1), + & " ilocal",iloc(j)," isccont",isccont(j,1) + enddo +c Read data pertaning to higher levels + do i=2,nlevel + call card_concat(controlcard,.true.) + call readi(controlcard,'NFRAG',NFRAG(i),0) + write (iout,*) "i",i," nfrag",nfrag(i) + do j=1,nfrag(i) + call card_concat(controlcard,.true.) + if (i.eq.2) then + call readi(controlcard,'ELCONT',ielecont(j,i),0) + if (ielecont(j,i).eq.0) then + call readi(controlcard,'SCCONT',isccont(j,i),1) + endif + call readi(controlcard,'RMS',irms(j,i),0) + else + ielecont(j,i)=0 + isccont(j,i)=0 + irms(j,i)=1 + endif + call readi(controlcard,'NPIECE',npiece(j,i),0) + call readi(controlcard,'N_SHIFT1',n_shift(1,j,i),0) + call readi(controlcard,'N_SHIFT2',n_shift(2,j,i),0) + call multreadi(controlcard,'IPIECE',ipiece(1,j,i), + & npiece(j,i),0) + call reada(controlcard,'NC_FRAC',nc_fragm(j,i),0.5d0) + call readi(controlcard,'NC_REQ',nc_req_setf(j,i),0) + write(iout,*) "j",j," npiece",npiece(j,i)," n_shift", + & n_shift(1,j,i),n_shift(2,j,i)," ielecont",ielecont(j,i), + & " isccont",isccont(j,i)," irms",irms(j,i) + write(iout,*) "ipiece",(ipiece(k,j,i),k=1,npiece(j,i)) + write(iout,*)"n_shift",n_shift(1,j,i),n_shift(2,j,i) + write(iout,*)"nc_frac",nc_fragm(j,i), + & " nc_req",nc_req_setf(j,i) + enddo + enddo + if (binary) write (iout,*) "Classes written in binary format." + return + 121 continue + call reada(controlcard,'ANGCUT_HEL',angcut_hel,50.0d0) + call reada(controlcard,'MAXANG_HEL',angcut1_hel,60.0d0) + call reada(controlcard,'ANGCUT_BET',angcut_bet,90.0d0) + call reada(controlcard,'MAXANG_BET',angcut1_bet,360.0d0) + call reada(controlcard,'ANGCUT_STRAND',angcut_strand,90.0d0) + call reada(controlcard,'MAXANG_STRAND',angcut1_strand,60.0d0) + call reada(controlcard,'FRAC_MIN',frac_min_set,0.666666d0) + call reada(controlcard,'NC_FRAC_HEL',ncfrac_hel,0.5d0) + call readi(controlcard,'NC_REQ_HEL',ncreq_hel,0) + call reada(controlcard,'NC_FRAC_BET',ncfrac_bet,0.5d0) + call reada(controlcard,'NC_FRAC_PAIR',ncfrac_pair,0.3d0) + call readi(controlcard,'NC_REQ_BET',ncreq_bet,0) + call readi(controlcard,'NC_REQ_PAIR',ncreq_pair,0) + call readi(controlcard,'NSHIFT_HEL',nshift_hel,3) + call readi(controlcard,'NSHIFT_BET',nshift_bet,3) + call readi(controlcard,'NSHIFT_STRAND',nshift_strand,3) + call readi(controlcard,'NSHIFT_PAIR',nshift_pair,3) + call readi(controlcard,'RMS_SINGLE',irms_single,0) + call readi(controlcard,'CONT_SINGLE',icont_single,1) + call readi(controlcard,'LOCAL_SINGLE',iloc_single,1) + call readi(controlcard,'RMS_PAIR',irms_pair,0) + call readi(controlcard,'CONT_PAIR',icont_pair,1) + call readi(controlcard,'SPLIT_BET',isplit_bet,0) + angcut_hel=angcut_hel*deg2rad + angcut1_hel=angcut1_hel*deg2rad + angcut_bet=angcut_bet*deg2rad + angcut1_bet=angcut1_bet*deg2rad + angcut_strand=angcut_strand*deg2rad + angcut1_strand=angcut1_strand*deg2rad + write (iout,*) "Automatic detection of structural elements" + write (iout,*) 'NC_FRAC_HEL',ncfrac_hel,' NC_REQ_HEL',ncreq_hel, + & ' NC_FRAC_BET',ncfrac_bet,' NC_REQ_BET',ncreq_bet, + & ' RMS_SINGLE',irms_single,' CONT_SINGLE',icont_single, + & ' NC_FRAC_PAIR',ncfrac_pair,' NC_REQ_PAIR',ncreq_pair, + & ' RMS_PAIR',irms_pair,' CONT_PAIR',icont_pair, + & ' SPLIT_BET',isplit_bet + write (iout,*) 'NSHIFT_HEL',nshift_hel,' NSHIFT_BET',nshift_bet, + & ' NSHIFT_STRAND',nshift_strand,' NSHIFT_PAIR',nshift_pair + write (iout,*) 'ANGCUT_HEL',angcut_hel*rad2deg, + & ' MAXANG_HEL',angcut1_hel*rad2deg + write (iout,*) 'ANGCUT_BET',angcut_bet*rad2deg, + & ' MAXANG_BET',angcut1_bet*rad2deg + write (iout,*) 'ANGCUT_STRAND',angcut_strand*rad2deg, + & ' MAXANG_STRAND',angcut1_strand*rad2deg + write (iout,*) 'FRAC_MIN',frac_min_set + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/rescode.f b/source/wham/src-NEWSC-NEWCORR/rescode.f new file mode 100644 index 0000000..b516fed --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/rescode.f @@ -0,0 +1,32 @@ + integer function rescode(iseq,nam,itype) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + character*3 nam,ucase + + if (itype.eq.0) then + + do i=1,ntyp1 + if (ucase(nam).eq.restyp(i)) then + rescode=i + return + endif + enddo + + else + + do i=1,ntyp1 + if (nam(1:1).eq.onelet(i)) then + rescode=i + return + endif + enddo + + endif + + write (iout,10) iseq,nam + stop + 10 format ('**** Error - residue',i4,' has an unresolved name ',a3) + end + diff --git a/source/wham/src-NEWSC-NEWCORR/rmscalc.f b/source/wham/src-NEWSC-NEWCORR/rmscalc.f new file mode 100644 index 0000000..70d9425 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/rmscalc.f @@ -0,0 +1,156 @@ + double precision function rmscalc(ishif,i,j,jcon,lprn) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.COMPAR' + include 'COMMON.IOUNITS' + include 'COMMON.COMPAR' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + double precision przes(3),obrot(3,3) + double precision creff(3,maxres2),cc(3,maxres2) + logical iadded(maxres) + integer inumber(2,maxres) + common /ccc/ creff,cc,iadded,inumber + logical lprn + logical non_conv + integer ishif,i,j + if (lprn) then + write (iout,*) "i",i," j",j," jcont",jcon," ishif",ishif + write (iout,*) "npiece",npiece(j,i) + endif + ii=0 + do l=1,nres + iadded(l)=.false. + enddo + do k=1,npiece(j,i) + if (i.eq.1) then + if (lprn) + & write (iout,*) "Level 1: j=",j,"k=",k," adding fragment", + & ifrag(1,k,j),ifrag(2,k,j) + call cprep(ifrag(1,k,j),ifrag(2,k,j),ishif,ii) +c write (iout,*) "ii=",ii + else + kk = ipiece(k,j,i) +c write (iout,*) "kk",kk," npiece",npiece(kk,1) + do l=1,npiece(kk,1) + if (lprn) + & write (iout,*) "Level",i,": j=",j,"k=",k," kk=",kk, + & " l=",l," adding fragment", + & ifrag(1,l,kk),ifrag(2,l,kk) + call cprep(ifrag(1,l,kk),ifrag(2,l,kk),ishif,ii) + enddo + endif + enddo + if (lprn) then + do k=1,ii + write(iout,'(5i4,2(3f10.5,5x))') i,j,k,inumber(1,k), + & inumber(2,k),(creff(l,k),l=1,3),(cc(l,k),l=1,3) + enddo + endif + call fitsq(rms,cc(1,1),creff(1,1),ii,przes,obrot,non_conv) + if (non_conv) then + print *,'Error: FITSQ non-convergent, jcon',jcon + rmscalc=1.0d2 + else if (rms.lt.-1.0d-6) then + print *,'Error: rms^2 = ',rms,jcon + rmscalc = 1.0d2 + else if (rms.ge.1.0d-6 .and. rms.lt.0) then + rmscalc=0.0d0 + else + rmscalc = dsqrt(rms) + endif + return + end +c------------------------------------------------------------------------- + subroutine cprep(if1,if2,ishif,ii) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.COMPAR' + include 'COMMON.IOUNITS' + include 'COMMON.COMPAR' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + double precision przes(3),obrot(3,3) + double precision creff(3,maxres2),cc(3,maxres2) + logical iadded(maxres) + integer inumber(2,maxres) + common /ccc/ creff,cc,iadded,inumber +c write (iout,*) "Calling cprep" + do l=if1,if2 +c write (iout,*) "l",l," iadded",iadded(l) + if (l+ishif.gt.1 .and. l+ishif.le.nres .and. .not.iadded(l)) + & then + ii=ii+1 + iadded(l)=.true. + inumber(1,ii)=l + inumber(2,ii)=l+ishif + do m=1,3 + creff(m,ii)=cref(m,l) + cc(m,ii)=c(m,l+ishif) + enddo + endif + enddo + return + end +c------------------------------------------------------------------------- + double precision function rmsnat(jcon) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.COMPAR' + include 'COMMON.IOUNITS' + include 'COMMON.COMPAR' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + double precision przes(3),obrot(3,3) + logical non_conv + integer ishif,i,j + call fitsq(rms,c(1,nstart_sup),cref(1,nstart_sup),nsup, + & przes,obrot,non_conv) + if (non_conv) then + print *,'Error: FITSQ non-convergent, jcon',jcon + rmsnat=1.0d2 + else if (rms.lt.-1.0d-6) then + print *,'Error: rms^2 = ',rms,jcon + rmsnat = 1.0d2 + else if (rms.ge.1.0d-6 .and. rms.lt.0) then + rmsnat=0.0d0 + else + rmsnat = dsqrt(rms) + endif + return + end +c----------------------------------------------------------------------------- + double precision function gyrate(jcon) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.INTERACT' + include 'COMMON.CHAIN' + double precision cen(3),rg + + do j=1,3 + cen(j)=0.0d0 + enddo + + do i=nnt,nct + do j=1,3 + cen(j)=cen(j)+c(j,i) + enddo + enddo + do j=1,3 + cen(j)=cen(j)/dble(nct-nnt+1) + enddo + rg = 0.0d0 + do i = nnt, nct + do j=1,3 + rg = rg + (c(j,i)-cen(j))**2 + enddo + end do + gyrate = dsqrt(rg/dble(nct-nnt+1)) + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/secondary.f b/source/wham/src-NEWSC-NEWCORR/secondary.f new file mode 100644 index 0000000..9c9bc7d --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/secondary.f @@ -0,0 +1,713 @@ + subroutine define_fragments + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.COMPAR' + include 'COMMON.IOUNITS' + include 'COMMON.TIME1' + include 'COMMON.FRAG' + include 'COMMON.SBRIDGE' + include 'COMMON.CONTROL' + include 'COMMON.COMPAR' + include 'COMMON.CHAIN' + include 'COMMON.HEADER' + include 'COMMON.GEO' + include 'COMMON.CONTACTS' + include 'COMMON.PEPTCONT' + include 'COMMON.INTERACT' + include 'COMMON.NAMES' + integer nstrand,istrand(2,maxres/2) + integer nhairp,ihairp(2,maxres/5) + character*16 strstr(4) /'helix','hairpin','strand','strand pair'/ + write (iout,*) 'NC_FRAC_HEL',ncfrac_hel,' NC_REQ_HEL',ncreq_hel, + & 'NC_FRAC_BET',ncfrac_bet,' NC_REQ_BET',ncreq_bet, + & 'NC_FRAC_PAIR',ncfrac_pair,' NC_REQ_PAIR',ncreq_pair, + & ' RMS_PAIR',irms_pair,' SPLIT_BET',isplit_bet + write (iout,*) 'NSHIFT_HEL',nshift_hel,' NSHIFT_BET',nshift_bet, + & ' NSHIFT_STRAND',nshift_strand,' NSHIFT_PAIR',nshift_pair + write (iout,*) 'ANGCUT_HEL',angcut_hel*rad2deg, + & ' MAXANG_HEL',angcut1_hel*rad2deg + write (iout,*) 'ANGCUT_BET',angcut_bet*rad2deg, + & ' MAXANG_BET',angcut1_bet*rad2deg + write (iout,*) 'ANGCUT_STRAND',angcut_strand*rad2deg, + & ' MAXANG_STRAND',angcut1_strand*rad2deg + write (iout,*) 'FRAC_MIN',frac_min_set +c Find secondary structure elements (helices and beta-sheets) + call secondary2(.true.,.false.,ncont_pept_ref,icont_pept_ref, + & isec_ref) +c Define primary fragments. First include the helices. + nhairp=0 + nstrand=0 +c Merge helices +c AL 12/23/03 - to avoid splitting helices into very small fragments + if (merge_helices) then + write (iout,*) "Before merging helices: nhfrag",nhfrag + do i=1,nhfrag + write (2,*) hfrag(1,i),hfrag(2,i) + enddo + i=1 + do while (i.lt.nhfrag) + if (hfrag(1,i+1)-hfrag(2,i).le.1) then + nhfrag=nhfrag-1 + hfrag(2,i)=hfrag(2,i+1) + do j=i+1,nhfrag + hfrag(1,j)=hfrag(1,j+1) + hfrag(2,j)=hfrag(2,j+1) + enddo + endif + i=i+1 + enddo + write (iout,*) "After merging helices: nhfrag",nhfrag + do i=1,nhfrag + write (2,*) hfrag(1,i),hfrag(2,i) + enddo + endif + nfrag(1)=nhfrag + do i=1,nhfrag + npiece(i,1)=1 + ifrag(1,1,i)=hfrag(1,i) + ifrag(2,1,i)=hfrag(2,i) + n_shift(1,i,1)=0 + n_shift(2,i,1)=nshift_hel + ang_cut(i)=angcut_hel + ang_cut1(i)=angcut1_hel + frac_min(i)=frac_min_set + nc_fragm(i,1)=ncfrac_hel + nc_req_setf(i,1)=ncreq_hel + istruct(i)=1 + enddo + write (iout,*) "isplit_bet",isplit_bet + if (isplit_bet.gt.1) then +c Split beta-sheets into strands and store strands as primary fragments. + call split_beta(nbfrag,bfrag,nstrand,istrand,nhairp,ihairp) + do i=1,nstrand + ii=i+nfrag(1) + npiece(ii,1)=1 + ifrag(1,1,ii)=istrand(1,i) + ifrag(2,1,ii)=istrand(2,i) + n_shift(1,ii,1)=nshift_strand + n_shift(2,ii,1)=nshift_strand + ang_cut(ii)=angcut_strand + ang_cut1(ii)=angcut1_strand + frac_min(ii)=frac_min_set + nc_fragm(ii,1)=0 + nc_req_setf(ii,1)=0 + istruct(ii)=3 + enddo + nfrag(1)=nfrag(1)+nstrand + else if (isplit_bet.eq.1) then +c Split only far beta-sheets; does not split hairpins. + call find_and_remove_hairpins(nbfrag,bfrag,nhairp,ihairp) + call split_beta(nbfrag,bfrag,nstrand,istrand,nhairp,ihairp) + do i=1,nhairp + ii=i+nfrag(1) + npiece(ii,1)=1 + ifrag(1,1,ii)=ihairp(1,i) + ifrag(2,1,ii)=ihairp(2,i) + n_shift(1,ii,1)=nshift_bet + n_shift(2,ii,1)=nshift_bet + ang_cut(ii)=angcut_bet + ang_cut1(ii)=angcut1_bet + frac_min(ii)=frac_min_set + nc_fragm(ii,1)=ncfrac_bet + nc_req_setf(ii,1)=ncreq_bet + istruct(ii)=2 + enddo + nfrag(1)=nfrag(1)+nhairp + do i=1,nstrand + ii=i+nfrag(1) + npiece(ii,1)=1 + ifrag(1,1,ii)=istrand(1,i) + ifrag(2,1,ii)=istrand(2,i) + n_shift(1,ii,1)=nshift_strand + n_shift(2,ii,1)=nshift_strand + ang_cut(ii)=angcut_strand + ang_cut1(ii)=angcut1_strand + frac_min(ii)=frac_min_set + nc_fragm(ii,1)=0 + nc_req_setf(ii,1)=0 + istruct(ii)=3 + enddo + nfrag(1)=nfrag(1)+nstrand + else +c Do not split beta-sheets; each pair of strands is a primary element. + call find_and_remove_hairpins(nbfrag,bfrag,nhairp,ihairp) + do i=1,nhairp + ii=i+nfrag(1) + npiece(ii,1)=1 + ifrag(1,1,ii)=ihairp(1,i) + ifrag(2,1,ii)=ihairp(2,i) + n_shift(1,ii,1)=nshift_bet + n_shift(2,ii,1)=nshift_bet + ang_cut(ii)=angcut_bet + ang_cut1(ii)=angcut1_bet + frac_min(ii)=frac_min_set + nc_fragm(ii,1)=ncfrac_bet + nc_req_setf(ii,1)=ncreq_bet + istruct(ii)=2 + enddo + nfrag(1)=nfrag(1)+nhairp + do i=1,nbfrag + ii=i+nfrag(1) + npiece(ii,1)=2 + ifrag(1,1,ii)=bfrag(1,i) + ifrag(2,1,ii)=bfrag(2,i) + if (bfrag(3,i).lt.bfrag(4,i)) then + ifrag(1,2,ii)=bfrag(3,i) + ifrag(2,2,ii)=bfrag(4,i) + else + ifrag(1,2,ii)=bfrag(4,i) + ifrag(2,2,ii)=bfrag(3,i) + endif + n_shift(1,ii,1)=nshift_bet + n_shift(2,ii,1)=nshift_bet + ang_cut(ii)=angcut_bet + ang_cut1(ii)=angcut1_bet + frac_min(ii)=frac_min_set + nc_fragm(ii,1)=ncfrac_bet + nc_req_setf(ii,1)=ncreq_bet + istruct(ii)=4 + enddo + nfrag(1)=nfrag(1)+nbfrag + endif + write (iout,*) "The following primary fragments were found:" + write (iout,*) "Helices:",nhfrag + do i=1,nhfrag + i1=ifrag(1,1,i) + i2=ifrag(2,1,i) + it1=itype(i1) + it2=itype(i2) + write (iout,'(i3,2x,a,i4,2x,a,i4)') + & i,restyp(it1),i1,restyp(it2),i2 + enddo + write (iout,*) "Hairpins:",nhairp + do i=nhfrag+1,nhfrag+nhairp + i1=ifrag(1,1,i) + i2=ifrag(2,1,i) + it1=itype(i1) + it2=itype(i2) + write (iout,'(i3,2x,a,i4,2x,a,i4,2x)') + & i,restyp(it1),i1,restyp(it2),i2 + enddo + write (iout,*) "Far strand pairs:",nbfrag + do i=nhfrag+nhairp+1,nhfrag+nhairp+nbfrag + i1=ifrag(1,1,i) + i2=ifrag(2,1,i) + it1=itype(i1) + it2=itype(i2) + i3=ifrag(1,2,i) + i4=ifrag(2,2,i) + it3=itype(i3) + it4=itype(i4) + write (iout,'(i3,2x,a,i4,2x,a,i4," and ",a,i4,2x,a,i4)') + & i,restyp(it1),i1,restyp(it2),i2, + & restyp(it3),i3,restyp(it4),i4 + enddo + write (iout,*) "Strands:",nstrand + do i=nhfrag+nhairp+nbfrag+1,nfrag(1) + i1=ifrag(1,1,i) + i2=ifrag(2,1,i) + it1=itype(i1) + it2=itype(i2) + write (iout,'(i3,2x,a,i4,2x,a,i4)') + & i,restyp(it1),i1,restyp(it2),i2 + enddo + call imysort(nfrag(1),2,maxpiece,ifrag(1,1,1),npiece(1,1), + & istruct(1),n_shift(1,1,1),ang_cut(1),ang_cut1(1),frac_min(1), + & nc_fragm(1,1),nc_req_setf(1,1)) + write (iout,*) "Fragments after sorting:" + do i=1,nfrag(1) + i1=ifrag(1,1,i) + i2=ifrag(2,1,i) + it1=itype(i1) + it2=itype(i2) + write (iout,'(i3,2x,a,i4,2x,a,i4,$)') + & i,restyp(it1),i1,restyp(it2),i2 + if (npiece(i,1).eq.1) then + write (iout,'(2x,a)') strstr(istruct(i)) + else + i1=ifrag(1,2,i) + i2=ifrag(2,2,i) + it1=itype(i1) + it2=itype(i2) + write (iout,'(2x,a,i4,2x,a,i4,2x,a)') + & restyp(it1),i1,restyp(it2),i2,strstr(istruct(i)) + endif + enddo + return + end +c------------------------------------------------------------------------------ + subroutine find_and_remove_hairpins(nbfrag,bfrag,nhairp,ihairp) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.COMPAR' + include 'COMMON.IOUNITS' + integer nbfrag,bfrag(4,maxres/3) + integer nhairp,ihairp(2,maxres/5) + write (iout,*) "Entered find_and_remove_hairpins" + write (iout,*) "nbfrag",nbfrag + do i=1,nbfrag + write (iout,*) i,(bfrag(k,i),k=1,4) + enddo + nhairp=0 + i=1 + do while (i.le.nbfrag) + write (iout,*) "check hairpin:",i,(bfrag(j,i),j=1,4) + if (bfrag(3,i).gt.bfrag(4,i) .and. bfrag(4,i)-bfrag(2,i).lt.5) + & then + write (iout,*) "Found hairpin:",i,bfrag(1,i),bfrag(3,i) + nhairp=nhairp+1 + ihairp(1,nhairp)=bfrag(1,i) + ihairp(2,nhairp)=bfrag(3,i) + nbfrag=nbfrag-1 + do j=i,nbfrag + do k=1,4 + bfrag(k,j)=bfrag(k,j+1) + enddo + enddo + else + i=i+1 + endif + enddo + write (iout,*) "After finding hairpins:" + write (iout,*) "nhairp",nhairp + do i=1,nhairp + write (iout,*) i,ihairp(1,i),ihairp(2,i) + enddo + write (iout,*) "nbfrag",nbfrag + do i=1,nbfrag + write (iout,*) i,(bfrag(k,i),k=1,4) + enddo + return + end +c------------------------------------------------------------------------------ + subroutine split_beta(nbfrag,bfrag,nstrand,istrand,nhairp,ihairp) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.COMPAR' + include 'COMMON.IOUNITS' + integer nbfrag,bfrag(4,maxres/3) + integer nstrand,istrand(2,maxres/2) + integer nhairp,ihairp(2,maxres/5) + logical found + write (iout,*) "Entered split_beta" + write (iout,*) "nbfrag",nbfrag + do i=1,nbfrag + write (iout,*) i,(bfrag(k,i),k=1,4) + enddo + nstrand=0 + do i=1,nbfrag + write (iout,*) "calling add_strand:",i,bfrag(1,i),bfrag(2,i) + call add_strand(nstrand,istrand,nhairp,ihairp, + & bfrag(1,i),bfrag(2,i),found) + if (bfrag(3,i).lt.bfrag(4,i)) then + write (iout,*) "calling add_strand:",i,bfrag(3,i),bfrag(4,i) + call add_strand(nstrand,istrand,nhairp,ihairp, + & bfrag(3,i),bfrag(4,i),found) + else + write (iout,*) "calling add_strand:",i,bfrag(4,i),bfrag(3,i) + call add_strand(nstrand,istrand,nhairp,ihairp, + & bfrag(4,i),bfrag(3,i),found) + endif + enddo + nbfrag=0 + write (iout,*) "Strands found:",nstrand + do i=1,nstrand + write (iout,*) i,istrand(1,i),istrand(2,i) + enddo + return + end +c------------------------------------------------------------------------------ + subroutine add_strand(nstrand,istrand,nhairp,ihairp,is1,is2,found) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.COMPAR' + include 'COMMON.IOUNITS' + integer nstrand,istrand(2,maxres/2) + integer nhairp,ihairp(2,maxres/5) + logical found + found=.false. + do j=1,nhairp + idelt=(ihairp(2,j)-ihairp(1,j))/6 + if (is1.lt.ihairp(2,j)-idelt.and.is2.gt.ihairp(1,j)+idelt) then + write (iout,*) "strand",is1,is2," is part of hairpin", + & ihairp(1,j),ihairp(2,j) + return + endif + enddo + do j=1,nstrand + idelt=(istrand(2,j)-istrand(1,j))/3 + if (is1.lt.istrand(2,j)-idelt.and.is2.gt.istrand(1,j)+idelt) + & then +c The strand already exists in the array; update its ends if necessary. + write (iout,*) "strand",is1,is2," found at position",j, + & ":",istrand(1,j),istrand(2,j) + istrand(1,j)=min0(istrand(1,j),is1) + istrand(2,j)=max0(istrand(2,j),is2) + return + endif + enddo +c The strand has not been found; add it to the array. + write (iout,*) "strand",is1,is2," added to the array." + found=.true. + nstrand=nstrand+1 + istrand(1,nstrand)=is1 + istrand(2,nstrand)=is2 + return + end +c------------------------------------------------------------------------------ + subroutine secondary2(lprint,lprint_sec,ncont,icont,isecstr) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.FRAG' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.INTERACT' + integer ncont,icont(2,maxcont),isec(maxres,4),nsec(maxres), + & isecstr(maxres) + logical lprint,lprint_sec,not_done,freeres + double precision p1,p2 + external freeres + character*1 csec(0:2) /'-','E','H'/ + if (lprint) then + write (iout,*) "entered secondary2",ncont + write (iout,*) "nstart_sup",nstart_sup," nend_sup",nend_sup + do i=1,ncont + write (iout,*) icont(1,i),icont(2,i) + enddo + endif + do i=1,nres + isecstr(i)=0 + enddo + nbfrag=0 + nhfrag=0 + do i=1,nres + isec(i,1)=0 + isec(i,2)=0 + nsec(i)=0 + enddo + +c finding parallel beta +cd write (iout,*) '------- looking for parallel beta -----------' + nbeta=0 + nstrand=0 + do i=1,ncont + i1=icont(1,i) + j1=icont(2,i) + if (i1.ge.nstart_sup .and. i1.le.nend_sup + & .and. j1.gt.nstart_sup .and. j1.le.nend_sup) then +cd write (iout,*) "parallel",i1,j1 + if(j1-i1.gt.5 .and. freeres(i1,j1,nsec,isec)) then + ii1=i1 + jj1=j1 +cd write (iout,*) i1,j1 + not_done=.true. + do while (not_done) + i1=i1+1 + j1=j1+1 + do j=1,ncont + if (i1.eq.icont(1,j) .and. j1.eq.icont(2,j) .and. + & freeres(i1,j1,nsec,isec)) goto 5 + enddo + not_done=.false. + 5 continue +cd write (iout,*) i1,j1,not_done + enddo + j1=j1-1 + i1=i1-1 + if (i1-ii1.gt.1) then + ii1=max0(ii1-1,1) + jj1=max0(jj1-1,1) + nbeta=nbeta+1 + if(lprint)write(iout,'(a,i3,4i4)')'parallel beta', + & nbeta,ii1,i1,jj1,j1 + + nbfrag=nbfrag+1 + bfrag(1,nbfrag)=ii1+1 + bfrag(2,nbfrag)=i1+1 + bfrag(3,nbfrag)=jj1+1 + bfrag(4,nbfrag)=min0(j1+1,nres) + + do ij=ii1,i1 + nsec(ij)=nsec(ij)+1 + isec(ij,nsec(ij))=nbeta + enddo + do ij=jj1,j1 + nsec(ij)=nsec(ij)+1 + isec(ij,nsec(ij))=nbeta + enddo + + if(lprint_sec) then + nstrand=nstrand+1 + if (nbeta.le.9) then + write(12,'(a18,i1,a9,i3,a2,i3,a1)') + & "DefPropRes 'strand",nstrand, + & "' 'num = ",ii1-1,"..",i1-1,"'" + else + write(12,'(a18,i2,a9,i3,a2,i3,a1)') + & "DefPropRes 'strand",nstrand, + & "' 'num = ",ii1-1,"..",i1-1,"'" + endif + nstrand=nstrand+1 + if (nbeta.le.9) then + write(12,'(a18,i1,a9,i3,a2,i3,a1)') + & "DefPropRes 'strand",nstrand, + & "' 'num = ",jj1-1,"..",j1-1,"'" + else + write(12,'(a18,i2,a9,i3,a2,i3,a1)') + & "DefPropRes 'strand",nstrand, + & "' 'num = ",jj1-1,"..",j1-1,"'" + endif + write(12,'(a8,4i4)') + & "SetNeigh",ii1-1,i1-1,jj1-1,j1-1 + endif + endif + endif + endif ! i1.ge.nstart_sup .and. i1.le.nend_sup .and. i2.gt.nstart_sup .and. i2.le.nend_sup + enddo + +c finding antiparallel beta +cd write (iout,*) '--------- looking for antiparallel beta ---------' + + do i=1,ncont + i1=icont(1,i) + j1=icont(2,i) + if (freeres(i1,j1,nsec,isec)) then + ii1=i1 + jj1=j1 +cd write (iout,*) i1,j1 + + not_done=.true. + do while (not_done) + i1=i1+1 + j1=j1-1 + do j=1,ncont + if (i1.eq.icont(1,j).and.j1.eq.icont(2,j) .and. + & freeres(i1,j1,nsec,isec)) goto 6 + enddo + not_done=.false. + 6 continue +cd write (iout,*) i1,j1,not_done + enddo + i1=i1-1 + j1=j1+1 + if (i1-ii1.gt.1) then + + nbfrag=nbfrag+1 + bfrag(1,nbfrag)=ii1 + bfrag(2,nbfrag)=min0(i1+1,nres) + bfrag(3,nbfrag)=min0(jj1+1,nres) + bfrag(4,nbfrag)=j1 + + nbeta=nbeta+1 + iii1=max0(ii1-1,1) + do ij=iii1,i1 + nsec(ij)=nsec(ij)+1 + if (nsec(ij).le.2) then + isec(ij,nsec(ij))=nbeta + endif + enddo + jjj1=max0(j1-1,1) + do ij=jjj1,jj1 + nsec(ij)=nsec(ij)+1 + if (nsec(ij).le.2) then + isec(ij,nsec(ij))=nbeta + endif + enddo + + + if (lprint_sec) then + write (iout,'(a,i3,4i4)')'antiparallel beta', + & nbeta,ii1-1,i1,jj1,j1-1 + nstrand=nstrand+1 + if (nstrand.le.9) then + write(12,'(a18,i1,a9,i3,a2,i3,a1)') + & "DefPropRes 'strand",nstrand, + & "' 'num = ",ii1-2,"..",i1-1,"'" + else + write(12,'(a18,i2,a9,i3,a2,i3,a1)') + & "DefPropRes 'strand",nstrand, + & "' 'num = ",ii1-2,"..",i1-1,"'" + endif + nstrand=nstrand+1 + if (nstrand.le.9) then + write(12,'(a18,i1,a9,i3,a2,i3,a1)') + & "DefPropRes 'strand",nstrand, + & "' 'num = ",j1-2,"..",jj1-1,"'" + else + write(12,'(a18,i2,a9,i3,a2,i3,a1)') + & "DefPropRes 'strand",nstrand, + & "' 'num = ",j1-2,"..",jj1-1,"'" + endif + write(12,'(a8,4i4)') + & "SetNeigh",ii1-2,i1-1,jj1-1,j1-2 + endif + endif + endif + enddo + +cd write (iout,*) "After beta:",nbfrag +cd do i=1,nbfrag +cd write (iout,*) (bfrag(j,i),j=1,4) +cd enddo + + if (nstrand.gt.0.and.lprint_sec) then + write(12,'(a27,$)') "DefPropRes 'sheet' 'strand1" + do i=2,nstrand + if (i.le.9) then + write(12,'(a9,i1,$)') " | strand",i + else + write(12,'(a9,i2,$)') " | strand",i + endif + enddo + write(12,'(a1)') "'" + endif + + +c finding alpha or 310 helix + + nhelix=0 + do i=1,ncont + i1=icont(1,i) + j1=icont(2,i) + p1=phi(i1+2)*rad2deg + p2=0.0 + if (j1+2.le.nres) p2=phi(j1+2)*rad2deg + + + if (j1.eq.i1+3 .and. + & ((p1.ge.10.and.p1.le.80).or.i1.le.2).and. + & ((p2.ge.10.and.p2.le.80).or.j1.le.2.or.j1.ge.nres-3) )then +cd if (j1.eq.i1+3) write (iout,*) "found 1-4 ",i1,j1,p1,p2 +co if (j1.eq.i1+4) write (iout,*) "found 1-5 ",i1,j1,p1,p2 + ii1=i1 + jj1=j1 + if (nsec(ii1).eq.0) then + not_done=.true. + else + not_done=.false. + endif + do while (not_done) + i1=i1+1 + j1=j1+1 + do j=1,ncont + if (i1.eq.icont(1,j) .and. j1.eq.icont(2,j)) goto 10 + enddo + not_done=.false. + 10 continue + p1=phi(i1+2)*rad2deg + p2=phi(j1+2)*rad2deg + if (p1.lt.10.or.p1.gt.80.or.p2.lt.10.or.p2.gt.80) + & not_done=.false. + +cd write (iout,*) i1,j1,not_done,p1,p2 + enddo + j1=j1+1 + if (j1-ii1.gt.4) then + nhelix=nhelix+1 +cd write (iout,*)'helix',nhelix,ii1,j1 + + nhfrag=nhfrag+1 + hfrag(1,nhfrag)=ii1 + hfrag(2,nhfrag)=j1 + + do ij=ii1,j1 + nsec(ij)=-1 + enddo + if (lprint_sec) then + write (iout,'(a,i3,2i4)') "Helix",nhelix,ii1-1,j1-1 + if (nhelix.le.9) then + write(12,'(a17,i1,a9,i3,a2,i3,a1)') + & "DefPropRes 'helix",nhelix, + & "' 'num = ",ii1-1,"..",j1-2,"'" + else + write(12,'(a17,i2,a9,i3,a2,i3,a1)') + & "DefPropRes 'helix",nhelix, + & "' 'num = ",ii1-1,"..",j1-2,"'" + endif + endif + endif + endif + enddo + + if (nhelix.gt.0.and.lprint_sec) then + write(12,'(a26,$)') "DefPropRes 'helix' 'helix1" + do i=2,nhelix + if (nhelix.le.9) then + write(12,'(a8,i1,$)') " | helix",i + else + write(12,'(a8,i2,$)') " | helix",i + endif + enddo + write(12,'(a1)') "'" + endif + + if (lprint_sec) then + write(12,'(a37)') "DefPropRes 'coil' '! (helix | sheet)'" + write(12,'(a20)') "XMacStand ribbon.mac" + endif + + if (lprint) then + + write(iout,*) 'UNRES seq:' + do j=1,nbfrag + write(iout,*) 'beta ',(bfrag(i,j),i=1,4) + enddo + + do j=1,nhfrag + write(iout,*) 'helix ',(hfrag(i,j),i=1,2) + enddo + + endif + + do j=1,nbfrag + do k=min0(bfrag(1,j),bfrag(2,j)),max0(bfrag(1,j),bfrag(2,j)) + isecstr(k)=1 + enddo + do k=min0(bfrag(3,j),bfrag(4,j)),max0(bfrag(3,j),bfrag(4,j)) + isecstr(k)=1 + enddo + enddo + do j=1,nhfrag + do k=hfrag(1,j),hfrag(2,j) + isecstr(k)=2 + enddo + enddo + if (lprint) then + write (iout,*) + write (iout,*) "Secondary structure" + do i=1,nres,80 + ist=i + ien=min0(i+79,nres) + write (iout,*) + write (iout,'(8(7x,i3))') (k,k=ist+9,ien,10) + write (iout,'(80a1)') (onelet(itype(k)),k=ist,ien) + write (iout,'(80a1)') (csec(isecstr(k)),k=ist,ien) + enddo + write (iout,*) + endif + return + end +c------------------------------------------------- + logical function freeres(i,j,nsec,isec) + include 'DIMENSIONS' + integer isec(maxres,4),nsec(maxres) + freeres=.false. + + if (nsec(i).gt.1.or.nsec(j).gt.1) return + do k=1,nsec(i) + do l=1,nsec(j) + if (isec(i,k).eq.isec(j,l)) return + enddo + enddo + freeres=.true. + return + end + diff --git a/source/wham/src-NEWSC-NEWCORR/setup_var.f b/source/wham/src-NEWSC-NEWCORR/setup_var.f new file mode 100644 index 0000000..f052400 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/setup_var.f @@ -0,0 +1,31 @@ + subroutine setup_var + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' +C Set up variable list. + ntheta=nres-2 + nphi=nres-3 + nvar=ntheta+nphi + nside=0 + do i=2,nres-1 + if (itype(i).ne.10) then + nside=nside+1 + ialph(i,1)=nvar+nside + ialph(nside,2)=i + endif + enddo + if (indphi.gt.0) then + nvar=nphi + else if (indback.gt.0) then + nvar=nphi+ntheta + else + nvar=nvar+2*nside + endif +cd write (iout,'(3i4)') (i,ialph(i,1),ialph(i,2),i=2,nres-1) + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/slices.F b/source/wham/src-NEWSC-NEWCORR/slices.F new file mode 100644 index 0000000..b22ea13 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/slices.F @@ -0,0 +1,80 @@ + subroutine set_slices(is,ie,ts,te,iR,ib,iparm) + implicit none + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.FREE' + include 'COMMON.IOUNITS' + include 'COMMON.PROTFILES' + include 'COMMON.OBCINKA' + include 'COMMON.PROT' + integer islice,iR,ib,iparm + integer is(MaxSlice),ie(MaxSlice),nrec_slice + double precision ts(MaxSlice),te(MaxSlice),time_slice + + do islice=1,nslice + if (time_end_collect(iR,ib,iparm).ge.1.0d10) then + ts(islice)=time_start_collect(iR,ib,iparm) + te(islice)=time_end_collect(iR,ib,iparm) + nrec_slice=(rec_end(iR,ib,iparm)- + & rec_start(iR,ib,iparm)+1)/nslice + is(islice)=rec_start(iR,ib,iparm)+(islice-1)*nrec_slice + ie(islice)=rec_start(iR,ib,iparm)+islice*nrec_slice-1 + else + time_slice=(time_end_collect(iR,ib,iparm) + & -time_start_collect(iR,ib,iparm))/nslice + ts(islice)=time_start_collect(iR,ib,iparm)+(islice-1)* + & time_slice + te(islice)=time_start_collect(iR,ib,iparm)+islice*time_slice + is(islice)=rec_start(iR,ib,iparm) + ie(islice)=rec_end(iR,ib,iparm) + endif + enddo + + write (iout,*) "nrec_slice",nrec_slice," time_slice",time_slice + write (iout,*) "is",(is(islice),islice=1,nslice) + write (iout,*) "ie",(ie(islice),islice=1,nslice) + write (iout,*) "rec_start", + & rec_start(iR,ib,iparm)," rec_end",rec_end(iR,ib,iparm) + write (iout,*) "ts",(ts(islice),islice=1,nslice) + write (iout,*) "te",(te(islice),islice=1,nslice) + write (iout,*) "time_start", + & time_start_collect(iR,ib,iparm)," time_end", + & time_end_collect(iR,ib,iparm) + call flush(iout) + + return + end +c----------------------------------------------------------------------------- + integer function slice(irecord,time,is,ie,ts,te) + implicit none + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.FREE' + include 'COMMON.IOUNITS' + include 'COMMON.PROTFILES' + include 'COMMON.OBCINKA' + include 'COMMON.PROT' + integer is(MaxSlice),ie(MaxSlice),nrec_slice + double precision ts(MaxSlice),te(MaxSlice),time_slice + integer i,ii,irecord + double precision time + +c write (iout,*) "within slice nslice",nslice +c call flush(iout) + if (irecord.lt.is(1) .or. time.lt.ts(1)) then + ii=0 + else + ii=1 + do while (ii.le.nslice .and. + & (irecord.lt.is(ii) .or. irecord.gt.ie(ii) .or. + & time.lt.ts(ii) .or. time.gt.te(ii)) ) +c write (iout,*) "ii",ii,time,ts(ii) +c call flush(iout) + ii=ii+1 + enddo + endif +c write (iout,*) "end: ii",ii +c call flush(iout) + slice=ii + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/store_parm.F b/source/wham/src-NEWSC-NEWCORR/store_parm.F new file mode 100644 index 0000000..0ededff --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/store_parm.F @@ -0,0 +1,547 @@ + subroutine store_parm(iparm) +C +C Store parameters of set IPARM +C valence angles and the side chains and energy parameters. +C + implicit none + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.FREE' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.FFIELD' + include 'COMMON.NAMES' + include 'COMMON.SBRIDGE' + include 'COMMON.SCROT' + include 'COMMON.SCCOR' + include 'COMMON.ALLPARM' + integer i,j,k,l,m,mm,iparm + +c Store weights + ww_all(1,iparm)=wsc + ww_all(2,iparm)=wscp + ww_all(3,iparm)=welec + ww_all(4,iparm)=wcorr + ww_all(5,iparm)=wcorr5 + ww_all(6,iparm)=wcorr6 + ww_all(7,iparm)=wel_loc + ww_all(8,iparm)=wturn3 + ww_all(9,iparm)=wturn4 + ww_all(10,iparm)=wturn6 + ww_all(11,iparm)=wang + ww_all(12,iparm)=wscloc + ww_all(13,iparm)=wtor + ww_all(14,iparm)=wtor_d + ww_all(15,iparm)=wstrain + ww_all(16,iparm)=wvdwpp + ww_all(17,iparm)=wbond + ww_all(19,iparm)=wsccor +c Store bond parameters + vbldp0_all(iparm)=vbldp0 + akp_all(iparm)=akp + do i=1,ntyp + nbondterm_all(i,iparm)=nbondterm(i) + do j=1,nbondterm(i) + vbldsc0_all(j,i,iparm)=vbldsc0(j,i) + aksc_all(j,i,iparm)=aksc(j,i) + abond0_all(j,i,iparm)=abond0(j,i) + enddo + enddo +c Store bond angle parameters +#ifdef CRYST_THETA + do i=1,ntyp + a0thet_all(i,iparm)=a0thet(i) + do j=1,2 + athet_all(j,i,iparm)=athet(j,i) + bthet_all(j,i,iparm)=bthet(j,i) + enddo + do j=0,3 + polthet_all(j,i,iparm)=polthet(j,i) + enddo + do j=1,3 + gthet_all(j,i,iparm)=gthet(j,i) + enddo + theta0_all(i,iparm)=theta0(i) + sig0_all(i,iparm)=sig0(i) + sigc0_all(i,iparm)=sigc0(i) + enddo +#else + nthetyp_all(iparm)=nthetyp + ntheterm_all(iparm)=ntheterm + ntheterm2_all(iparm)=ntheterm2 + ntheterm3_all(iparm)=ntheterm3 + nsingle_all(iparm)=nsingle + ndouble_all(iparm)=ndouble + nntheterm_all(iparm)=nntheterm + do i=1,ntyp1 + ithetyp_all(i,iparm)=ithetyp(i) + enddo + do i=1,maxthetyp1 + do j=1,maxthetyp1 + do k=1,maxthetyp1 + aa0thet_all(i,j,k,iparm)=aa0thet(i,j,k) + do l=1,ntheterm + aathet_all(l,i,j,k,iparm)=aathet(l,i,j,k) + enddo + do l=1,ntheterm2 + do m=1,nsingle + bbthet_all(m,l,i,j,k,iparm)=bbthet(m,l,i,j,k) + ccthet_all(m,l,i,j,k,iparm)=ccthet(m,l,i,j,k) + ddthet_all(m,l,i,j,k,iparm)=ddthet(m,l,i,j,k) + eethet_all(m,l,i,j,k,iparm)=eethet(m,l,i,j,k) + enddo + enddo + do l=1,ntheterm3 + do m=1,ndouble + do mm=1,ndouble + ffthet_all(mm,m,l,i,j,k,iparm)=ffthet(mm,m,l,i,j,k) + ggthet_all(mm,m,l,i,j,k,iparm)=ggthet(mm,m,l,i,j,k) + enddo + enddo + enddo + enddo + enddo + enddo +#endif +#ifdef CRYST_SC +c Store the sidechain rotamer parameters + do i=1,ntyp + nlob_all(i,iparm)=nlob(i) + do j=1,nlob(i) + bsc_all(j,i,iparm)=bsc(j,i) + do k=1,3 + censc_all(k,j,i,iparm)=censc(k,j,i) + enddo + do k=1,3 + do l=1,3 + gaussc_all(l,k,j,i,iparm)=gaussc(l,k,j,i) + enddo + enddo + enddo + enddo +#else + do i=1,ntyp + do j=1,65 + sc_parmin_all(j,i,iparm)=sc_parmin(j,i) + enddo + enddo +#endif +c Store the torsional parameters + do i=1,ntortyp + do j=1,ntortyp + v0_all(i,j,iparm)=v0(i,j) + nterm_all(i,j,iparm)=nterm(i,j) + nlor_all(i,j,iparm)=nlor(i,j) + do k=1,nterm(i,j) + v1_all(k,i,j,iparm)=v1(k,i,j) + v2_all(k,i,j,iparm)=v2(i,i,j) + enddo + do k=1,nlor(i,j) + vlor1_all(k,i,j,iparm)=vlor1(k,i,j) + vlor2_all(k,i,j,iparm)=vlor2(k,i,j) + vlor3_all(k,i,j,iparm)=vlor3(k,i,j) + enddo + enddo + enddo +c Store the double torsional parameters + do i=1,ntortyp + do j=1,ntortyp + do k=1,ntortyp + ntermd1_all(i,j,k,iparm)=ntermd_1(i,j,k) + ntermd2_all(i,j,k,iparm)=ntermd_2(i,j,k) + do l=1,ntermd_1(i,j,k) + v1c_all(1,l,i,j,k,iparm)=v1c(1,l,i,j,k) + v1c_all(2,l,i,j,k,iparm)=v1c(2,l,i,j,k) + v2c_all(1,l,i,j,k,iparm)=v2c(1,l,i,j,k) + v2c_all(2,l,i,j,k,iparm)=v2c(2,l,i,j,k) + enddo + do l=1,ntermd_2(i,j,k) + do m=1,ntermd_2(i,j,k) + v2s_all(l,m,i,j,k,iparm)=v2s(l,m,i,j,k) + enddo + enddo + enddo + enddo + enddo +c Store parameters of the cumulants + do i=1,nloctyp + do j=1,2 + b1_all(j,i,iparm)=b1(j,i) + b1tilde_all(j,i,iparm)=b1tilde(j,i) + b2_all(j,i,iparm)=b2(j,i) + enddo + do j=1,2 + do k=1,2 + cc_all(k,j,i,iparm)=cc(k,j,i) + ctilde_all(k,j,i,iparm)=ctilde(k,j,i) + dd_all(k,j,i,iparm)=dd(k,j,i) + dtilde_all(k,j,i,iparm)=dtilde(k,j,i) + ee_all(k,j,i,iparm)=ee(k,j,i) + enddo + enddo + enddo +c Store the parameters of electrostatic interactions + do i=1,2 + do j=1,2 + app_all(j,i,iparm)=app(j,i) + bpp_all(j,i,iparm)=bpp(j,i) + ael6_all(j,i,iparm)=ael6(j,i) + ael3_all(j,i,iparm)=ael3(j,i) + enddo + enddo +c Store sidechain parameters + do i=1,ntyp + do j=1,ntyp + aa_all(j,i,iparm)=aa(j,i) + bb_all(j,i,iparm)=bb(j,i) + r0_all(j,i,iparm)=r0(j,i) + sigma_all(j,i,iparm)=sigma(j,i) + chi_all(j,i,iparm)=chi(j,i) + chipp_all(j,i,iparm)=chipp(j,i) + augm_all(j,i,iparm)=augm(j,i) + eps_all(j,i,iparm)=eps(j,i) + sigmap1_all(j,i,iparm)=sigmap1(j,i) + sigmap2_all(j,i,iparm)=sigmap2(j,i) + chis_all(j,i,iparm)=chis(j,i) + do k=1,4 + alphasur_all(k,j,i,iparm)=alphasur(k,j,i) + wstate_all(k,j,i,iparm)=wstate(k,j,i) + enddo + nstate_all(j,i,iparm)=nstate(j,i) + do k=1,2 + do l=1,2 + dhead_all(l,k,j,i,iparm)=dhead(l,k,j,i) + enddo + enddo + do k=1,2 + dtail_all(k,j,i,iparm)=dtail(k,j,i) + enddo + epshead_all(j,i,iparm)=epshead(j,i) + rborn_all(j,i,iparm)=rborn(j,i) + do k=1,2 + wqdip_all(k,j,i,iparm)=wqdip(k,j,i) + enddo + wquad_all(j,i,iparm)=wquad(j,i) + alphapol_all(j,i,iparm)=alphapol(j,i) + do k=1,4 + alphiso_all(k,j,i,iparm)=alphiso(k,j,i) + enddo + sigiso1_all(j,i,iparm)=sigiso1(j,i) + sigiso2_all(j,i,iparm)=sigiso2(j,i) + epsintab_all(j,i,iparm)=epsintab(j,i) + enddo + enddo + do i=1,ntyp + chip_all(i,iparm)=chip(i) + alp_all(i,iparm)=alp(i) + enddo +c Store the SCp parameters + do i=1,ntyp + do j=1,2 + aad_all(i,j,iparm)=aad(i,j) + bad_all(i,j,iparm)=bad(i,j) + enddo + enddo +c Store disulfide-bond parameters + ebr_all(iparm)=ebr + d0cm_all(iparm)=d0cm + akcm_all(iparm)=akcm + akth_all(iparm)=akth + akct_all(iparm)=akct + v1ss_all(iparm)=v1ss + v2ss_all(iparm)=v2ss + v3ss_all(iparm)=v3ss +c Store SC-backbone correlation parameters + do i=1,nsccortyp + do j=1,nsccortyp + + nterm_sccor_all(j,i,iparm)=nterm_sccor(j,i) + do l=1,3 + do k=1,nterm_sccor(j,i) + v1sccor_all(k,l,j,i,iparm)=v1sccor(k,l,j,i) + v2sccor_all(k,l,j,i,iparm)=v2sccor(k,l,j,i) + enddo + enddo + enddo + enddo + return + end +c-------------------------------------------------------------------------- + subroutine restore_parm(iparm) +C +C Store parameters of set IPARM +C valence angles and the side chains and energy parameters. +C + implicit none + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.FREE' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.FFIELD' + include 'COMMON.NAMES' + include 'COMMON.SBRIDGE' + include 'COMMON.SCROT' + include 'COMMON.SCCOR' + include 'COMMON.ALLPARM' + integer i,j,k,l,m,mm,iparm + +c Restore weights + wsc=ww_all(1,iparm) + wscp=ww_all(2,iparm) + welec=ww_all(3,iparm) + wcorr=ww_all(4,iparm) + wcorr5=ww_all(5,iparm) + wcorr6=ww_all(6,iparm) + wel_loc=ww_all(7,iparm) + wturn3=ww_all(8,iparm) + wturn4=ww_all(9,iparm) + wturn6=ww_all(10,iparm) + wang=ww_all(11,iparm) + wscloc=ww_all(12,iparm) + wtor=ww_all(13,iparm) + wtor_d=ww_all(14,iparm) + wstrain=ww_all(15,iparm) + wvdwpp=ww_all(16,iparm) + wbond=ww_all(17,iparm) + wsccor=ww_all(19,iparm) +c Restore bond parameters + vbldp0=vbldp0_all(iparm) + akp=akp_all(iparm) + do i=1,ntyp + nbondterm(i)=nbondterm_all(i,iparm) + do j=1,nbondterm(i) + vbldsc0(j,i)=vbldsc0_all(j,i,iparm) + aksc(j,i)=aksc_all(j,i,iparm) + abond0(j,i)=abond0_all(j,i,iparm) + enddo + enddo +c Restore bond angle parameters +#ifdef CRYST_THETA + do i=1,ntyp + a0thet(i)=a0thet_all(i,iparm) + do j=1,2 + athet(j,i)=athet_all(j,i,iparm) + bthet(j,i)=bthet_all(j,i,iparm) + enddo + do j=0,3 + polthet(j,i)=polthet_all(j,i,iparm) + enddo + do j=1,3 + gthet(j,i)=gthet_all(j,i,iparm) + enddo + theta0(i)=theta0_all(i,iparm) + sig0(i)=sig0_all(i,iparm) + sigc0(i)=sigc0_all(i,iparm) + enddo +#else + nthetyp=nthetyp_all(iparm) + ntheterm=ntheterm_all(iparm) + ntheterm2=ntheterm2_all(iparm) + ntheterm3=ntheterm3_all(iparm) + nsingle=nsingle_all(iparm) + ndouble=ndouble_all(iparm) + nntheterm=nntheterm_all(iparm) + do i=1,ntyp1 + ithetyp(i)=ithetyp_all(i,iparm) + enddo + do i=1,maxthetyp1 + do j=1,maxthetyp1 + do k=1,maxthetyp1 + aa0thet(i,j,k)=aa0thet_all(i,j,k,iparm) + do l=1,ntheterm + aathet(l,i,j,k)=aathet_all(l,i,j,k,iparm) + enddo + do l=1,ntheterm2 + do m=1,nsingle + bbthet(m,l,i,j,k)=bbthet_all(m,l,i,j,k,iparm) + ccthet(m,l,i,j,k)=ccthet_all(m,l,i,j,k,iparm) + ddthet(m,l,i,j,k)=ddthet_all(m,l,i,j,k,iparm) + eethet(m,l,i,j,k)=eethet_all(m,l,i,j,k,iparm) + enddo + enddo + do l=1,ntheterm3 + do m=1,ndouble + do mm=1,ndouble + ffthet(mm,m,l,i,j,k)=ffthet_all(mm,m,l,i,j,k,iparm) + ggthet(mm,m,l,i,j,k)=ggthet_all(mm,m,l,i,j,k,iparm) + enddo + enddo + enddo + enddo + enddo + enddo +#endif +c Restore the sidechain rotamer parameters +#ifdef CRYST_SC + do i=1,ntyp + nlob(i)=nlob_all(i,iparm) + do j=1,nlob(i) + bsc(j,i)=bsc_all(j,i,iparm) + do k=1,3 + censc(k,j,i)=censc_all(k,j,i,iparm) + enddo + do k=1,3 + do l=1,3 + gaussc(l,k,j,i)=gaussc_all(l,k,j,i,iparm) + enddo + enddo + enddo + enddo +#else + do i=1,ntyp + do j=1,65 + sc_parmin(j,i)=sc_parmin_all(j,i,iparm) + enddo + enddo +#endif +c Restore the torsional parameters + do i=1,ntortyp + do j=1,ntortyp + v0(i,j)=v0_all(i,j,iparm) + nterm(i,j)=nterm_all(i,j,iparm) + nlor(i,j)=nlor_all(i,j,iparm) + do k=1,nterm(i,j) + v1(k,i,j)=v1_all(k,i,j,iparm) + v2(i,i,j)=v2_all(k,i,j,iparm) + enddo + do k=1,nlor(i,j) + vlor1(k,i,j)=vlor1_all(k,i,j,iparm) + vlor2(k,i,j)=vlor2_all(k,i,j,iparm) + vlor3(k,i,j)=vlor3_all(k,i,j,iparm) + enddo + enddo + enddo +c Restore the double torsional parameters + do i=1,ntortyp + do j=1,ntortyp + do k=1,ntortyp + ntermd_1(i,j,k)=ntermd1_all(i,j,k,iparm) + ntermd_2(i,j,k)=ntermd2_all(i,j,k,iparm) + do l=1,ntermd_1(i,j,k) + v1c(1,l,i,j,k)=v1c_all(1,l,i,j,k,iparm) + v1c(2,l,i,j,k)=v1c_all(2,l,i,j,k,iparm) + v2c(1,l,i,j,k)=v2c_all(1,l,i,j,k,iparm) + v2c(2,l,i,j,k)=v2c_all(2,l,i,j,k,iparm) + enddo + do l=1,ntermd_2(i,j,k) + do m=1,ntermd_2(i,j,k) + v2s(l,m,i,j,k)=v2s_all(l,m,i,j,k,iparm) + enddo + enddo + enddo + enddo + enddo +c Restore parameters of the cumulants + do i=1,nloctyp + do j=1,2 + b1(j,i)=b1_all(j,i,iparm) + b1tilde(j,i)=b1tilde_all(j,i,iparm) + b2(j,i)=b2_all(j,i,iparm) + enddo + do j=1,2 + do k=1,2 + cc(k,j,i)=cc_all(k,j,i,iparm) + ctilde(k,j,i)=ctilde_all(k,j,i,iparm) + dd(k,j,i)=dd_all(k,j,i,iparm) + dtilde(k,j,i)=dtilde_all(k,j,i,iparm) + ee(k,j,i)=ee_all(k,j,i,iparm) + enddo + enddo + enddo +c Restore the parameters of electrostatic interactions + do i=1,2 + do j=1,2 + app(j,i)=app_all(j,i,iparm) + bpp(j,i)=bpp_all(j,i,iparm) + ael6(j,i)=ael6_all(j,i,iparm) + ael3(j,i)=ael3_all(j,i,iparm) + enddo + enddo +c Restore sidechain parameters + do i=1,ntyp + do j=1,ntyp + aa(j,i)=aa_all(j,i,iparm) + bb(j,i)=bb_all(j,i,iparm) + r0(j,i)=r0_all(j,i,iparm) + sigma(j,i)=sigma_all(j,i,iparm) + chi(j,i)=chi_all(j,i,iparm) + chipp(j,i)=chipp_all(j,i,iparm) + augm(j,i)=augm_all(j,i,iparm) + eps(j,i)=eps_all(j,i,iparm) + sigmap1(j,i)=sigmap1_all(j,i,iparm) + sigmap2(j,i)=sigmap2_all(j,i,iparm) + chis(j,i)=chis_all(j,i,iparm) + do k=1,4 + alphasur(k,j,i)=alphasur_all(k,j,i,iparm) + wstate(k,j,i)=wstate_all(k,j,i,iparm) + enddo + nstate(j,i)=nstate_all(j,i,iparm) + do k=1,2 + do l=1,2 + dhead(l,k,j,i)=dhead_all(l,k,j,i,iparm) + enddo + enddo + do k=1,2 + dtail(k,j,i)=dtail_all(k,j,i,iparm) + enddo + epshead(j,i)=epshead_all(j,i,iparm) + rborn(j,i)=rborn_all(j,i,iparm) + do k=1,2 + wqdip(k,j,i)=wqdip_all(k,j,i,iparm) + enddo + wquad(j,i)=wquad_all(j,i,iparm) + alphapol(j,i)=alphapol_all(j,i,iparm) + do k=1,4 + alphiso(k,j,i)=alphiso_all(k,j,i,iparm) + enddo + sigiso1(j,i)=sigiso1_all(j,i,iparm) + sigiso2(j,i)=sigiso2_all(j,i,iparm) + epsintab(j,i)=epsintab_all(j,i,iparm) + enddo + enddo + do i=1,ntyp + chip(i)=chip_all(i,iparm) + alp(i)=alp_all(i,iparm) + enddo +c Restore the SCp parameters + do i=1,ntyp + do j=1,2 + aad(i,j)=aad_all(i,j,iparm) + bad(i,j)=bad_all(i,j,iparm) + enddo + enddo +c Restore disulfide-bond parameters + ebr=ebr_all(iparm) + d0cm=d0cm_all(iparm) + akcm=akcm_all(iparm) + akth=akth_all(iparm) + akct=akct_all(iparm) + v1ss=v1ss_all(iparm) + v2ss=v2ss_all(iparm) + v3ss=v3ss_all(iparm) +c Restore SC-backbone correlation parameters + do i=1,nsccortyp + do j=1,nsccortyp + + nterm_sccor(j,i)=nterm_sccor_all(j,i,iparm) +c do i=1,20 +c do j=1,20 + do l=1,3 + do k=1,nterm_sccor(j,i) + v1sccor(k,l,j,i)=v1sccor_all(k,l,j,i,iparm) + v2sccor(k,l,j,i)=v2sccor_all(k,l,j,i,iparm) + enddo + enddo + enddo + enddo + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/timing.F b/source/wham/src-NEWSC-NEWCORR/timing.F new file mode 100644 index 0000000..1012457 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/timing.F @@ -0,0 +1,163 @@ +C $Date: 1994/10/05 16:41:52 $ +C $Revision: 2.2 $ +C +C +C + subroutine set_timers +c + implicit none + double precision tcpu + include 'COMMON.TIME1' +C Diminish the assigned time limit a little so that there is some time to +C end a batch job +c timlim=batime-150.0 +C Calculate the initial time, if it is not zero (e.g. for the SUN). + stime=tcpu() +cd print *,' in SET_TIMERS stime=',stime + return + end +C------------------------------------------------------------------------------ + logical function stopx(nf) +C This function returns .true. in case of time up on the master node. + implicit none + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + integer nf + logical ovrtim +#ifdef MPI + include 'mpif.h' + include 'COMMON.MPI' +#endif + include 'COMMON.IOUNITS' + include 'COMMON.TIME1' + if (ovrtim()) then +C Finish if time is up. + stopx = .true. + WhatsUp=1 + else if (cutoffviol) then + stopx = .true. + WhatsUp=2 + else + stopx=.false. + endif + return + end +C-------------------------------------------------------------------------- + logical function ovrtim() + implicit none + include 'COMMON.TIME1' + real*8 tcpu,curtim + curtim= tcpu() +c print *,'curtim=',curtim,' timlim=',timlim +C curtim is the current time in seconds. +c ovrtim=(curtim .ge. timlim - safety ) +c ovrtim does not work sometimes and crashes the program ! CHUUUJ ! +c setting always to false + ovrtim=.false. + return + end +************************************************************************** + double precision function tcpu() + implicit none + include 'COMMON.TIME1' +#ifdef ES9000 +**************************** +C Next definition for EAGLE (ibm-es9000) + real*8 micseconds + integer rcode + tcpu=cputime(micseconds,rcode) + tcpu=(micseconds/1.0E6) - stime +**************************** +#endif +#ifdef SUN +**************************** +C Next definitions for sun + REAL*8 ECPU,ETIME,ETCPU + dimension tarray(2) + tcpu=etime(tarray) + tcpu=tarray(1) +**************************** +#endif +#ifdef KSR +**************************** +C Next definitions for ksr +C this function uses the ksr timer ALL_SECONDS from the PMON library to +C return the elapsed time in seconds + tcpu= all_seconds() - stime +**************************** +#endif +#ifdef SGI +**************************** +C Next definitions for sgi + real timar(2), etime, seconds + seconds = etime(timar) +Cd print *,'seconds=',seconds,' stime=',stime +C usrsec = timar(1) +C syssec = timar(2) + tcpu=seconds - stime +**************************** +#endif + +#ifdef LINUX +**************************** +C Next definitions for sgi + real timar(2), etime, seconds + seconds = etime(timar) +Cd print *,'seconds=',seconds,' stime=',stime +C usrsec = timar(1) +C syssec = timar(2) + tcpu=seconds - stime +**************************** +#endif + + +#ifdef CRAY +**************************** +C Next definitions for Cray +C call date(curdat) +C curdat=curdat(1:9) +C call clock(curtim) +C curtim=curtim(1:8) + cpusec = second() + tcpu=cpusec - stime +**************************** +#endif +#ifdef AIX +**************************** +C Next definitions for RS6000 + integer*4 i1,mclock + i1 = mclock() + tcpu = (i1+0.0D0)/100.0D0 +#endif +#ifdef WIN +**************************** +c next definitions for windows NT Digital fortran + real time_real + call cpu_time(time_real) + tcpu = time_real +#endif + + return + end +C--------------------------------------------------------------------------- + subroutine dajczas(rntime,hrtime,mintime,sectime) + implicit none + include 'COMMON.IOUNITS' + integer ihr,imn,isc + real*8 rntime,hrtime,mintime,sectime + hrtime=rntime/3600.0D0 + hrtime=aint(hrtime) + mintime=aint((rntime-3600.0D0*hrtime)/60.0D0) + sectime=aint((rntime-3600.0D0*hrtime-60.0D0*mintime)+0.5D0) + if (sectime.eq.60.0D0) then + sectime=0.0D0 + mintime=mintime+1.0D0 + endif + ihr=hrtime + imn=mintime + isc=sectime + write (iout,328) ihr,imn,isc + 328 FORMAT(//'***** Computation time: ',I4 ,' hours ',I2 , + 1 ' minutes ', I2 ,' seconds *****') + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/wham_calc1.F b/source/wham/src-NEWSC-NEWCORR/wham_calc1.F new file mode 100644 index 0000000..57a41d3 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/wham_calc1.F @@ -0,0 +1,1454 @@ + subroutine WHAM_CALC(islice,*) +! Weighed Histogram Analysis Method (WHAM) code +! Written by A. Liwo based on the work of Kumar et al., +! J.Comput.Chem., 13, 1011 (1992) +! +! 2/1/05 Multiple temperatures allowed. +! 2/2/05 Free energies calculated directly from data points +! acc. to Eq. (21) of Kumar et al.; final histograms also +! constructed based on this equation. +! 2/12/05 Multiple parameter sets included +! +! 2/2/05 Parallel version + implicit none + include "DIMENSIONS" + include "DIMENSIONS.ZSCOPT" + include "DIMENSIONS.FREE" + integer MaxBinRms,MaxBinRgy + parameter (MaxBinRms=100,MaxBinRgy=100) + integer MaxHdim +c parameter (MaxHdim=200000) + parameter (MaxHdim=100) + integer maxinde + parameter (maxinde=100) +#ifdef MPI + include "mpif.h" + include "COMMON.MPI" + integer ierror,errcode,status(MPI_STATUS_SIZE) +#endif + include "COMMON.CONTROL" + include "COMMON.IOUNITS" + include "COMMON.FREE" + include "COMMON.ENERGIES" + include "COMMON.FFIELD" + include "COMMON.SBRIDGE" + include "COMMON.PROT" + include "COMMON.ENEPS" + integer MaxPoint,MaxPointProc + parameter (MaxPoint=MaxStr, + & MaxPointProc=MaxStr_Proc) + double precision finorm_max,potfac,entmin,entmax,expfac,vf + double precision entfac_min,entfac_min_t + parameter (finorm_max=1.0d0) + integer islice + integer i,ii,j,jj,k,kk,l,m,ind,iter,t,tmax,ient,ientmax,iln + integer start,end,iharm,ib,iib,nbin1,nbin,nbin_rms,nbin_rgy, + & nbin_rmsrgy,liczba,iparm,nFi,indrgy,indrms + integer htot(0:MaxHdim),histent(0:2000) + double precision v(MaxPointProc,MaxR,MaxT_h,Max_Parm) + double precision energia(0:max_ene) +#ifdef MPI + integer tmax_t,upindE_p + double precision fi_p(MaxR,MaxT_h,Max_Parm), + & fi_p_min(MaxR,MaxT_h,Max_Parm) + double precision sumW_p(0:Max_GridT,Max_Parm), + & sumE_p(0:Max_GridT,Max_Parm),sumEsq_p(0:Max_GridT,Max_Parm), + & sumQ_p(MaxQ1,0:Max_GridT,Max_Parm), + & sumQsq_p(MaxQ1,0:Max_GridT,Max_Parm), + & sumEQ_p(MaxQ1,0:Max_GridT,Max_Parm), + & sumEprim_p(MaxQ1,0:Max_GridT,Max_Parm), + & sumEbis_p(0:Max_GridT,Max_Parm) + double precision hfin_p(0:MaxHdim,maxT_h), + & hfin_ent_p(0:MaxHdim),histE_p(0:maxindE),sumH, + & hrmsrgy_p(0:MaxBinRgy,0:MaxBinRms,maxT_h) + double precision rgymin_t,rmsmin_t,rgymax_t,rmsmax_t + double precision potEmin_t_all(maxT_h,Max_Parm),entmin_p,entmax_p + integer histent_p(0:2000) + logical lprint /.true./ +#endif + double precision rgymin,rmsmin,rgymax,rmsmax + double precision sumW(0:NGridT,Max_Parm),sumE(0:NGridT,Max_Parm), + & sumEsq(0:NGridT,Max_Parm),sumQ(MaxQ1,0:NGridT,Max_Parm), + & sumQsq(MaxQ1,0:NGridT,Max_Parm),sumEQ(MaxQ1,0:NGridT,Max_Parm), + & sumEprim(0:NGridT,Max_Parm),sumEbis(0:NGridT,Max_Parm),betaT, + & weight,econstr + double precision fi(MaxR,maxT_h,Max_Parm), + & fi_min(MaxR,maxT_h,Max_Parm), + & dd,dd1,dd2,hh,dmin,denom,finorm,avefi,pom, + & hfin(0:MaxHdim,maxT_h),histE(0:maxindE), + & hrmsrgy(0:MaxBinRgy,0:MaxBinRms,maxT_h), + & potEmin_all(maxT_h,Max_Parm),potEmin,potEmin_min,ent, + & hfin_ent(0:MaxHdim),vmax,aux + double precision fT(6),fTprim(6),fTbis(6),quot,quotl1,quotl,kfacl, + & eprim,ebis,temper,kfac/2.4d0/,T0/300.0d0/, + & eplus,eminus,logfac,tanhT,tt + double precision etot,evdw,evdw_t,evdw2,ees,evdw1,ebe,etors, + & escloc,ehpb,ecorr,ecorr5,ecorr6,eello_turn4,eello_turn3, + & eturn6,eel_loc,edihcnstr,etors_d,estr,evdw2_14,esccor + + integer ind_point(maxpoint),upindE,indE + character*16 plik + character*1 licz1 + character*2 licz2 + character*3 licz3 + character*128 nazwa + integer ilen + external ilen + + write (iout,*) "Enter WHAM_calc" + call flush(iout) + write(licz2,'(bz,i2.2)') islice + nbin1 = 1.0d0/delta + write (iout,'(//80(1h-)/"Solving WHAM equations for slice", + & i2/80(1h-)//)') islice + write (iout,*) "delta",delta," nbin1",nbin1 + write (iout,*) "MaxN",MaxN," MaxQ",MaxQ," MaHdim",MaxHdim + call flush(iout) + dmin=0.0d0 + tmax=0 + do i=1,nParmset + do j=1,nT_h(i) + potEmin_all(j,i)=1.0d10 + enddo + enddo + rgymin=1.0d10 + rmsmin=1.0d10 + rgymax=0.0d0 + rmsmax=0.0d0 + do t=0,MaxN + htot(t)=0 + enddo +#ifdef MPI + do i=1,scount(me1) +#else + do i=1,ntot(islice) +#endif + if (q(nQ+1,i).lt.rmsmin) rmsmin=q(nQ+1,i) + if (q(nQ+1,i).gt.rmsmax) rmsmax=q(nQ+1,i) + if (q(nQ+2,i).lt.rgymin) rgymin=q(nQ+2,i) + if (q(nQ+2,i).gt.rgymax) rgymax=q(nQ+2,i) + ind_point(i)=0 + do j=nQ,1,-1 + ind=(q(j,i)-dmin+1.0d-8)/delta + if (j.eq.1) then + ind_point(i)=ind_point(i)+ind + else + ind_point(i)=ind_point(i)+nbin1**(j-1)*ind + endif + if (ind_point(i).lt.0 .or. ind_point(i).gt.MaxHdim) then + write (iout,*) "Error - index exceeds range for point",i, + & " q=",q(j,i)," ind",ind_point(i) +#ifdef MPI + write (iout,*) "Processor",me1 + call flush(iout) + call MPI_Abort(MPI_COMM_WORLD, Ierror, Errcode ) +#endif + stop + endif + enddo ! j + if (ind_point(i).gt.tmax) tmax=ind_point(i) + htot(ind_point(i))=htot(ind_point(i))+1 +#ifdef DEBUG + write (iout,*) "i",i,"q",(q(j,i),j=1,nQ)," ind",ind_point(i), + & " htot",htot(ind_point(i)) + call flush(iout) +#endif + enddo ! i + call flush(iout) + + nbin=nbin1**nQ-1 + write (iout,'(a)') "Numbers of counts in Q bins" + do t=0,tmax + if (htot(t).gt.0) then + write (iout,'(i15,$)') t + liczba=t + do j=1,nQ + jj = mod(liczba,nbin1) + liczba=liczba/nbin1 + write (iout,'(i5,$)') jj + enddo + write (iout,'(i8)') htot(t) + endif + enddo + do iparm=1,nParmSet + write (iout,'(a,i3)') "Number of data points for parameter set", + & iparm + write (iout,'(i7,$)') ((snk(m,ib,iparm,islice),m=1,nr(ib,iparm)), + & ib=1,nT_h(iparm)) + write (iout,'(i8)') stot(islice) + write (iout,'(a)') + enddo + call flush(iout) + +#ifdef MPI + call MPI_AllReduce(tmax,tmax_t,1,MPI_INTEGER,MPI_MAX, + & WHAM_COMM,IERROR) + tmax=tmax_t + call MPI_AllReduce(rmsmin,rmsmin_t,1,MPI_DOUBLE_PRECISION, + & MPI_MIN,WHAM_COMM,IERROR) + call MPI_AllReduce(rmsmax,rmsmax_t,1,MPI_DOUBLE_PRECISION, + & MPI_MAX,WHAM_COMM,IERROR) + call MPI_AllReduce(rgymin,rgymin_t,1,MPI_DOUBLE_PRECISION, + & MPI_MIN,WHAM_COMM,IERROR) + call MPI_AllReduce(rgymax,rgymax_t,1,MPI_DOUBLE_PRECISION, + & MPI_MAX,WHAM_COMM,IERROR) + rgymin=rgymin_t + rgymax=rgymax_t + rmsmin=rmsmin_t + rmsmax=rmsmax_t +#endif + rmsmin=deltrms*dint(rmsmin/deltrms) + rmsmax=deltrms*dint(rmsmax/deltrms) + rgymin=deltrms*dint(rgymin/deltrgy) + rgymax=deltrms*dint(rgymax/deltrgy) + nbin_rms=(rmsmax-rmsmin)/deltrms + nbin_rgy=(rgymax-rgymin)/deltrgy + write (iout,*) "rmsmin",rmsmin," rmsmax",rmsmax," rgymin",rgymin, + & " rgymax",rgymax," nbin_rms",nbin_rms," nbin_rgy",nbin_rgy + nFi=0 + do i=1,nParmSet + do j=1,nT_h(i) + nFi=nFi+nR(j,i) + enddo + enddo + write (iout,*) "nFi",nFi +! Compute the Boltzmann factor corresponing to restrain potentials in different +! simulations. +#ifdef MPI + do i=1,scount(me1) +#else + do i=1,ntot(islice) +#endif +c write (9,'(3i5,f10.5)') i,(iparm,potE(i,iparm),iparm=1,nParmSet) + do iparm=1,nParmSet +#ifdef DEBUG + write (iout,'(2i5,21f8.2)') i,iparm, + & (enetb(k,i,iparm),k=1,21) +#endif + call restore_parm(iparm) +#ifdef DEBUG + write (iout,*) wsc,wscp,welec,wvdwpp,wang,wtor,wscloc, + & wcorr,wcorr5,wcorr6,wturn4,wturn3,wturn6,wel_loc, + & wtor_d,wsccor,wbond +#endif + do ib=1,nT_h(iparm) + if (rescale_mode.eq.1) then + quot=1.0d0/(beta_h(ib,iparm)*1.987D-3*T0) + quotl=1.0d0 + kfacl=1.0d0 + do l=1,5 + quotl1=quotl + quotl=quotl*quot + kfacl=kfacl*kfac + fT(l)=kfacl/(kfacl-1.0d0+quotl) + enddo +#if defined(FUNCTH) + tt = 1.0d0/(beta_h(ib,iparm)*1.987D-3) + ft(6)=(320.0d0+80.0d0*dtanh((tt-320.0d0)/80.0d0))/320.0d0 +#elif defined(FUNCT) + ft(6)=1.0d0/(beta_h(ib,iparm)*1.987D-3*T0) +#else + ft(6)=1.0d0 +#endif + else if (rescale_mode.eq.2) then + quot=1.0d0/(T0*beta_h(ib,iparm)*1.987D-3) + quotl=1.0d0 + do l=1,5 + quotl=quotl*quot + fT(l)=1.12692801104297249644d0/ + & dlog(dexp(quotl)+dexp(-quotl)) + enddo +#if defined(FUNCTH) + tt = 1.0d0/(beta_h(ib,iparm)*1.987D-3) + ft(6)=(320.0d0+80.0d0*dtanh((tt-320.0d0)/80.0d0))/320.0d0 +#elif defined(FUNCT) + ft(6)=1.0d0/(beta_h(ib,iparm)*1.987D-3*T0) +#else + ft(6)=1.0d0 +#endif +c write (iout,*) 1.0d0/(beta_h(ib,iparm)*1.987D-3),ft + else if (rescale_mode.eq.0) then + do l=1,6 + fT(l)=1.0d0 + enddo + else + write (iout,*) "Error in WHAM_CALC: wrong RESCALE_MODE", + & rescale_mode + call flush(iout) + return1 + endif + evdw=enetb(1,i,iparm) + evdw_t=enetb(21,i,iparm) +#ifdef SCP14 + evdw2_14=enetb(17,i,iparm) + evdw2=enetb(2,i,iparm)+evdw2_14 +#else + evdw2=enetb(2,i,iparm) + evdw2_14=0.0d0 +#endif +#ifdef SPLITELE + ees=enetb(3,i,iparm) + evdw1=enetb(16,i,iparm) +#else + ees=enetb(3,i,iparm) + evdw1=0.0d0 +#endif + ecorr=enetb(4,i,iparm) + ecorr5=enetb(5,i,iparm) + ecorr6=enetb(6,i,iparm) + eel_loc=enetb(7,i,iparm) + eello_turn3=enetb(8,i,iparm) + eello_turn4=enetb(9,i,iparm) + eturn6=enetb(10,i,iparm) + ebe=enetb(11,i,iparm) + escloc=enetb(12,i,iparm) + etors=enetb(13,i,iparm) + etors_d=enetb(14,i,iparm) + ehpb=enetb(15,i,iparm) + estr=enetb(18,i,iparm) + esccor=enetb(19,i,iparm) + edihcnstr=enetb(20,i,iparm) +#ifdef DEBUG + write (iout,'(3i5,6f5.2,14f12.3)') i,ib,iparm,(ft(l),l=1,6), + & evdw+evdw_t,evdw2,ees,evdw1,ecorr,eel_loc,estr,ebe,escloc, + & etors,etors_d,eello_turn3,eello_turn4,esccor +#endif + +#ifdef SPLITELE + etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2+ft(1)*welec*ees + & +wvdwpp*evdw1 + & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc + & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 + & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 + & +ft(2)*wturn3*eello_turn3 + & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc + & +edihcnstr+ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor + & +wbond*estr +#else + etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2 + & +ft(1)*welec*(ees+evdw1) + & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc + & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 + & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 + & +ft(2)*wturn3*eello_turn3 + & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc+edihcnstr + & +ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor + & +wbond*estr +#endif +#ifdef DEBUG + write (iout,*) i,iparm,1.0d0/(beta_h(ib,iparm)*1.987D-3), + & etot +#endif +#ifdef DEBUG + if (iparm.eq.1 .and. ib.eq.1) then + write (iout,*)"Conformation",i + energia(0)=etot + do k=1,max_ene + energia(k)=enetb(k,i,iparm) + enddo + call enerprint(energia(0),fT) + endif +#endif + do kk=1,nR(ib,iparm) + Econstr=0.0d0 + do j=1,nQ + dd = q(j,i) + Econstr=Econstr+Kh(j,kk,ib,iparm) + & *(dd-q0(j,kk,ib,iparm))**2 + enddo + v(i,kk,ib,iparm)= + & -beta_h(ib,iparm)*(etot+Econstr) +#ifdef DEBUG + write (iout,'(4i5,4e15.5)') i,kk,ib,iparm, + & etot,v(i,kk,ib,iparm) +#endif + enddo ! kk + enddo ! ib + enddo ! iparm + enddo ! i +! Simple iteration to calculate free energies corresponding to all simulation +! runs. + do iter=1,maxit + +! Compute new free-energy values corresponding to the righ-hand side of the +! equation and their derivatives. + write (iout,*) "------------------------fi" + entfac_min=1.0d10 +#ifdef MPI + do t=1,scount(me1) +#else + do t=1,ntot(islice) +#endif + vmax=-1.0d+20 + do i=1,nParmSet + do k=1,nT_h(i) + do l=1,nR(k,i) + vf=v(t,l,k,i)+f(l,k,i) + if (vf.gt.vmax) vmax=vf + enddo + enddo + enddo + denom=0.0d0 + do i=1,nParmSet + do k=1,nT_h(i) + do l=1,nR(k,i) + aux=f(l,k,i)+v(t,l,k,i)-vmax + if (aux.gt.-200.0d0) + & denom=denom+snk(l,k,i,islice)*dexp(aux) + enddo + enddo + enddo + entfac(t)=-dlog(denom)-vmax + if (entfac(t).lt.entfac_min) entfac_min=entfac(t) +#ifdef DEBUG + write (iout,*) t,"vmax",vmax," denom",denom,"entfac",entfac(t) +#endif + enddo +c#ifdef MPI +c write (iout,*) "entfac_min before AllReduce",entfac_min +c call MPI_AllReduce(entfac_min,entfac_min_t,1, +c & MPI_DOUBLE_PRECISION,MPI_MAX,WHAM_COMM,IERROR) +c entfac_min=entfac_min_t +c write (iout,*) "entfac_min after AllReduce",entfac_min +c#endif +c#ifdef MPI +c do t=1,scount(me) +c entfac(t)=entfac(t)-entfac_min +c enddo +c#else +c do t=1,ntot(islice) +c entfac(t)=entfac(t)-entfac_min +c enddo +c#endif + do iparm=1,nParmSet + do iib=1,nT_h(iparm) + do ii=1,nR(iib,iparm) +#ifdef MPI + fi_p_min(ii,iib,iparm)=-1.0d10 + do t=1,scount(me) + aux=v(t,ii,iib,iparm)+entfac(t) + if (aux.gt.fi_p_min(ii,iib,iparm)) + & fi_p_min(ii,iib,iparm)=aux + enddo +#else + do t=1,ntot(islice) + aux=v(t,ii,iib,iparm)+entfac(t) + if (aux.gt.fi_min(ii,iib,iparm)) + & fi_min(ii,iib,iparm)=aux + enddo +#endif + enddo ! ii + enddo ! iib + enddo ! iparm +#ifdef MPI +#ifdef DEBUG + write (iout,*) "fi_min before AllReduce" + do i=1,nParmSet + do j=1,nT_h(i) + write (iout,*) (i,j,k,fi_p_min(k,j,i),k=1,nR(j,i)) + enddo + enddo +#endif + call MPI_AllReduce(fi_p_min,fi_min,MaxR*MaxT_h*nParmSet, + & MPI_DOUBLE_PRECISION,MPI_MAX,WHAM_COMM,IERROR) +#ifdef DEBUG + write (iout,*) "fi_min after AllReduce" + do i=1,nParmSet + do j=1,nT_h(i) + write (iout,*) (i,j,k,fi_min(k,j,i),k=1,nR(j,i)) + enddo + enddo +#endif +#endif + do iparm=1,nParmSet + do iib=1,nT_h(iparm) + do ii=1,nR(iib,iparm) +#ifdef MPI + fi_p(ii,iib,iparm)=0.0d0 + do t=1,scount(me) + fi_p(ii,iib,iparm)=fi_p(ii,iib,iparm) + & +dexp(v(t,ii,iib,iparm)+entfac(t)-fi_min(ii,iib,iparm)) +#ifdef DEBUG + write (iout,'(4i5,4e15.5)') t,ii,iib,iparm, + & v(t,ii,iib,iparm),entfac(t),fi_min(ii,iib,iparm), + & fi_p(ii,iib,iparm) +#endif + enddo +#else + fi(ii,iib,iparm)=0.0d0 + do t=1,ntot(islice) + fi(ii,iib,iparm)=fi(ii,iib,iparm) + & +dexp(v(t,ii,iib,iparm)+entfac(t)-fi_min(ii,iib,iparm)) + enddo +#endif + enddo ! ii + enddo ! iib + enddo ! iparm + +#ifdef MPI +#ifdef DEBUG + write (iout,*) "fi before MPI_Reduce me",me,' master',master + do iparm=1,nParmSet + do ib=1,nT_h(iparm) + write (iout,*) "iparm",iparm," ib",ib + write (iout,*) "beta=",beta_h(ib,iparm) + write (iout,'(8e15.5)') (fi_p(i,ib,iparm),i=1,nR(ib,iparm)) + enddo + enddo +#endif +#ifdef DEBUG + write (iout,*) "REDUCE size",maxR,MaxT_h,nParmSet, + & maxR*MaxT_h*nParmSet + write (iout,*) "MPI_COMM_WORLD",MPI_COMM_WORLD, + & " WHAM_COMM",WHAM_COMM +#endif + call MPI_Reduce(fi_p(1,1,1),fi(1,1,1),maxR*MaxT_h*nParmSet, + & MPI_DOUBLE_PRECISION, + & MPI_SUM,Master,WHAM_COMM,IERROR) +#ifdef DEBUG + write (iout,*) "fi after MPI_Reduce nparmset",nparmset + do iparm=1,nParmSet + write (iout,*) "iparm",iparm + do ib=1,nT_h(iparm) + write (iout,*) "beta=",beta_h(ib,iparm) + write (iout,'(8e15.5)') (fi(i,ib,iparm),i=1,nR(ib,iparm)) + enddo + enddo +#endif + if (me1.eq.Master) then +#endif + avefi=0.0d0 + do iparm=1,nParmSet + do ib=1,nT_h(iparm) + do i=1,nR(ib,iparm) + fi(i,ib,iparm)=-dlog(fi(i,ib,iparm))-fi_min(i,ib,iparm) + avefi=avefi+fi(i,ib,iparm) + enddo + enddo + enddo + avefi=avefi/nFi + do iparm=1,nParmSet + write (iout,*) "Parameter set",iparm + do ib =1,nT_h(iparm) + write (iout,*) "beta=",beta_h(ib,iparm) + do i=1,nR(ib,iparm) + fi(i,ib,iparm)=fi(i,ib,iparm)-avefi + enddo + write (iout,'(8f10.5)') (fi(i,ib,iparm),i=1,nR(ib,iparm)) + write (iout,'(8f10.5)') (f(i,ib,iparm),i=1,nR(ib,iparm)) + enddo + enddo + +! Compute the norm of free-energy increments. + finorm=0.0d0 + do iparm=1,nParmSet + do ib=1,nT_h(iparm) + do i=1,nR(ib,iparm) + finorm=finorm+dabs(fi(i,ib,iparm)-f(i,ib,iparm)) + f(i,ib,iparm)=fi(i,ib,iparm) + enddo + enddo + enddo + + write (iout,*) 'Iteration',iter,' finorm',finorm + +#ifdef MPI + endif + call MPI_Bcast(f(1,1,1),MaxR*MaxT_h*nParmSet, + & MPI_DOUBLE_PRECISION,Master, + & WHAM_COMM,IERROR) + call MPI_Bcast(finorm,1,MPI_DOUBLE_PRECISION,Master, + & WHAM_COMM,IERROR) +#endif +! Exit, if the increment norm is smaller than pre-assigned tolerance. + if (finorm.lt.fimin) then + write (iout,*) 'Iteration converged' + goto 20 + endif + + enddo ! iter + + 20 continue +! Now, put together the histograms from all simulations, in order to get the +! unbiased total histogram. + +C Determine the minimum free energies +#ifdef MPI + do i=1,scount(me1) +#else + do i=1,ntot(islice) +#endif +c write (9,'(3i5,f10.5)') i,(iparm,potE(i,iparm),iparm=1,nParmSet) + do iparm=1,nParmSet +#ifdef DEBUG + write (iout,'(2i5,21f8.2)') i,iparm, + & (enetb(k,i,iparm),k=1,21) +#endif + call restore_parm(iparm) +#ifdef DEBUG + write (iout,*) wsc,wscp,welec,wvdwpp,wang,wtor,wscloc, + & wcorr,wcorr5,wcorr6,wturn4,wturn3,wturn6,wel_loc, + & wtor_d,wsccor,wbond +#endif + do ib=1,nT_h(iparm) + if (rescale_mode.eq.1) then + quot=1.0d0/(beta_h(ib,iparm)*1.987D-3*T0) + quotl=1.0d0 + kfacl=1.0d0 + do l=1,5 + quotl1=quotl + quotl=quotl*quot + kfacl=kfacl*kfac + fT(l)=kfacl/(kfacl-1.0d0+quotl) + enddo +#if defined(FUNCTH) + tt = 1.0d0/(beta_h(ib,iparm)*1.987D-3) + ft(6)=(320.0d0+80.0d0*dtanh((tt-320.0d0)/80.0d0))/320.0d0 +#elif defined(FUNCT) + ft(6)=1.0d0/(beta_h(ib,iparm)*1.987D-3*T0) +#else + ft(6)=1.0d0 +#endif + else if (rescale_mode.eq.2) then + quot=1.0d0/(T0*beta_h(ib,iparm)*1.987D-3) + quotl=1.0d0 + do l=1,5 + quotl=quotl*quot + fT(l)=1.12692801104297249644d0/ + & dlog(dexp(quotl)+dexp(-quotl)) + enddo +#if defined(FUNCTH) + tt = 1.0d0/(beta_h(ib,iparm)*1.987D-3) + ft(6)=(320.0d0+80.0d0*dtanh((tt-320.0d0)/80.0d0))/320.0d0 +#elif defined(FUNCT) + ft(6)=1.0d0/(beta_h(ib,iparm)*1.987D-3*T0) +#else + ft(6)=1.0d0 +#endif +c write (iout,*) 1.0d0/(beta_h(ib,iparm)*1.987D-3),ft + else if (rescale_mode.eq.0) then + do l=1,6 + fT(l)=1.0d0 + enddo + else + write (iout,*) "Error in WHAM_CALC: wrong RESCALE_MODE", + & rescale_mode + call flush(iout) + return1 + endif + evdw=enetb(1,i,iparm) + evdw_t=enetb(21,i,iparm) +#ifdef SCP14 + evdw2_14=enetb(17,i,iparm) + evdw2=enetb(2,i,iparm)+evdw2_14 +#else + evdw2=enetb(2,i,iparm) + evdw2_14=0.0d0 +#endif +#ifdef SPLITELE + ees=enetb(3,i,iparm) + evdw1=enetb(16,i,iparm) +#else + ees=enetb(3,i,iparm) + evdw1=0.0d0 +#endif + ecorr=enetb(4,i,iparm) + ecorr5=enetb(5,i,iparm) + ecorr6=enetb(6,i,iparm) + eel_loc=enetb(7,i,iparm) + eello_turn3=enetb(8,i,iparm) + eello_turn4=enetb(9,i,iparm) + eturn6=enetb(10,i,iparm) + ebe=enetb(11,i,iparm) + escloc=enetb(12,i,iparm) + etors=enetb(13,i,iparm) + etors_d=enetb(14,i,iparm) + ehpb=enetb(15,i,iparm) + estr=enetb(18,i,iparm) + esccor=enetb(19,i,iparm) + edihcnstr=enetb(20,i,iparm) +#ifdef DEBUG + write (iout,'(3i5,6f5.2,14f12.3)') i,ib,iparm,(ft(l),l=1,6), + & evdw+evdw_t,evdw2,ees,evdw1,ecorr,eel_loc,estr,ebe,escloc, + & etors,etors_d,eello_turn3,eello_turn4,esccor,edihcnstr +#endif + +#ifdef SPLITELE + etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2+ft(1)*welec*ees + & +wvdwpp*evdw1 + & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc + & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 + & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 + & +ft(2)*wturn3*eello_turn3 + & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc + & +edihcnstr+ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor + & +wbond*estr +#else + etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2 + & +ft(1)*welec*(ees+evdw1) + & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc + & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 + & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 + & +ft(2)*wturn3*eello_turn3 + & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc+edihcnstr + & +ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor + & +wbond*estr +#endif +c write (iout,*) "i",i," ib",ib, +c & " temp",1.0d0/(1.987d-3*beta_h(ib,iparm))," etot",etot, +c & " entfac",entfac(i) + etot=etot-entfac(i)/beta_h(ib,iparm) + if(etot.lt.potEmin_all(ib,iparm)) potEmin_all(ib,iparm)=etot +c write (iout,*) "efree",etot," potEmin",potEmin_all(ib,iparm) + enddo ! ib + enddo ! iparm + enddo ! i +#ifdef DEBUG + write (iout,*) "The potEmin array before reduction" + do i=1,nParmSet + write (iout,*) "Parameter set",i + do j=1,nT_h(i) + write (iout,*) j,PotEmin_all(j,i) + enddo + enddo + write (iout,*) "potEmin_min",potEmin_min +#endif +#ifdef MPI +C Determine the minimum energes for all parameter sets and temperatures + call MPI_AllReduce(potEmin_all(1,1),potEmin_t_all(1,1), + & maxT_h*nParmSet,MPI_DOUBLE_PRECISION,MPI_MIN,WHAM_COMM,IERROR) + do i=1,nParmSet + do j=1,nT_h(i) + potEmin_all(j,i)=potEmin_t_all(j,i) + enddo + enddo +#endif + potEmin_min=potEmin_all(1,1) + do i=1,nParmSet + do j=1,nT_h(i) + if (potEmin_all(j,i).lt.potEmin_min) + & potEmin_min=potEmin_all(j,i) + enddo + enddo +#ifdef DEBUG + write (iout,*) "The potEmin array" + do i=1,nParmSet + write (iout,*) "Parameter set",i + do j=1,nT_h(i) + write (iout,*) j,PotEmin_all(j,i) + enddo + enddo + write (iout,*) "potEmin_min",potEmin_min +#endif + +#ifdef MPI + do t=0,tmax + hfin_ent_p(t)=0.0d0 + enddo +#else + do t=0,tmax + hfin_ent(t)=0.0d0 + enddo +#endif + write (iout,*) "--------------hist" +#ifdef MPI + do iparm=1,nParmSet + do i=0,nGridT + sumW_p(i,iparm)=0.0d0 + sumE_p(i,iparm)=0.0d0 + sumEbis_p(i,iparm)=0.0d0 + sumEsq_p(i,iparm)=0.0d0 + do j=1,nQ+2 + sumQ_p(j,i,iparm)=0.0d0 + sumQsq_p(j,i,iparm)=0.0d0 + sumEQ_p(j,i,iparm)=0.0d0 + enddo + enddo + enddo + upindE_p=0 +#else + do iparm=1,nParmSet + do i=0,nGridT + sumW(i,iparm)=0.0d0 + sumE(i,iparm)=0.0d0 + sumEbis(i,iparm)=0.0d0 + sumEsq(i,iparm)=0.0d0 + do j=1,nQ+2 + sumQ(j,i,iparm)=0.0d0 + sumQsq(j,i,iparm)=0.0d0 + sumEQ(j,i,iparm)=0.0d0 + enddo + enddo + enddo + upindE=0 +#endif +c 8/26/05 entropy distribution +#ifdef MPI + entmin_p=1.0d10 + entmax_p=-1.0d10 + do t=1,scount(me1) +c ent=-dlog(entfac(t)) + ent=entfac(t) + if (ent.lt.entmin_p) entmin_p=ent + if (ent.gt.entmax_p) entmax_p=ent + enddo + write (iout,*) "entmin",entmin_p," entmax",entmax_p + call flush(iout) + call MPI_Allreduce(entmin_p,entmin,1,MPI_DOUBLE_PRECISION,MPI_MIN, + & WHAM_COMM,IERROR) + call MPI_Allreduce(entmax_p,entmax,1,MPI_DOUBLE_PRECISION,MPI_MAX, + & WHAM_COMM,IERROR) + ientmax=entmax-entmin + if (ientmax.gt.2000) ientmax=2000 + write (iout,*) "entmin",entmin," entmax",entmax," ientmax",ientmax + call flush(iout) + do t=1,scount(me1) +c ient=-dlog(entfac(t))-entmin + ient=entfac(t)-entmin + if (ient.le.2000) histent_p(ient)=histent_p(ient)+1 + enddo + call MPI_Allreduce(histent_p(0),histent(0),ientmax+1,MPI_INTEGER, + & MPI_SUM,WHAM_COMM,IERROR) + if (me1.eq.Master) then + write (iout,*) "Entropy histogram" + do i=0,ientmax + write(iout,'(f15.4,i10)') entmin+i,histent(i) + enddo + endif +#else + entmin=1.0d10 + entmax=-1.0d10 + do t=1,ntot(islice) + ent=entfac(t) + if (ent.lt.entmin) entmin=ent + if (ent.gt.entmax) entmax=ent + enddo + ientmax=-dlog(entmax)-entmin + if (ientmax.gt.2000) ientmax=2000 + do t=1,ntot(islice) + ient=entfac(t)-entmin + if (ient.le.2000) histent(ient)=histent(ient)+1 + enddo + write (iout,*) "Entropy histogram" + do i=0,ientmax + write(iout,'(2f15.4)') entmin+i,histent(i) + enddo +#endif + +#ifdef MPI +c write (iout,*) "me1",me1," scount",scount(me1) + + do iparm=1,nParmSet + +#ifdef MPI + do ib=1,nT_h(iparm) + do t=0,tmax + hfin_p(t,ib)=0.0d0 + enddo + enddo + do i=1,maxindE + histE_p(i)=0.0d0 + enddo +#else + do ib=1,nT_h(iparm) + do t=0,tmax + hfin(t,ib)=0.0d0 + enddo + enddo + do i=1,maxindE + histE(i)=0.0d0 + enddo +#endif + do ib=1,nT_h(iparm) + do i=0,MaxBinRms + do j=0,MaxBinRgy + hrmsrgy(j,i,ib)=0.0d0 +#ifdef MPI + hrmsrgy_p(j,i,ib)=0.0d0 +#endif + enddo + enddo + enddo + + do t=1,scount(me1) +#else + do t=1,ntot(islice) +#endif + ind = ind_point(t) +#ifdef MPI + hfin_ent_p(ind)=hfin_ent_p(ind)+dexp(entfac(t)) +#else + hfin_ent(ind)=hfin_ent(ind)+dexp(entfac(t)) +#endif + call restore_parm(iparm) + evdw=enetb(21,t,iparm) + evdw_t=enetb(1,t,iparm) +#ifdef SCP14 + evdw2_14=enetb(17,t,iparm) + evdw2=enetb(2,t,iparm)+evdw2_14 +#else + evdw2=enetb(2,t,iparm) + evdw2_14=0.0d0 +#endif +#ifdef SPLITELE + ees=enetb(3,t,iparm) + evdw1=enetb(16,t,iparm) +#else + ees=enetb(3,t,iparm) + evdw1=0.0d0 +#endif + ecorr=enetb(4,t,iparm) + ecorr5=enetb(5,t,iparm) + ecorr6=enetb(6,t,iparm) + eel_loc=enetb(7,t,iparm) + eello_turn3=enetb(8,t,iparm) + eello_turn4=enetb(9,t,iparm) + eturn6=enetb(10,t,iparm) + ebe=enetb(11,t,iparm) + escloc=enetb(12,t,iparm) + etors=enetb(13,t,iparm) + etors_d=enetb(14,t,iparm) + ehpb=enetb(15,t,iparm) + estr=enetb(18,t,iparm) + esccor=enetb(19,t,iparm) + edihcnstr=enetb(20,t,iparm) + do k=0,nGridT + betaT=startGridT+k*delta_T + temper=betaT +c fT=T0/betaT +c ft=2*T0/(T0+betaT) + if (rescale_mode.eq.1) then + quot=betaT/T0 + quotl=1.0d0 + kfacl=1.0d0 + do l=1,5 + quotl1=quotl + quotl=quotl*quot + kfacl=kfacl*kfac + denom=kfacl-1.0d0+quotl + fT(l)=kfacl/denom + ftprim(l)=-l*ft(l)*quotl1/(T0*denom) + ftbis(l)=l*kfacl*quotl1* + & (2*l*quotl-(l-1)*denom)/(quot*t0*t0*denom**3) + enddo +#if defined(FUNCTH) + ft(6)=(320.0d0+80.0d0*dtanh((betaT-320.0d0)/80.0d0))/ + & 320.0d0 + ftprim(6)=1.0d0/(320.0d0*dcosh((betaT-320.0d0)/80.0d0)**2) + ftbis(6)=-2.0d0*dtanh((betaT-320.0d0)/80.0d0) + & /(320.0d0*80.0d0*dcosh((betaT-320.0d0)/80.0d0)**3) +#elif defined(FUNCT) + fT(6)=betaT/T0 + ftprim(6)=1.0d0/T0 + ftbis(6)=0.0d0 +#else + fT(6)=1.0d0 + ftprim(6)=0.0d0 + ftbis(6)=0.0d0 +#endif + else if (rescale_mode.eq.2) then + quot=betaT/T0 + quotl=1.0d0 + do l=1,5 + quotl1=quotl + quotl=quotl*quot + eplus=dexp(quotl) + eminus=dexp(-quotl) + logfac=1.0d0/dlog(eplus+eminus) + tanhT=(eplus-eminus)/(eplus+eminus) + fT(l)=1.12692801104297249644d0*logfac + ftprim(l)=-l*quotl1*ft(l)*tanhT*logfac/T0 + ftbis(l)=(l-1)*ftprim(l)/(quot*T0)- + & 2*l*quotl1/T0*logfac* + & (2*l*quotl1*ft(l)/(T0*(eplus+eminus)**2) + & +ftprim(l)*tanhT) + enddo +#if defined(FUNCTH) + ft(6)=(320.0d0+80.0d0*dtanh((betaT-320.0d0)/80.0d0))/ + & 320.0d0 + ftprim(6)=1.0d0/(320.0d0*dcosh((betaT-320.0d0)/80.0d0)**2) + ftbis(6)=-2.0d0*dtanh((betaT-320.0d0)/80.0d0) + & /(320.0d0*80.0d0*dcosh((betaT-320.0d0)/80.0d0)**3) +#elif defined(FUNCT) + fT(6)=betaT/T0 + ftprim(6)=1.0d0/T0 + ftbis(6)=0.0d0 +#else + fT(6)=1.0d0 + ftprim(6)=0.0d0 + ftbis(6)=0.0d0 +#endif + else if (rescale_mode.eq.0) then + do l=1,5 + fT(l)=1.0d0 + ftprim(l)=0.0d0 + enddo + else + write (iout,*) "Error in WHAM_CALC: wrong RESCALE_MODE", + & rescale_mode + call flush(iout) + return1 + endif +c write (iout,*) "ftprim",ftprim +c write (iout,*) "ftbis",ftbis + betaT=1.0d0/(1.987D-3*betaT) + if (betaT.ge.beta_h(1,iparm)) then + potEmin=potEmin_all(1,iparm) +c write(iout,*) "first",temper,potEmin + else if (betaT.lt.beta_h(nT_h(iparm),iparm)) then + potEmin=potEmin_all(nT_h(iparm),iparm) +c write (iout,*) "last",temper,potEmin + else + do l=1,nT_h(iparm)-1 + if (betaT.le.beta_h(l,iparm) .and. + & betaT.gt.beta_h(l+1,iparm)) then + potEmin=potEmin_all(l,iparm) +c write (iout,*) "l",l, +c & betaT,1.0d0/(1.987D-3*beta_h(l,iparm)), +c & 1.0d0/(1.987D-3*beta_h(l+1,iparm)),temper,potEmin + exit + endif + enddo + endif +c write (iout,*) ib," PotEmin",potEmin +#ifdef SPLITELE + etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2+ft(1)*welec*ees + & +wvdwpp*evdw1 + & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc + & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 + & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 + & +ft(2)*wturn3*eello_turn3 + & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc + & +edihcnstr+ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor + & +wbond*estr + eprim=ftprim(6)*evdw_t+ftprim(1)*welec*ees + & +ftprim(1)*wtor*etors+ + & ftprim(3)*wcorr*ecorr+ftprim(4)*wcorr5*ecorr5+ + & ftprim(5)*wcorr6*ecorr6+ftprim(3)*wturn4*eello_turn4+ + & ftprim(2)*wturn3*eello_turn3+ftprim(5)*wturn6*eturn6+ + & ftprim(2)*wel_loc*eel_loc+ftprim(2)*wtor_d*etors_d+ + & ftprim(1)*wsccor*esccor + ebis=ftbis(1)*welec*ees+ftbis(1)*wtor*etors+ + & ftbis(3)*wcorr*ecorr+ftbis(4)*wcorr5*ecorr5+ + & ftbis(5)*wcorr6*ecorr6+ftbis(3)*wturn4*eello_turn4+ + & ftbis(2)*wturn3*eello_turn3+ftbis(5)*wturn6*eturn6+ + & ftbis(2)*wel_loc*eel_loc+ftbis(2)*wtor_d*etors_d+ + & ftbis(1)*wsccor*esccor +#else + etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2 + & +ft(1)*welec*(ees+evdw1) + & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc + & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 + & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 + & +ft(2)*wturn3*eello_turn3 + & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc+edihcnstr + & +ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor + & +wbond*estr + eprim=ftprim(6)*evdw_t+ftprim(1)*welec*(ees+evdw1) + & +ftprim(1)*wtor*etors+ + & ftprim(3)*wcorr*ecorr+ftprim(4)*wcorr5*ecorr5+ + & ftprim(5)*wcorr6*ecorr6+ftprim(3)*wturn4*eello_turn4+ + & ftprim(2)*wturn3*eello_turn3+ftprim(5)*wturn6*eturn6+ + & ftprim(2)*wel_loc*eel_loc+ftprim(2)*wtor_d*etors_d+ + & ftprim(1)*wsccor*esccor + ebis=ftbis(1)*welec*(ees+evdw1)+ftbis(1)*wtor*etors+ + & ftbis(3)*wcorr*ecorr+ftbis(4)*wcorr5*ecorr5+ + & ftbis(5)*wcorr6*ecorr6+ftbis(3)*wturn4*eello_turn4+ + & ftbis(2)*wturn3*eello_turn3+ftbis(5)*wturn6*eturn6+ + & ftbis(2)*wel_loc*eel_loc+ftbis(2)*wtor_d*etors_d+ + & ftprim(1)*wsccor*esccor +#endif + weight=dexp(-betaT*(etot-potEmin)+entfac(t)) +#ifdef DEBUG + write (iout,*) "iparm",iparm," t",t," temper",temper, + & " etot",etot," entfac",entfac(t), + & " efree",etot-entfac(t)/betaT," potEmin",potEmin, + & " boltz",-betaT*(etot-potEmin)+entfac(t), + & " weight",weight," ebis",ebis +#endif + etot=etot-temper*eprim +#ifdef MPI + sumW_p(k,iparm)=sumW_p(k,iparm)+weight + sumE_p(k,iparm)=sumE_p(k,iparm)+etot*weight + sumEbis_p(k,iparm)=sumEbis_p(k,iparm)+ebis*weight + sumEsq_p(k,iparm)=sumEsq_p(k,iparm)+etot**2*weight + do j=1,nQ+2 + sumQ_p(j,k,iparm)=sumQ_p(j,k,iparm)+q(j,t)*weight + sumQsq_p(j,k,iparm)=sumQsq_p(j,k,iparm)+q(j,t)**2*weight + sumEQ_p(j,k,iparm)=sumEQ_p(j,k,iparm) + & +etot*q(j,t)*weight + enddo +#else + sumW(k,iparm)=sumW(k,iparm)+weight + sumE(k,iparm)=sumE(k,iparm)+etot*weight + sumEbis(k,iparm)=sumEbis(k,iparm)+ebis*weight + sumEsq(k,iparm)=sumEsq(k,iparm)+etot**2*weight + do j=1,nQ+2 + sumQ(j,k,iparm)=sumQ(j,k,iparm)+q(j,t)*weight + sumQsq(j,k,iparm)=sumQsq(j,k,iparm)+q(j,t)**2*weight + sumEQ(j,k,iparm)=sumEQ(j,k,iparm) + & +etot*q(j,t)*weight + enddo +#endif + enddo + indE = aint(potE(t,iparm)-aint(potEmin)) + if (indE.ge.0 .and. indE.le.maxinde) then + if (indE.gt.upindE_p) upindE_p=indE + histE_p(indE)=histE_p(indE)+dexp(-entfac(t)) + endif +#ifdef MPI + do ib=1,nT_h(iparm) + potEmin=potEmin_all(ib,iparm) + expfac=dexp(-beta_h(ib,iparm)*(etot-potEmin)+entfac(t)) + hfin_p(ind,ib)=hfin_p(ind,ib)+ + & dexp(-beta_h(ib,iparm)*(etot-potEmin)+entfac(t)) + if (rmsrgymap) then + indrgy=dint((q(nQ+2,t)-rgymin)/deltrgy) + indrms=dint((q(nQ+1,t)-rmsmin)/deltrms) + hrmsrgy_p(indrgy,indrms,ib)= + & hrmsrgy_p(indrgy,indrms,ib)+expfac + endif + enddo +#else + do ib=1,nT_h(iparm) + potEmin=potEmin_all(ib,iparm) + expfac=dexp(-beta_h(ib,iparm)*(etot-potEmin)+entfac(t)) + hfin(ind,ib)=hfin(ind,ib)+ + & dexp(-beta_h(ib,iparm)*(etot-potEmin)+entfac(t)) + if (rmsrgymap) then + indrgy=dint((q(nQ+2,t)-rgymin)/deltrgy) + indrms=dint((q(nQ+1,t)-rmsmin)/deltrms) + hrmsrgy(indrgy,indrms,ib)= + & hrmsrgy(indrgy,indrms,ib)+expfac + endif + enddo +#endif + enddo ! t + do ib=1,nT_h(iparm) + if (histout) call MPI_Reduce(hfin_p(0,ib),hfin(0,ib),nbin, + & MPI_DOUBLE_PRECISION,MPI_SUM,Master,WHAM_COMM,IERROR) + if (rmsrgymap) then + call MPI_Reduce(hrmsrgy_p(0,0,ib),hrmsrgy(0,0,ib), + & (MaxBinRgy+1)*(nbin_rms+1),MPI_DOUBLE_PRECISION,MPI_SUM,Master, + & WHAM_COMM,IERROR) + endif + enddo + call MPI_Reduce(upindE_p,upindE,1, + & MPI_INTEGER,MPI_MAX,Master,WHAM_COMM,IERROR) + call MPI_Reduce(histE_p(0),histE(0),maxindE, + & MPI_DOUBLE_PRECISION,MPI_SUM,Master,WHAM_COMM,IERROR) + + if (me1.eq.master) then + + if (histout) then + + write (iout,'(6x,$)') + write (iout,'(f20.2,$)') (1.0d0/(1.987D-3*beta_h(ib,iparm)), + & ib=1,nT_h(iparm)) + write (iout,*) + + write (iout,'(/a)') 'Final histograms' + if (histfile) then + if (nslice.eq.1) then + if (separate_parset) then + write(licz3,"(bz,i3.3)") myparm + histname=prefix(:ilen(prefix))//'_par'//licz3//'.hist' + else + histname=prefix(:ilen(prefix))//'.hist' + endif + else + if (separate_parset) then + write(licz3,"(bz,i3.3)") myparm + histname=prefix(:ilen(prefix))//'_par'//licz3// + & '_slice_'//licz2//'.hist' + else + histname=prefix(:ilen(prefix))//'_slice_'//licz2//'.hist' + endif + endif +#if defined(AIX) || defined(PGI) + open (ihist,file=histname,position='append') +#else + open (ihist,file=histname,access='append') +#endif + endif + + do t=0,tmax + liczba=t + sumH=0.0d0 + do ib=1,nT_h(iparm) + sumH=sumH+hfin(t,ib) + enddo + if (sumH.gt.0.0d0) then + do j=1,nQ + jj = mod(liczba,nbin1) + liczba=liczba/nbin1 + write (iout,'(f6.3,$)') dmin+(jj+0.5d0)*delta + if (histfile) + & write (ihist,'(f6.3,$)') dmin+(jj+0.5d0)*delta + enddo + do ib=1,nT_h(iparm) + write (iout,'(e20.10,$)') hfin(t,ib) + if (histfile) write (ihist,'(e20.10,$)') hfin(t,ib) + enddo + write (iout,'(i5)') iparm + if (histfile) write (ihist,'(i5)') iparm + endif + enddo + + endif + + if (entfile) then + if (nslice.eq.1) then + if (separate_parset) then + write(licz3,"(bz,i3.3)") myparm + histname=prefix(:ilen(prefix))//"_par"//licz3//'.ent' + else + histname=prefix(:ilen(prefix))//'.ent' + endif + else + if (separate_parset) then + write(licz3,"(bz,i3.3)") myparm + histname=prefix(:ilen(prefix))//'par_'//licz3// + & '_slice_'//licz2//'.ent' + else + histname=prefix(:ilen(prefix))//'_slice_'//licz2//'.ent' + endif + endif +#if defined(AIX) || defined(PGI) + open (ihist,file=histname,position='append') +#else + open (ihist,file=histname,access='append') +#endif + write (ihist,'(a)') "# Microcanonical entropy" + do i=0,upindE + write (ihist,'(f8.0,$)') dint(potEmin)+i + if (histE(i).gt.0.0e0) then + write (ihist,'(f15.5,$)') dlog(histE(i)) + else + write (ihist,'(f15.5,$)') 0.0d0 + endif + enddo + write (ihist,*) + close(ihist) + endif + write (iout,*) "Microcanonical entropy" + do i=0,upindE + write (iout,'(f8.0,$)') dint(potEmin)+i + if (histE(i).gt.0.0e0) then + write (iout,'(f15.5,$)') dlog(histE(i)) + else + write (iout,'(f15.5,$)') 0.0d0 + endif + write (iout,*) + enddo + if (rmsrgymap) then + if (nslice.eq.1) then + if (separate_parset) then + write(licz3,"(bz,i3.3)") myparm + histname=prefix(:ilen(prefix))//'_par'//licz3//'.rmsrgy' + else + histname=prefix(:ilen(prefix))//'.rmsrgy' + endif + else + if (separate_parset) then + write(licz3,"(bz,i3.3)") myparm + histname=prefix(:ilen(prefix))//'_par'//licz3// + & '_slice_'//licz2//'.rmsrgy' + else + histname=prefix(:ilen(prefix))//'_slice_'//licz2//'.rmsrgy' + endif + endif +#if defined(AIX) || defined(PGI) + open (ihist,file=histname,position='append') +#else + open (ihist,file=histname,access='append') +#endif + do i=0,nbin_rms + do j=0,nbin_rgy + write(ihist,'(2f8.2,$)') + & rgymin+deltrgy*j,rmsmin+deltrms*i + do ib=1,nT_h(iparm) + if (hrmsrgy(j,i,ib).gt.0.0d0) then + write(ihist,'(e14.5,$)') + & -dlog(hrmsrgy(j,i,ib))/beta_h(ib,iparm) + & +potEmin + else + write(ihist,'(e14.5,$)') 1.0d6 + endif + enddo + write (ihist,'(i2)') iparm + enddo + enddo + close(ihist) + endif + endif + enddo ! iparm +#ifdef MPI + call MPI_Reduce(hfin_ent_p(0),hfin_ent(0),nbin, + & MPI_DOUBLE_PRECISION,MPI_SUM,Master,WHAM_COMM,IERROR) + call MPI_Reduce(sumW_p(0,1),sumW(0,1),(nGridT+1)*nParmSet, + & MPI_DOUBLE_PRECISION,MPI_SUM,Master,WHAM_COMM,IERROR) + call MPI_Reduce(sumE_p(0,1),sumE(0,1),(nGridT+1)*nParmSet, + & MPI_DOUBLE_PRECISION,MPI_SUM,Master,WHAM_COMM,IERROR) + call MPI_Reduce(sumEbis_p(0,1),sumEbis(0,1),(nGridT+1)*nParmSet, + & MPI_DOUBLE_PRECISION,MPI_SUM,Master,WHAM_COMM,IERROR) + call MPI_Reduce(sumEsq_p(0,1),sumEsq(0,1),(nGridT+1)*nParmSet, + & MPI_DOUBLE_PRECISION,MPI_SUM,Master,WHAM_COMM,IERROR) + call MPI_Reduce(sumQ_p(1,0,1),sumQ(1,0,1), + & MaxQ1*(nGridT+1)*nParmSet,MPI_DOUBLE_PRECISION,MPI_SUM,Master, + & WHAM_COMM,IERROR) + call MPI_Reduce(sumQsq_p(1,0,1),sumQsq(1,0,1), + & MaxQ1*(nGridT+1)*nParmSet,MPI_DOUBLE_PRECISION,MPI_SUM,Master, + & WHAM_COMM,IERROR) + call MPI_Reduce(sumEQ_p(1,0,1),sumEQ(1,0,1), + & MaxQ1*(nGridT+1)*nParmSet,MPI_DOUBLE_PRECISION,MPI_SUM,Master, + & WHAM_COMM,IERROR) + if (me.eq.master) then +#endif + write (iout,'(/a)') 'Thermal characteristics of folding' + if (nslice.eq.1) then + nazwa=prefix + else + nazwa=prefix(:ilen(prefix))//"_slice_"//licz2 + endif + iln=ilen(nazwa) + if (nparmset.eq.1 .and. .not.separate_parset) then + nazwa=nazwa(:iln)//".thermal" + else if (nparmset.eq.1 .and. separate_parset) then + write(licz3,"(bz,i3.3)") myparm + nazwa=nazwa(:iln)//"_par_"//licz3//".thermal" + endif + do iparm=1,nParmSet + if (nparmset.gt.1) then + write(licz3,"(bz,i3.3)") iparm + nazwa=nazwa(:iln)//"_par_"//licz3//".thermal" + endif + open(34,file=nazwa) + if (separate_parset) then + write (iout,'(a,i3)') "Parameter set",myparm + else + write (iout,'(a,i3)') "Parameter set",iparm + endif + do i=0,NGridT + betaT=1.0d0/(1.987D-3*(startGridT+i*delta_T)) + if (betaT.ge.beta_h(1,iparm)) then + potEmin=potEmin_all(1,iparm) + else if (betaT.lt.beta_h(nT_h(iparm),iparm)) then + potEmin=potEmin_all(nT_h(iparm),iparm) + else + do l=1,nT_h(iparm)-1 + if (betaT.le.beta_h(l,iparm) .and. + & betaT.gt.beta_h(l+1,iparm)) then + potEmin=potEmin_all(l,iparm) + exit + endif + enddo + endif + sumE(i,iparm)=sumE(i,iparm)/sumW(i,iparm) + sumEbis(i,iparm)=(startGridT+i*delta_T)*sumEbis(i,iparm)/ + & sumW(i,iparm) + sumEsq(i,iparm)=(sumEsq(i,iparm)/sumW(i,iparm) + & -sumE(i,iparm)**2)/(1.987D-3*(startGridT+i*delta_T)**2) + do j=1,nQ+2 + sumQ(j,i,iparm)=sumQ(j,i,iparm)/sumW(i,iparm) + sumQsq(j,i,iparm)=sumQsq(j,i,iparm)/sumW(i,iparm) + & -sumQ(j,i,iparm)**2 + sumEQ(j,i,iparm)=sumEQ(j,i,iparm)/sumW(i,iparm) + & -sumQ(j,i,iparm)*sumE(i,iparm) + enddo + sumW(i,iparm)=-dlog(sumW(i,iparm))*(1.987D-3* + & (startGridT+i*delta_T))+potEmin + write (iout,'(f7.1,2f15.5,$)') startGridT+i*delta_T, + & sumW(i,iparm),sumE(i,iparm) + write (iout,'(f10.5,$)') (sumQ(j,i,iparm),j=1,nQ+2) + write (iout,'(e15.5,$)') sumEsq(i,iparm)-sumEbis(i,iparm), + & (sumQsq(j,i,iparm),j=1,nQ+2),(sumEQ(j,i,iparm),j=1,nQ+2) + write (iout,*) + write (34,'(f7.1,2f15.5,$)') startGridT+i*delta_T, + & sumW(i,iparm),sumE(i,iparm) + write (34,'(f10.5,$)') (sumQ(j,i,iparm),j=1,nQ+2) + write (34,'(e15.5,$)') sumEsq(i,iparm)-sumEbis(i,iparm), + & (sumQsq(j,i,iparm),j=1,nQ+2),(sumEQ(j,i,iparm),j=1,nQ+2) + write (34,*) + enddo + close(34) + enddo + if (histout) then + do t=0,tmax + if (hfin_ent(t).gt.0.0d0) then + liczba=t + jj = mod(liczba,nbin1) + write (iout,'(f6.3,e20.10," ent")') dmin+(jj+0.5d0)*delta, + & hfin_ent(t) + if (histfile) write (ihist,'(f6.3,e20.10," ent")') + & dmin+(jj+0.5d0)*delta, + & hfin_ent(t) + endif + enddo + if (histfile) close(ihist) + endif + +#ifdef ZSCORE +! Write data for zscore + if (nslice.eq.1) then + zscname=prefix(:ilen(prefix))//".zsc" + else + zscname=prefix(:ilen(prefix))//"_slice_"//licz2//".zsc" + endif +#if defined(AIX) || defined(PGI) + open (izsc,file=prefix(:ilen(prefix))//'.zsc',position='append') +#else + open (izsc,file=prefix(:ilen(prefix))//'.zsc',access='append') +#endif + write (izsc,'("NQ=",i1," NPARM=",i1)') nQ,nParmSet + do iparm=1,nParmSet + write (izsc,'("NT=",i1)') nT_h(iparm) + do ib=1,nT_h(iparm) + write (izsc,'("TEMP=",f6.1," NR=",i2," SNK=",$)') + & 1.0d0/(beta_h(ib,iparm)*1.987D-3),nR(ib,iparm) + jj = min0(nR(ib,iparm),7) + write (izsc,'(i8,$)') (snk(i,ib,iparm,islice),i=1,jj) + write (izsc,'(a1,$)') (" ",i=22+8*jj+1,79) + write (izsc,'("&")') + if (nR(ib,iparm).gt.7) then + do ii=8,nR(ib,iparm),9 + jj = min0(nR(ib,iparm),ii+8) + write (izsc,'(i8,$)') (snk(i,ib,iparm,islice),i=ii,jj) + write (izsc,'(a1,$') (" ",i=(jj-ii+1)*8+1,79) + write (izsc,'("&")') + enddo + endif + write (izsc,'("FI=",$)') + jj=min0(nR(ib,iparm),7) + write (izsc,'(f10.5,$)') (fi(i,ib,iparm),i=1,jj) + write (izsc,'(a1,$)') (" ",i=3+10*jj+1,79) + write (izsc,'("&")') + if (nR(ib,iparm).gt.7) then + do ii=8,nR(ib,iparm),9 + jj = min0(nR(ib,iparm),ii+8) + write (izsc,'(f10.5,$)') (fi(i,ib,iparm),i=ii,jj) + if (jj.eq.nR(ib,iparm)) then + write (izsc,*) + else + write (izsc,'(a1,$)') (" ",i=10*(jj-ii+1)+1,79) + write (izsc,'(t80,"&")') + endif + enddo + endif + do i=1,nR(ib,iparm) + write (izsc,'("KH=",$)') + write (izsc,'(f7.2,$)') (Kh(j,i,ib,iparm),j=1,nQ) + write (izsc,'(" Q0=",$)') + write (izsc,'(f7.5,$)') (q0(j,i,ib,iparm),j=1,nQ) + write (izsc,*) + enddo + enddo + enddo + close(izsc) +#endif +#ifdef MPI + endif +#endif + + return + end diff --git a/source/wham/src-NEWSC-NEWCORR/wham_calc1.F.safe b/source/wham/src-NEWSC-NEWCORR/wham_calc1.F.safe new file mode 100644 index 0000000..f51dcc4 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/wham_calc1.F.safe @@ -0,0 +1,1195 @@ + subroutine WHAM_CALC(islice,*) +! Weighed Histogram Analysis Method (WHAM) code +! Written by A. Liwo based on the work of Kumar et al., +! J.Comput.Chem., 13, 1011 (1992) +! +! 2/1/05 Multiple temperatures allowed. +! 2/2/05 Free energies calculated directly from data points +! acc. to Eq. (21) of Kumar et al.; final histograms also +! constructed based on this equation. +! 2/12/05 Multiple parameter sets included +! +! 2/2/05 Parallel version + implicit none + include "DIMENSIONS" + include "DIMENSIONS.ZSCOPT" + include "DIMENSIONS.FREE" + integer nGridT + parameter (NGridT=400) + integer MaxBinRms,MaxBinRgy + parameter (MaxBinRms=100,MaxBinRgy=100) + integer MaxHdim +c parameter (MaxHdim=200000) + parameter (MaxHdim=200) + integer maxinde + parameter (maxinde=200) +#ifdef MPI + include "mpif.h" + include "COMMON.MPI" + integer ierror,errcode,status(MPI_STATUS_SIZE) +#endif + include "COMMON.CONTROL" + include "COMMON.IOUNITS" + include "COMMON.FREE" + include "COMMON.ENERGIES" + include "COMMON.FFIELD" + include "COMMON.SBRIDGE" + include "COMMON.PROT" + include "COMMON.ENEPS" + integer MaxPoint,MaxPointProc + parameter (MaxPoint=MaxStr, + & MaxPointProc=MaxStr_Proc) + double precision finorm_max,potfac,entmin,entmax,expfac,vf + parameter (finorm_max=1.0d0) + integer islice + integer i,ii,j,jj,k,kk,l,m,ind,iter,t,tmax,ient,ientmax,iln + integer start,end,iharm,ib,iib,nbin1,nbin,nbin_rms,nbin_rgy, + & nbin_rmsrgy,liczba,iparm,nFi,indrgy,indrms + integer htot(0:MaxHdim),histent(0:2000) + double precision v(MaxPointProc,MaxR,MaxT_h,Max_Parm) + double precision energia(0:max_ene) +#ifdef MPI + integer tmax_t,upindE_p + double precision fi_p(MaxR,MaxT_h,Max_Parm) + double precision sumW_p(0:nGridT,Max_Parm), + & sumE_p(0:nGridT,Max_Parm),sumEsq_p(0:nGridT,Max_Parm), + & sumQ_p(MaxQ1,0:nGridT,Max_Parm), + & sumQsq_p(MaxQ1,0:nGridT,Max_Parm), + & sumEQ_p(MaxQ1,0:nGridT,Max_Parm), + & sumEprim_p(MaxQ1,0:nGridT,Max_Parm), + & sumEbis_p(0:nGridT,Max_Parm) + double precision hfin_p(0:MaxHdim,maxT_h), + & hfin_ent_p(0:MaxHdim),histE_p(0:maxindE),sumH, + & hrmsrgy_p(0:MaxBinRgy,0:MaxBinRms,maxT_h) + double precision rgymin_t,rmsmin_t,rgymax_t,rmsmax_t + double precision potEmin_t,entmin_p,entmax_p + integer histent_p(0:2000) + logical lprint /.true./ +#endif + double precision delta_T /1.0d0/ + double precision rgymin,rmsmin,rgymax,rmsmax + double precision sumW(0:NGridT,Max_Parm),sumE(0:NGridT,Max_Parm), + & sumEsq(0:NGridT,Max_Parm),sumQ(MaxQ1,0:NGridT,Max_Parm), + & sumQsq(MaxQ1,0:NGridT,Max_Parm),sumEQ(MaxQ1,0:NGridT,Max_Parm), + & sumEprim(0:NGridT,Max_Parm),sumEbis(0:NGridT,Max_Parm),betaT, + & weight,econstr + double precision fi(MaxR,maxT_h,Max_Parm), + & dd,dd1,dd2,hh,dmin,denom,finorm,avefi,pom, + & hfin(0:MaxHdim,maxT_h),histE(0:maxindE), + & hrmsrgy(0:MaxBinRgy,0:MaxBinRms,maxT_h), + & potEmin,ent, + & hfin_ent(0:MaxHdim),vmax,aux + double precision fT(6),fTprim(6),fTbis(6),quot,quotl1,quotl,kfacl, + & eprim,ebis,temper,kfac/2.4d0/,T0/300.0d0/,startGridT/200.0d0/, + & eplus,eminus,logfac,tanhT,tt + double precision etot,evdw,evdw_t,evdw2,ees,evdw1,ebe,etors, + & escloc,ehpb,ecorr,ecorr5,ecorr6,eello_turn4,eello_turn3, + & eturn6,eel_loc,edihcnstr,etors_d,estr,evdw2_14,esccor + + integer ind_point(maxpoint),upindE,indE + character*16 plik + character*1 licz1 + character*2 licz2 + character*3 licz3 + character*128 nazwa + integer ilen + external ilen + + write(licz2,'(bz,i2.2)') islice + nbin1 = 1.0d0/delta + write (iout,'(//80(1h-)/"Solving WHAM equations for slice", + & i2/80(1h-)//)') islice + write (iout,*) "delta",delta," nbin1",nbin1 + write (iout,*) "MaxN",MaxN," MaxQ",MaxQ," MaHdim",MaxHdim + call flush(iout) + dmin=0.0d0 + tmax=0 + potEmin=1.0d10 + rgymin=1.0d10 + rmsmin=1.0d10 + rgymax=0.0d0 + rmsmax=0.0d0 + do t=0,MaxN + htot(t)=0 + enddo +#ifdef MPI + do i=1,scount(me1) +#else + do i=1,ntot(islice) +#endif + do j=1,nParmSet + if (potE(i,j).le.potEmin) potEmin=potE(i,j) + enddo + if (q(nQ+1,i).lt.rmsmin) rmsmin=q(nQ+1,i) + if (q(nQ+1,i).gt.rmsmax) rmsmax=q(nQ+1,i) + if (q(nQ+2,i).lt.rgymin) rgymin=q(nQ+2,i) + if (q(nQ+2,i).gt.rgymax) rgymax=q(nQ+2,i) + ind_point(i)=0 + do j=nQ,1,-1 + ind=(q(j,i)-dmin+1.0d-8)/delta + if (j.eq.1) then + ind_point(i)=ind_point(i)+ind + else + ind_point(i)=ind_point(i)+nbin1**(j-1)*ind + endif +c write (iout,*) "i",i," j",j," q",q(j,i)," ind_point", +c & ind_point(i) + call flush(iout) + if (ind_point(i).lt.0 .or. ind_point(i).gt.MaxHdim) then + write (iout,*) "Error - index exceeds range for point",i, + & " q=",q(j,i)," ind",ind_point(i) +#ifdef MPI + write (iout,*) "Processor",me1 + call flush(iout) + call MPI_Abort(MPI_COMM_WORLD, Ierror, Errcode ) +#endif + stop + endif + enddo ! j + if (ind_point(i).gt.tmax) tmax=ind_point(i) + htot(ind_point(i))=htot(ind_point(i))+1 +#ifdef DEBUG + write (iout,*) "i",i,"q",(q(j,i),j=1,nQ)," ind",ind_point(i), + & " htot",htot(ind_point(i)) + call flush(iout) +#endif + enddo ! i + call flush(iout) + + nbin=nbin1**nQ-1 + write (iout,'(a)') "Numbers of counts in Q bins" + do t=0,tmax + if (htot(t).gt.0) then + write (iout,'(i15,$)') t + liczba=t + do j=1,nQ + jj = mod(liczba,nbin1) + liczba=liczba/nbin1 + write (iout,'(i5,$)') jj + enddo + write (iout,'(i8)') htot(t) + endif + enddo + do iparm=1,nParmSet + write (iout,'(a,i3)') "Number of data points for parameter set", + & iparm + write (iout,'(i7,$)') ((snk(m,ib,iparm,islice),m=1,nr(ib,iparm)), + & ib=1,nT_h(iparm)) + write (iout,'(i8)') stot(islice) + write (iout,'(a)') + enddo + call flush(iout) + +#ifdef MPI + call MPI_AllReduce(tmax,tmax_t,1,MPI_INTEGER,MPI_MAX, + & WHAM_COMM,IERROR) + tmax=tmax_t + call MPI_AllReduce(potEmin,potEmin_t,1,MPI_DOUBLE_PRECISION, + & MPI_MIN,WHAM_COMM,IERROR) + call MPI_AllReduce(rmsmin,rmsmin_t,1,MPI_DOUBLE_PRECISION, + & MPI_MIN,WHAM_COMM,IERROR) + call MPI_AllReduce(rmsmax,rmsmax_t,1,MPI_DOUBLE_PRECISION, + & MPI_MAX,WHAM_COMM,IERROR) + call MPI_AllReduce(rgymin,rgymin_t,1,MPI_DOUBLE_PRECISION, + & MPI_MIN,WHAM_COMM,IERROR) + call MPI_AllReduce(rgymax,rgymax_t,1,MPI_DOUBLE_PRECISION, + & MPI_MAX,WHAM_COMM,IERROR) + potEmin=potEmin_t/2 + rgymin=rgymin_t + rgymax=rgymax_t + rmsmin=rmsmin_t + rmsmax=rmsmax_t + write (iout,*) "potEmin",potEmin +#endif + rmsmin=deltrms*dint(rmsmin/deltrms) + rmsmax=deltrms*dint(rmsmax/deltrms) + rgymin=deltrms*dint(rgymin/deltrgy) + rgymax=deltrms*dint(rgymax/deltrgy) + nbin_rms=(rmsmax-rmsmin)/deltrms + nbin_rgy=(rgymax-rgymin)/deltrgy + write (iout,*) "rmsmin",rmsmin," rmsmax",rmsmax," rgymin",rgymin, + & " rgymax",rgymax," nbin_rms",nbin_rms," nbin_rgy",nbin_rgy + nFi=0 + do i=1,nParmSet + do j=1,nT_h(i) + nFi=nFi+nR(j,i) + enddo + enddo + write (iout,*) "nFi",nFi +! Compute the Boltzmann factor corresponing to restrain potentials in different +! simulations. +#ifdef MPI + do i=1,scount(me1) +#else + do i=1,ntot(islice) +#endif +c write (9,'(3i5,f10.5)') i,(iparm,potE(i,iparm),iparm=1,nParmSet) + do iparm=1,nParmSet +#ifdef DEBUG + write (iout,'(2i5,21f8.2)') i,iparm, + & (enetb(k,i,iparm),k=1,21) +#endif + call restore_parm(iparm) +#ifdef DEBUG + write (iout,*) wsc,wscp,welec,wvdwpp,wang,wtor,wscloc, + & wcorr,wcorr5,wcorr6,wturn4,wturn3,wturn6,wel_loc, + & wtor_d,wsccor,wbond +#endif + do ib=1,nT_h(iparm) + if (rescale_mode.eq.1) then + quot=1.0d0/(beta_h(ib,iparm)*1.987D-3*T0) + quotl=1.0d0 + kfacl=1.0d0 + do l=1,5 + quotl1=quotl + quotl=quotl*quot + kfacl=kfacl*kfac + fT(l)=kfacl/(kfacl-1.0d0+quotl) + enddo +#if defined(FUNCTH) + tt = 1.0d0/(beta_h(ib,iparm)*1.987D-3) + ft(6)=(320.0d0+80.0d0*dtanh((tt-320.0d0)/80.0d0))/320.0d0 +#elif defined(FUNCT) + ft(6)=1.0d0/(beta_h(ib,iparm)*1.987D-3*T0) +#else + ft(6)=1.0d0 +#endif + else if (rescale_mode.eq.2) then + quot=1.0d0/(T0*beta_h(ib,iparm)*1.987D-3) + quotl=1.0d0 + do l=1,5 + quotl=quotl*quot + fT(l)=1.12692801104297249644d0/ + & dlog(dexp(quotl)+dexp(-quotl)) + enddo +#if defined(FUNCTH) + tt = 1.0d0/(beta_h(ib,iparm)*1.987D-3) + ft(6)=(320.0d0+80.0d0*dtanh((tt-320.0d0)/80.0d0))/320.0d0 +#elif defined(FUNCT) + ft(6)=1.0d0/(beta_h(ib,iparm)*1.987D-3*T0) +#else + ft(6)=1.0d0 +#endif +c write (iout,*) 1.0d0/(beta_h(ib,iparm)*1.987D-3),ft + else if (rescale_mode.eq.0) then + do l=1,6 + fT(l)=1.0d0 + enddo + else + write (iout,*) "Error in WHAM_CALC: wrong RESCALE_MODE", + & rescale_mode + call flush(iout) + return1 + endif + evdw=enetb(1,i,iparm) + evdw_t=enetb(21,i,iparm) +#ifdef SCP14 + evdw2_14=enetb(17,i,iparm) + evdw2=enetb(2,i,iparm)+evdw2_14 +#else + evdw2=enetb(2,i,iparm) + evdw2_14=0.0d0 +#endif +#ifdef SPLITELE + ees=enetb(3,i,iparm) + evdw1=enetb(16,i,iparm) +#else + ees=enetb(3,i,iparm) + evdw1=0.0d0 +#endif + ecorr=enetb(4,i,iparm) + ecorr5=enetb(5,i,iparm) + ecorr6=enetb(6,i,iparm) + eel_loc=enetb(7,i,iparm) + eello_turn3=enetb(8,i,iparm) + eello_turn4=enetb(9,i,iparm) + eturn6=enetb(10,i,iparm) + ebe=enetb(11,i,iparm) + escloc=enetb(12,i,iparm) + etors=enetb(13,i,iparm) + etors_d=enetb(14,i,iparm) + ehpb=enetb(15,i,iparm) + estr=enetb(18,i,iparm) + esccor=enetb(19,i,iparm) + edihcnstr=enetb(20,i,iparm) +#ifdef DEBUG + write (iout,'(3i5,6f5.2,14f12.3)') i,ib,iparm,(ft(l),l=1,6), + & evdw+evdw_t,evdw2,ees,evdw1,ecorr,eel_loc,estr,ebe,escloc, + & etors,etors_d,eello_turn3,eello_turn4,esccor +#endif + +#ifdef SPLITELE + etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2+ft(1)*welec*ees + & +wvdwpp*evdw1 + & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc + & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 + & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 + & +ft(2)*wturn3*eello_turn3 + & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc + & +edihcnstr+ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor + & +wbond*estr +#else + etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2 + & +ft(1)*welec*(ees+evdw1) + & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc + & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 + & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 + & +ft(2)*wturn3*eello_turn3 + & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc+edihcnstr + & +ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor + & +wbond*estr +#endif +#ifdef DEBUG + write (iout,*) i,iparm,1.0d0/(beta_h(ib,iparm)*1.987D-3), + & etot,potEmin +#endif +#ifdef DEBUG + if (iparm.eq.1 .and. ib.eq.1) then + write (iout,*)"Conformation",i + energia(0)=etot + do k=1,max_ene + energia(k)=enetb(k,i,iparm) + enddo + call enerprint(energia(0),fT) + endif +#endif + do kk=1,nR(ib,iparm) + Econstr=0.0d0 + do j=1,nQ + dd = q(j,i) + Econstr=Econstr+Kh(j,kk,ib,iparm) + & *(dd-q0(j,kk,ib,iparm))**2 + enddo + v(i,kk,ib,iparm)= + & -beta_h(ib,iparm)*(etot-potEmin+Econstr) +#ifdef DEBUG + write (iout,'(4i5,4e15.5)') i,kk,ib,iparm, + & etot,potEmin,etot-potEmin,v(i,kk,ib,iparm) +#endif + enddo ! kk + enddo ! ib + enddo ! iparm + enddo ! i +! Simple iteration to calculate free energies corresponding to all simulation +! runs. + do iter=1,maxit + +! Compute new free-energy values corresponding to the righ-hand side of the +! equation and their derivatives. + write (iout,*) "------------------------fi" +#ifdef MPI + do t=1,scount(me1) +#else + do t=1,ntot(islice) +#endif + vmax=-1.0d+20 + do i=1,nParmSet + do k=1,nT_h(i) + do l=1,nR(k,i) + vf=v(t,l,k,i)+f(l,k,i) + if (vf.gt.vmax) vmax=vf + enddo + enddo + enddo + denom=0.0d0 + do i=1,nParmSet + do k=1,nT_h(i) + do l=1,nR(k,i) + aux=f(l,k,i)+v(t,l,k,i)-vmax + if (aux.gt.-200.0d0) + & denom=denom+snk(l,k,i,islice)*dexp(aux) + enddo + enddo + enddo + entfac(t)=-dlog(denom)-vmax +#ifdef DEBUG + write (iout,*) t,"vmax",vmax," denom",denom,"entfac",entfac(t) +#endif + enddo + do iparm=1,nParmSet + do iib=1,nT_h(iparm) + do ii=1,nR(iib,iparm) +#ifdef MPI + fi_p(ii,iib,iparm)=0.0d0 + do t=1,scount(me) + fi_p(ii,iib,iparm)=fi_p(ii,iib,iparm) + & +dexp(v(t,ii,iib,iparm)+entfac(t)) +#ifdef DEBUG + write (iout,'(4i5,3e15.5)') t,ii,iib,iparm, + & v(t,ii,iib,iparm),entfac(t),fi_p(ii,iib,iparm) +#endif + enddo +#else + fi(ii,iib,iparm)=0.0d0 + do t=1,ntot(islice) + fi(ii,iib,iparm)=fi(ii,iib,iparm) + & +dexp(v(t,ii,iib,iparm)+entfac(t)) + enddo +#endif + enddo ! ii + enddo ! iib + enddo ! iparm + +#ifdef MPI +#ifdef DEBUG + write (iout,*) "fi before MPI_Reduce me",me,' master',master + do iparm=1,nParmSet + do ib=1,nT_h(nparmset) + write (iout,*) "iparm",iparm," ib",ib + write (iout,*) "beta=",beta_h(ib,iparm) + write (iout,'(8e15.5)') (fi_p(i,ib,iparm),i=1,nR(ib,iparm)) + enddo + enddo +#endif + write (iout,*) "REDUCE size",maxR,MaxT_h,nParmSet, + & maxR*MaxT_h*nParmSet + write (iout,*) "MPI_COMM_WORLD",MPI_COMM_WORLD, + & " WHAM_COMM",WHAM_COMM + call MPI_Reduce(fi_p(1,1,1),fi(1,1,1),maxR*MaxT_h*nParmSet, + & MPI_DOUBLE_PRECISION, + & MPI_SUM,Master,WHAM_COMM,IERROR) +#ifdef DEBUG + write (iout,*) "fi after MPI_Reduce nparmset",nparmset + do iparm=1,nParmSet + write (iout,*) "iparm",iparm + do ib=1,nT_h(iparm) + write (iout,*) "beta=",beta_h(ib,iparm) + write (iout,'(8e15.5)') (fi(i,ib,iparm),i=1,nR(ib,iparm)) + enddo + enddo +#endif + if (me1.eq.Master) then +#endif + avefi=0.0d0 + do iparm=1,nParmSet + do ib=1,nT_h(iparm) + do i=1,nR(ib,iparm) + fi(i,ib,iparm)=-dlog(fi(i,ib,iparm)) + avefi=avefi+fi(i,ib,iparm) + enddo + enddo + enddo + avefi=avefi/nFi + do iparm=1,nParmSet + write (iout,*) "Parameter set",iparm + do ib =1,nT_h(iparm) + write (iout,*) "beta=",beta_h(ib,iparm) + do i=1,nR(ib,iparm) + fi(i,ib,iparm)=fi(i,ib,iparm)-avefi + enddo + write (iout,'(8f10.5)') (fi(i,ib,iparm),i=1,nR(ib,iparm)) + write (iout,'(8f10.5)') (f(i,ib,iparm),i=1,nR(ib,iparm)) + enddo + enddo + +! Compute the norm of free-energy increments. + finorm=0.0d0 + do iparm=1,nParmSet + do ib=1,nT_h(iparm) + do i=1,nR(ib,iparm) + finorm=finorm+dabs(fi(i,ib,iparm)-f(i,ib,iparm)) + f(i,ib,iparm)=fi(i,ib,iparm) + enddo + enddo + enddo + + write (iout,*) 'Iteration',iter,' finorm',finorm + +#ifdef MPI + endif + call MPI_Bcast(f(1,1,1),MaxR*MaxT_h*nParmSet, + & MPI_DOUBLE_PRECISION,Master, + & WHAM_COMM,IERROR) + call MPI_Bcast(finorm,1,MPI_DOUBLE_PRECISION,Master, + & WHAM_COMM,IERROR) +#endif +! Exit, if the increment norm is smaller than pre-assigned tolerance. + if (finorm.lt.fimin) then + write (iout,*) 'Iteration converged' + goto 20 + endif + + enddo ! iter + + 20 continue +! Now, put together the histograms from all simulations, in order to get the +! unbiased total histogram. +#ifdef MPI + do t=0,tmax + hfin_ent_p(t)=0.0d0 + enddo +#else + do t=0,tmax + hfin_ent(t)=0.0d0 + enddo +#endif + write (iout,*) "--------------hist" +#ifdef MPI + do iparm=1,nParmSet + do i=0,nGridT + sumW_p(i,iparm)=0.0d0 + sumE_p(i,iparm)=0.0d0 + sumEbis_p(i,iparm)=0.0d0 + sumEsq_p(i,iparm)=0.0d0 + do j=1,nQ+2 + sumQ_p(j,i,iparm)=0.0d0 + sumQsq_p(j,i,iparm)=0.0d0 + sumEQ_p(j,i,iparm)=0.0d0 + enddo + enddo + enddo + upindE_p=0 +#else + do iparm=1,nParmSet + do i=0,nGridT + sumW(i,iparm)=0.0d0 + sumE(i,iparm)=0.0d0 + sumEbis(i,iparm)=0.0d0 + sumEsq(i,iparm)=0.0d0 + do j=1,nQ+2 + sumQ(j,i,iparm)=0.0d0 + sumQsq(j,i,iparm)=0.0d0 + sumEQ(j,i,iparm)=0.0d0 + enddo + enddo + enddo + upindE=0 +#endif +c 8/26/05 entropy distribution +#ifdef MPI + entmin_p=1.0d10 + entmax_p=-1.0d10 + do t=1,scount(me1) +c ent=-dlog(entfac(t)) + ent=entfac(t) + if (ent.lt.entmin_p) entmin_p=ent + if (ent.gt.entmax_p) entmax_p=ent + enddo + write (iout,*) "entmin",entmin_p," entmax",entmax_p + call flush(iout) + call MPI_Allreduce(entmin_p,entmin,1,MPI_DOUBLE_PRECISION,MPI_MIN, + & WHAM_COMM,IERROR) + call MPI_Allreduce(entmax_p,entmax,1,MPI_DOUBLE_PRECISION,MPI_MAX, + & WHAM_COMM,IERROR) + ientmax=entmax-entmin + if (ientmax.gt.2000) ientmax=2000 + write (iout,*) "entmin",entmin," entmax",entmax," ientmax",ientmax + call flush(iout) + do t=1,scount(me1) +c ient=-dlog(entfac(t))-entmin + ient=entfac(t)-entmin + if (ient.le.2000) histent_p(ient)=histent_p(ient)+1 + enddo + call MPI_Allreduce(histent_p(0),histent(0),ientmax+1,MPI_INTEGER, + & MPI_SUM,WHAM_COMM,IERROR) + if (me1.eq.Master) then + write (iout,*) "Entropy histogram" + do i=0,ientmax + write(iout,'(f15.4,i10)') entmin+i,histent(i) + enddo + endif +#else + entmin=1.0d10 + entmax=-1.0d10 + do t=1,ntot(islice) + ent=entfac(t) + if (ent.lt.entmin) entmin=ent + if (ent.gt.entmax) entmax=ent + enddo + ientmax=-dlog(entmax)-entmin + if (ientmax.gt.2000) ientmax=2000 + do t=1,ntot(islice) + ient=entfac(t)-entmin + if (ient.le.2000) histent(ient)=histent(ient)+1 + enddo + write (iout,*) "Entropy histogram" + do i=0,ientmax + write(iout,'(2f15.4)') entmin+i,histent(i) + enddo +#endif + +#ifdef MPI +c write (iout,*) "me1",me1," scount",scount(me1) + + do iparm=1,nParmSet + +#ifdef MPI + do ib=1,nT_h(iparm) + do t=0,tmax + hfin_p(t,ib)=0.0d0 + enddo + enddo + do i=1,maxindE + histE_p(i)=0.0d0 + enddo +#else + do ib=1,nT_h(iparm) + do t=0,tmax + hfin(t,ib)=0.0d0 + enddo + enddo + do i=1,maxindE + histE(i)=0.0d0 + enddo +#endif + do ib=1,nT_h(iparm) + do i=0,MaxBinRms + do j=0,MaxBinRgy + hrmsrgy(j,i,ib)=0.0d0 +#ifdef MPI + hrmsrgy_p(j,i,ib)=0.0d0 +#endif + enddo + enddo + enddo + + do t=1,scount(me1) +#else + do t=1,ntot(islice) +#endif + ind = ind_point(t) +#ifdef MPI + hfin_ent_p(ind)=hfin_ent_p(ind)+dexp(entfac(t)) +#else + hfin_ent(ind)=hfin_ent(ind)+dexp(entfac(t)) +#endif +c write (iout,'(2i5,20f8.2)') t,t,(enetb(k,t,iparm),k=1,18) + call restore_parm(iparm) + evdw=enetb(21,t,iparm) + evdw_t=enetb(1,t,iparm) +#ifdef SCP14 + evdw2_14=enetb(17,t,iparm) + evdw2=enetb(2,t,iparm)+evdw2_14 +#else + evdw2=enetb(2,t,iparm) + evdw2_14=0.0d0 +#endif +#ifdef SPLITELE + ees=enetb(3,t,iparm) + evdw1=enetb(16,t,iparm) +#else + ees=enetb(3,t,iparm) + evdw1=0.0d0 +#endif + ecorr=enetb(4,t,iparm) + ecorr5=enetb(5,t,iparm) + ecorr6=enetb(6,t,iparm) + eel_loc=enetb(7,t,iparm) + eello_turn3=enetb(8,t,iparm) + eello_turn4=enetb(9,t,iparm) + eturn6=enetb(10,t,iparm) + ebe=enetb(11,t,iparm) + escloc=enetb(12,t,iparm) + etors=enetb(13,t,iparm) + etors_d=enetb(14,t,iparm) + ehpb=enetb(15,t,iparm) + estr=enetb(18,t,iparm) + esccor=enetb(19,t,iparm) + edihcnstr=enetb(20,t,iparm) + edihcnstr=0.0d0 + do k=0,nGridT + betaT=startGridT+k*delta_T + temper=betaT +c fT=T0/betaT +c ft=2*T0/(T0+betaT) + if (rescale_mode.eq.1) then + quot=betaT/T0 + quotl=1.0d0 + kfacl=1.0d0 + do l=1,5 + quotl1=quotl + quotl=quotl*quot + kfacl=kfacl*kfac + denom=kfacl-1.0d0+quotl + fT(l)=kfacl/denom + ftprim(l)=-l*ft(l)*quotl1/(T0*denom) + ftbis(l)=l*kfacl*quotl1* + & (2*l*quotl-(l-1)*denom)/(quot*t0*t0*denom**3) + enddo +#if defined(FUNCTH) + ft(6)=(320.0d0+80.0d0*dtanh((betaT-320.0d0)/80.0d0))/ + & 320.0d0 + ftprim(6)=1.0d0/(320.0d0*dcosh((betaT-320.0d0)/80.0d0)**2) + ftbis(6)=-2.0d0*dtanh((betaT-320.0d0)/80.0d0) + & /(320.0d0*80.0d0*dcosh((betaT-320.0d0)/80.0d0)**3) +#elif defined(FUNCT) + fT(6)=betaT/T0 + ftprim(6)=1.0d0/T0 + ftbis(6)=0.0d0 +#else + fT(6)=1.0d0 + ftprim(6)=0.0d0 + ftbis(6)=0.0d0 +#endif + else if (rescale_mode.eq.2) then + quot=betaT/T0 + quotl=1.0d0 + do l=1,5 + quotl1=quotl + quotl=quotl*quot + eplus=dexp(quotl) + eminus=dexp(-quotl) + logfac=1.0d0/dlog(eplus+eminus) + tanhT=(eplus-eminus)/(eplus+eminus) + fT(l)=1.12692801104297249644d0*logfac + ftprim(l)=-l*quotl1*ft(l)*tanhT*logfac/T0 + ftbis(l)=(l-1)*ftprim(l)/(quot*T0)- + & 2*l*quotl1/T0*logfac* + & (2*l*quotl1*ft(l)/(T0*(eplus+eminus)**2) + & +ftprim(l)*tanhT) + enddo +#if defined(FUNCTH) + ft(6)=(320.0d0+80.0d0*dtanh((betaT-320.0d0)/80.0d0))/ + & 320.0d0 + ftprim(6)=1.0d0/(320.0d0*dcosh((betaT-320.0d0)/80.0d0)**2) + ftbis(6)=-2.0d0*dtanh((betaT-320.0d0)/80.0d0) + & /(320.0d0*80.0d0*dcosh((betaT-320.0d0)/80.0d0)**3) +#elif defined(FUNCT) + fT(6)=betaT/T0 + ftprim(6)=1.0d0/T0 + ftbis(6)=0.0d0 +#else + fT(6)=1.0d0 + ftprim(6)=0.0d0 + ftbis(6)=0.0d0 +#endif + else if (rescale_mode.eq.0) then + do l=1,5 + fT(l)=1.0d0 + ftprim(l)=0.0d0 + enddo + else + write (iout,*) "Error in WHAM_CALC: wrong RESCALE_MODE", + & rescale_mode + call flush(iout) + return1 + endif +c write (iout,*) "ftprim",ftprim +c write (iout,*) "ftbis",ftbis + betaT=1.0d0/(1.987D-3*betaT) +#ifdef SPLITELE + etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2+ft(1)*welec*ees + & +wvdwpp*evdw1 + & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc + & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 + & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 + & +ft(2)*wturn3*eello_turn3 + & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc + & +edihcnstr+ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor + & +wbond*estr + eprim=ftprim(6)*evdw_t+ftprim(1)*welec*ees + & +ftprim(1)*wtor*etors+ + & ftprim(3)*wcorr*ecorr+ftprim(4)*wcorr5*ecorr5+ + & ftprim(5)*wcorr6*ecorr6+ftprim(3)*wturn4*eello_turn4+ + & ftprim(2)*wturn3*eello_turn3+ftprim(5)*wturn6*eturn6+ + & ftprim(2)*wel_loc*eel_loc+ftprim(2)*wtor_d*etors_d+ + & ftprim(1)*wsccor*esccor + ebis=ftbis(1)*welec*ees+ftbis(1)*wtor*etors+ + & ftbis(3)*wcorr*ecorr+ftbis(4)*wcorr5*ecorr5+ + & ftbis(5)*wcorr6*ecorr6+ftbis(3)*wturn4*eello_turn4+ + & ftbis(2)*wturn3*eello_turn3+ftbis(5)*wturn6*eturn6+ + & ftbis(2)*wel_loc*eel_loc+ftbis(2)*wtor_d*etors_d+ + & ftbis(1)*wsccor*esccor +#else + etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2 + & +ft(1)*welec*(ees+evdw1) + & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc + & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 + & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 + & +ft(2)*wturn3*eello_turn3 + & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc+edihcnstr + & +ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor + & +wbond*estr + eprim=ftprim(6)*evdw_t+ftprim(1)*welec*(ees+evdw1) + & +ftprim(1)*wtor*etors+ + & ftprim(3)*wcorr*ecorr+ftprim(4)*wcorr5*ecorr5+ + & ftprim(5)*wcorr6*ecorr6+ftprim(3)*wturn4*eello_turn4+ + & ftprim(2)*wturn3*eello_turn3+ftprim(5)*wturn6*eturn6+ + & ftprim(2)*wel_loc*eel_loc+ftprim(2)*wtor_d*etors_d+ + & ftprim(1)*wsccor*esccor + ebis=ftbis(1)*welec*(ees+evdw1)+ftbis(1)*wtor*etors+ + & ftbis(3)*wcorr*ecorr+ftbis(4)*wcorr5*ecorr5+ + & ftbis(5)*wcorr6*ecorr6+ftbis(3)*wturn4*eello_turn4+ + & ftbis(2)*wturn3*eello_turn3+ftbis(5)*wturn6*eturn6+ + & ftbis(2)*wel_loc*eel_loc+ftbis(2)*wtor_d*etors_d+ + & ftprim(1)*wsccor*esccor +#endif + weight=dexp(-betaT*(etot-potEmin)+entfac(t)) +#define DEBUG +#ifdef DEBUG + write (iout,*) "iparm",iparm," t",t," betaT",betaT, + & " etot",etot," entfac",entfac(t), + & " weight",weight," ebis",ebis +#endif +#undef DEBUG + etot=etot-temper*eprim +#ifdef MPI + sumW_p(k,iparm)=sumW_p(k,iparm)+weight + sumE_p(k,iparm)=sumE_p(k,iparm)+etot*weight + sumEbis_p(k,iparm)=sumEbis_p(k,iparm)+ebis*weight + sumEsq_p(k,iparm)=sumEsq_p(k,iparm)+etot**2*weight + do j=1,nQ+2 + sumQ_p(j,k,iparm)=sumQ_p(j,k,iparm)+q(j,t)*weight + sumQsq_p(j,k,iparm)=sumQsq_p(j,k,iparm)+q(j,t)**2*weight + sumEQ_p(j,k,iparm)=sumEQ_p(j,k,iparm) + & +etot*q(j,t)*weight + enddo +#else + sumW(k,iparm)=sumW(k,iparm)+weight + sumE(k,iparm)=sumE(k,iparm)+etot*weight + sumEbis(k,iparm)=sumEbis(k,iparm)+ebis*weight + sumEsq(k,iparm)=sumEsq(k,iparm)+etot**2*weight + do j=1,nQ+2 + sumQ(j,k,iparm)=sumQ(j,k,iparm)+q(j,t)*weight + sumQsq(j,k,iparm)=sumQsq(j,k,iparm)+q(j,t)**2*weight + sumEQ(j,k,iparm)=sumEQ(j,k,iparm) + & +etot*q(j,t)*weight + enddo +#endif + enddo + indE = aint(potE(t,iparm)-aint(potEmin)) + if (indE.ge.0 .and. indE.le.maxinde) then + if (indE.gt.upindE_p) upindE_p=indE + histE_p(indE)=histE_p(indE)+dexp(-entfac(t)) + endif +#ifdef MPI + do ib=1,nT_h(iparm) + expfac=dexp(-beta_h(ib,iparm)*(etot-potEmin)+entfac(t)) + hfin_p(ind,ib)=hfin_p(ind,ib)+ + & dexp(-beta_h(ib,iparm)*(etot-potEmin)+entfac(t)) + if (rmsrgymap) then + indrgy=dint((q(nQ+2,t)-rgymin)/deltrgy) + indrms=dint((q(nQ+1,t)-rmsmin)/deltrms) + hrmsrgy_p(indrgy,indrms,ib)= + & hrmsrgy_p(indrgy,indrms,ib)+expfac + endif + enddo +#else + do ib=1,nT_h(iparm) + expfac=dexp(-beta_h(ib,iparm)*(etot-potEmin)+entfac(t)) + hfin(ind,ib)=hfin(ind,ib)+ + & dexp(-beta_h(ib,iparm)*(etot-potEmin)+entfac(t)) + if (rmsrgymap) then + indrgy=dint((q(nQ+2,t)-rgymin)/deltrgy) + indrms=dint((q(nQ+1,t)-rmsmin)/deltrms) + hrmsrgy(indrgy,indrms,ib)= + & hrmsrgy(indrgy,indrms,ib)+expfac + endif + enddo +#endif + enddo ! t + do ib=1,nT_h(iparm) + if (histout) call MPI_Reduce(hfin_p(0,ib),hfin(0,ib),nbin, + & MPI_DOUBLE_PRECISION,MPI_SUM,Master,WHAM_COMM,IERROR) + if (rmsrgymap) then + call MPI_Reduce(hrmsrgy_p(0,0,ib),hrmsrgy(0,0,ib), + & (MaxBinRgy+1)*(nbin_rms+1),MPI_DOUBLE_PRECISION,MPI_SUM,Master, + & WHAM_COMM,IERROR) + endif + enddo + call MPI_Reduce(upindE_p,upindE,1, + & MPI_INTEGER,MPI_MAX,Master,WHAM_COMM,IERROR) + call MPI_Reduce(histE_p(0),histE(0),maxindE, + & MPI_DOUBLE_PRECISION,MPI_SUM,Master,WHAM_COMM,IERROR) + + if (me1.eq.master) then + + if (histout) then + + write (iout,'(6x,$)') + write (iout,'(f20.2,$)') (1.0d0/(1.987D-3*beta_h(ib,iparm)), + & ib=1,nT_h(iparm)) + write (iout,*) + + write (iout,'(/a)') 'Final histograms' + if (histfile) then + if (nslice.eq.1) then + if (separate_parset) then + write(licz3,"(bz,i3.3)") myparm + histname=prefix(:ilen(prefix))//'_par'//licz3//'.hist' + else + histname=prefix(:ilen(prefix))//'.hist' + endif + else + if (separate_parset) then + write(licz3,"(bz,i3.3)") myparm + histname=prefix(:ilen(prefix))//'_par'//licz3// + & '_slice_'//licz2//'.hist' + else + histname=prefix(:ilen(prefix))//'_slice_'//licz2//'.hist' + endif + endif +#if defined(AIX) || defined(PGI) + open (ihist,file=histname,position='append') +#else + open (ihist,file=histname,access='append') +#endif + endif + + do t=0,tmax + liczba=t + sumH=0.0d0 + do ib=1,nT_h(iparm) + sumH=sumH+hfin(t,ib) + enddo + if (sumH.gt.0.0d0) then + do j=1,nQ + jj = mod(liczba,nbin1) + liczba=liczba/nbin1 + write (iout,'(f6.3,$)') dmin+(jj+0.5d0)*delta + if (histfile) + & write (ihist,'(f6.3,$)') dmin+(jj+0.5d0)*delta + enddo + do ib=1,nT_h(iparm) + write (iout,'(e20.10,$)') hfin(t,ib) + if (histfile) write (ihist,'(e20.10,$)') hfin(t,ib) + enddo + write (iout,'(i5)') iparm + if (histfile) write (ihist,'(i5)') iparm + endif + enddo + + endif + + if (entfile) then + if (nslice.eq.1) then + if (separate_parset) then + write(licz3,"(bz,i3.3)") myparm + histname=prefix(:ilen(prefix))//"_par"//licz3//'.ent' + else + histname=prefix(:ilen(prefix))//'.ent' + endif + else + if (separate_parset) then + write(licz3,"(bz,i3.3)") myparm + histname=prefix(:ilen(prefix))//'par_'//licz3// + & '_slice_'//licz2//'.ent' + else + histname=prefix(:ilen(prefix))//'_slice_'//licz2//'.ent' + endif + endif +#if defined(AIX) || defined(PGI) + open (ihist,file=histname,position='append') +#else + open (ihist,file=histname,access='append') +#endif + write (ihist,'(a)') "# Microcanonical entropy" + do i=0,upindE + write (ihist,'(f8.0,$)') dint(potEmin)+i + if (histE(i).gt.0.0e0) then + write (ihist,'(f15.5,$)') dlog(histE(i)) + else + write (ihist,'(f15.5,$)') 0.0d0 + endif + enddo + write (ihist,*) + close(ihist) + endif + write (iout,*) "Microcanonical entropy" + do i=0,upindE + write (iout,'(f8.0,$)') dint(potEmin)+i + if (histE(i).gt.0.0e0) then + write (iout,'(f15.5,$)') dlog(histE(i)) + else + write (iout,'(f15.5,$)') 0.0d0 + endif + write (iout,*) + enddo + if (rmsrgymap) then + if (nslice.eq.1) then + if (separate_parset) then + write(licz3,"(bz,i3.3)") myparm + histname=prefix(:ilen(prefix))//'_par'//licz3//'.rmsrgy' + else + histname=prefix(:ilen(prefix))//'.rmsrgy' + endif + else + if (separate_parset) then + write(licz3,"(bz,i3.3)") myparm + histname=prefix(:ilen(prefix))//'_par'//licz3// + & '_slice_'//licz2//'.rmsrgy' + else + histname=prefix(:ilen(prefix))//'_slice_'//licz2//'.rmsrgy' + endif + endif +#if defined(AIX) || defined(PGI) + open (ihist,file=histname,position='append') +#else + open (ihist,file=histname,access='append') +#endif + do i=0,nbin_rms + do j=0,nbin_rgy + write(ihist,'(2f8.2,$)') + & rgymin+deltrgy*j,rmsmin+deltrms*i + do ib=1,nT_h(iparm) + if (hrmsrgy(j,i,ib).gt.0.0d0) then + write(ihist,'(e14.5,$)') + & -dlog(hrmsrgy(j,i,ib))/beta_h(ib,iparm) + & +potEmin + else + write(ihist,'(e14.5,$)') 1.0d6 + endif + enddo + write (ihist,'(i2)') iparm + enddo + enddo + close(ihist) + endif + endif + enddo ! iparm +#ifdef MPI + call MPI_Reduce(hfin_ent_p(0),hfin_ent(0),nbin, + & MPI_DOUBLE_PRECISION,MPI_SUM,Master,WHAM_COMM,IERROR) + call MPI_Reduce(sumW_p(0,1),sumW(0,1),(nGridT+1)*nParmSet, + & MPI_DOUBLE_PRECISION,MPI_SUM,Master,WHAM_COMM,IERROR) + call MPI_Reduce(sumE_p(0,1),sumE(0,1),(nGridT+1)*nParmSet, + & MPI_DOUBLE_PRECISION,MPI_SUM,Master,WHAM_COMM,IERROR) + call MPI_Reduce(sumEbis_p(0,1),sumEbis(0,1),(nGridT+1)*nParmSet, + & MPI_DOUBLE_PRECISION,MPI_SUM,Master,WHAM_COMM,IERROR) + call MPI_Reduce(sumEsq_p(0,1),sumEsq(0,1),(nGridT+1)*nParmSet, + & MPI_DOUBLE_PRECISION,MPI_SUM,Master,WHAM_COMM,IERROR) + call MPI_Reduce(sumQ_p(1,0,1),sumQ(1,0,1), + & MaxQ1*(nGridT+1)*nParmSet,MPI_DOUBLE_PRECISION,MPI_SUM,Master, + & WHAM_COMM,IERROR) + call MPI_Reduce(sumQsq_p(1,0,1),sumQsq(1,0,1), + & MaxQ1*(nGridT+1)*nParmSet,MPI_DOUBLE_PRECISION,MPI_SUM,Master, + & WHAM_COMM,IERROR) + call MPI_Reduce(sumEQ_p(1,0,1),sumEQ(1,0,1), + & MaxQ1*(nGridT+1)*nParmSet,MPI_DOUBLE_PRECISION,MPI_SUM,Master, + & WHAM_COMM,IERROR) + if (me.eq.master) then +#endif + write (iout,'(/a)') 'Thermal characteristics of folding' + if (nslice.eq.1) then + nazwa=prefix + else + nazwa=prefix(:ilen(prefix))//"_slice_"//licz2 + endif + iln=ilen(nazwa) + if (nparmset.eq.1 .and. .not.separate_parset) then + nazwa=nazwa(:iln)//".thermal" + else if (nparmset.eq.1 .and. separate_parset) then + write(licz3,"(bz,i3.3)") myparm + nazwa=nazwa(:iln)//"_par_"//licz3//".thermal" + endif + do iparm=1,nParmSet + if (nparmset.gt.1) then + write(licz3,"(bz,i3.3)") iparm + nazwa=nazwa(:iln)//"_par_"//licz3//".thermal" + endif + open(34,file=nazwa) + if (separate_parset) then + write (iout,'(a,i3)') "Parameter set",myparm + else + write (iout,'(a,i3)') "Parameter set",iparm + endif + do i=0,NGridT + sumE(i,iparm)=sumE(i,iparm)/sumW(i,iparm) + sumEbis(i,iparm)=(startGridT+i*delta_T)*sumEbis(i,iparm)/ + & sumW(i,iparm) + sumEsq(i,iparm)=(sumEsq(i,iparm)/sumW(i,iparm) + & -sumE(i,iparm)**2)/(1.987D-3*(startGridT+i*delta_T)**2) + do j=1,nQ+2 + sumQ(j,i,iparm)=sumQ(j,i,iparm)/sumW(i,iparm) + sumQsq(j,i,iparm)=sumQsq(j,i,iparm)/sumW(i,iparm) + & -sumQ(j,i,iparm)**2 + sumEQ(j,i,iparm)=sumEQ(j,i,iparm)/sumW(i,iparm) + & -sumQ(j,i,iparm)*sumE(i,iparm) + enddo + sumW(i,iparm)=-dlog(sumW(i,iparm))*(1.987D-3* + & (startGridT+i*delta_T))+potEmin + write (iout,'(f7.1,2f15.5,$)') startGridT+i*delta_T, + & sumW(i,iparm),sumE(i,iparm) + write (iout,'(f10.5,$)') (sumQ(j,i,iparm),j=1,nQ+2) + write (iout,'(e15.5,$)') sumEsq(i,iparm)-sumEbis(i,iparm), + & (sumQsq(j,i,iparm),j=1,nQ+2),(sumEQ(j,i,iparm),j=1,nQ+2) + write (iout,*) + write (34,'(f7.1,2f15.5,$)') startGridT+i*delta_T, + & sumW(i,iparm),sumE(i,iparm) + write (34,'(f10.5,$)') (sumQ(j,i,iparm),j=1,nQ+2) + write (34,'(e15.5,$)') sumEsq(i,iparm)-sumEbis(i,iparm), + & (sumQsq(j,i,iparm),j=1,nQ+2),(sumEQ(j,i,iparm),j=1,nQ+2) + write (34,*) + enddo + close(34) + enddo + if (histout) then + do t=0,tmax + if (hfin_ent(t).gt.0.0d0) then + liczba=t + jj = mod(liczba,nbin1) + write (iout,'(f6.3,e20.10," ent")') dmin+(jj+0.5d0)*delta, + & hfin_ent(t) + if (histfile) write (ihist,'(f6.3,e20.10," ent")') + & dmin+(jj+0.5d0)*delta, + & hfin_ent(t) + endif + enddo + if (histfile) close(ihist) + endif + +#ifdef ZSCORE +! Write data for zscore + if (nslice.eq.1) then + zscname=prefix(:ilen(prefix))//".zsc" + else + zscname=prefix(:ilen(prefix))//"_slice_"//licz2//".zsc" + endif +#if defined(AIX) || defined(PGI) + open (izsc,file=prefix(:ilen(prefix))//'.zsc',position='append') +#else + open (izsc,file=prefix(:ilen(prefix))//'.zsc',access='append') +#endif + write (izsc,'("NQ=",i1," NPARM=",i1)') nQ,nParmSet + do iparm=1,nParmSet + write (izsc,'("NT=",i1)') nT_h(iparm) + do ib=1,nT_h(iparm) + write (izsc,'("TEMP=",f6.1," NR=",i2," SNK=",$)') + & 1.0d0/(beta_h(ib,iparm)*1.987D-3),nR(ib,iparm) + jj = min0(nR(ib,iparm),7) + write (izsc,'(i8,$)') (snk(i,ib,iparm,islice),i=1,jj) + write (izsc,'(a1,$)') (" ",i=22+8*jj+1,79) + write (izsc,'("&")') + if (nR(ib,iparm).gt.7) then + do ii=8,nR(ib,iparm),9 + jj = min0(nR(ib,iparm),ii+8) + write (izsc,'(i8,$)') (snk(i,ib,iparm,islice),i=ii,jj) + write (izsc,'(a1,$') (" ",i=(jj-ii+1)*8+1,79) + write (izsc,'("&")') + enddo + endif + write (izsc,'("FI=",$)') + jj=min0(nR(ib,iparm),7) + write (izsc,'(f10.5,$)') (fi(i,ib,iparm),i=1,jj) + write (izsc,'(a1,$)') (" ",i=3+10*jj+1,79) + write (izsc,'("&")') + if (nR(ib,iparm).gt.7) then + do ii=8,nR(ib,iparm),9 + jj = min0(nR(ib,iparm),ii+8) + write (izsc,'(f10.5,$)') (fi(i,ib,iparm),i=ii,jj) + if (jj.eq.nR(ib,iparm)) then + write (izsc,*) + else + write (izsc,'(a1,$)') (" ",i=10*(jj-ii+1)+1,79) + write (izsc,'(t80,"&")') + endif + enddo + endif + do i=1,nR(ib,iparm) + write (izsc,'("KH=",$)') + write (izsc,'(f7.2,$)') (Kh(j,i,ib,iparm),j=1,nQ) + write (izsc,'(" Q0=",$)') + write (izsc,'(f7.5,$)') (q0(j,i,ib,iparm),j=1,nQ) + write (izsc,*) + enddo + enddo + enddo + close(izsc) +#endif +#ifdef MPI + endif +#endif + + return + + end diff --git a/source/wham/src-NEWSC-NEWCORR/wham_multparm.F b/source/wham/src-NEWSC-NEWCORR/wham_multparm.F new file mode 100644 index 0000000..003b6b4 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/wham_multparm.F @@ -0,0 +1,277 @@ + program WHAM_multparm +c Creation/update of the database of conformations + implicit none +#ifndef ISNAN + external proc_proc +#endif +#ifdef WINPGI +cMS$ATTRIBUTES C :: proc_proc +#endif + include "DIMENSIONS" + include "DIMENSIONS.ZSCOPT" + include "DIMENSIONS.FREE" +#ifdef MPI + include "mpif.h" + integer IERROR,ERRCODE + include "COMMON.MPI" +#endif + include "COMMON.IOUNITS" + include "COMMON.FREE" + include "COMMON.CONTROL" + include "COMMON.ALLPARM" + include "COMMON.PROT" + double precision rr,x(max_paropt) + integer idumm + integer i,ipar,islice +#ifdef MPI + call MPI_Init( IERROR ) + call MPI_Comm_rank( MPI_COMM_WORLD, me, IERROR ) + call MPI_Comm_size( MPI_COMM_WORLD, nprocs, IERROR ) + Master = 0 + if (ierror.gt.0) then + write(iout,*) "SEVERE ERROR - Can't initialize MPI." + call mpi_finalize(ierror) + stop + endif + if (nprocs.gt.MaxProcs+1) then + write (2,*) "Error - too many processors", + & nprocs,MaxProcs+1 + write (2,*) "Increase MaxProcs and recompile" + call MPI_Finalize(IERROR) + stop + endif +#endif +c NaNQ initialization +#ifndef ISNAN + i=-1 + rr=dacos(100.0d0) +#ifdef WINPGI + idumm=proc_proc(rr,i) +#else + call proc_proc(rr,i) +#endif +#endif + call initialize + call openunits + call cinfo + call read_general_data(*10) + call flush(iout) + call molread(*10) + call flush(iout) +#ifdef MPI + write (iout,*) "Calling proc_groups" + call proc_groups + write (iout,*) "proc_groups exited" + call flush(iout) +#endif +#ifdef SCALREP + write (iout,*) "1,4 SCSC repulsive interactions sacled down by 10" +#endif + do ipar=1,nParmSet + write (iout,*) "Calling parmread",ipar + call parmread(ipar,*10) + if (.not.separate_parset) then + call store_parm(ipar) + write (iout,*) "Finished storing parameters",ipar + else if (ipar.eq.myparm) then + call store_parm(1) + write (iout,*) "Finished storing parameters",ipar + endif + call flush(iout) + enddo + call read_efree(*10) + write (iout,*) "Finished READ_EFREE" + call flush(iout) + call read_protein_data(*10) + write (iout,*) "Finished READ_PROTEIN_DATA" + call flush(iout) + if (indpdb.gt.0) then + call promienie + call read_compar + call read_ref_structure(*10) + call proc_cont + call fragment_list + endif + write (iout,*) "Begin read_database" + call flush(iout) + call read_database(*10) + write (iout,*) "Finished read_database" + call flush(iout) + if (separate_parset) nparmset=1 + do islice=1,nslice + if (ntot(islice).gt.0) then +#ifdef MPI + call work_partition(islice,.true.) + write (iout,*) "work_partition OK" + call flush(iout) +#endif + call enecalc(islice,*10) + write (iout,*) "enecalc OK" + call flush(iout) + write (iout,*) "Calling WHAM_calc" + call flush(iout) + call WHAM_CALC(islice,*10) + write (iout,*) "wham_calc OK" + call flush(iout) + call write_dbase(islice,*10) + write (iout,*) "write_dbase OK" + call flush(iout) + if (ensembles.gt.0) then + call make_ensembles(islice,*10) + write (iout,*) "make_ensembles OK" + call flush(iout) + endif + endif + enddo +#ifdef MPI + call MPI_Finalize( IERROR ) +#endif + stop + 10 write (iout,*) "Error termination of the program" + call MPI_Finalize( IERROR ) + stop + end +c------------------------------------------------------------------------------ +#ifdef MPI + subroutine proc_groups +C Split the processors into the Master and Workers group, if needed. + implicit none + include "DIMENSIONS" + include "DIMENSIONS.ZSCOPT" + include "DIMENSIONS.FREE" + include "mpif.h" + include "COMMON.IOUNITS" + include "COMMON.MPI" + include "COMMON.FREE" + integer n,chunk,i,j,ii,remainder + integer kolor,key,ierror,errcode + logical lprint + lprint=.true. +C +C Split the communicator if independent runs for different parameter +C sets will be performed. +C + if (nparmset.eq.1 .or. .not.separate_parset) then + WHAM_COMM = MPI_COMM_WORLD + else if (separate_parset) then + if (nprocs.lt.nparmset) then + write (iout,*) + & "*** Cannot split parameter sets for fewer processors than sets", + & nprocs,nparmset + call MPI_Finalize(ierror) + stop + endif + write (iout,*) "nparmset",nparmset + nprocs = nprocs/nparmset + kolor = me/nprocs + key = mod(me,nprocs) + write (iout,*) "My old rank",me," kolor",kolor," key",key + call MPI_Comm_split(MPI_COMM_WORLD,kolor,key,WHAM_COMM,ierror) + call MPI_Comm_size(WHAM_COMM,nprocs,ierror) + call MPI_Comm_rank(WHAM_COMM,me,ierror) + write (iout,*) "My new rank",me," comm size",nprocs + write (iout,*) "MPI_COMM_WORLD",MPI_COMM_WORLD, + & " WHAM_COMM",WHAM_COMM + myparm=kolor+1 + write (iout,*) "My parameter set is",myparm + call flush(iout) + else + myparm=nparmset + endif + Me1 = Me + Nprocs1 = Nprocs + return + end +c------------------------------------------------------------------------------ + subroutine work_partition(islice,lprint) +c Split the conformations between processors + implicit none + include "DIMENSIONS" + include "DIMENSIONS.ZSCOPT" + include "DIMENSIONS.FREE" + include "mpif.h" + include "COMMON.IOUNITS" + include "COMMON.MPI" + include "COMMON.PROT" + integer islice + integer n,chunk,i,j,ii,remainder + integer kolor,key,ierror,errcode + logical lprint +C +C Divide conformations between processors; the first and +C the last conformation to handle by ith processor is stored in +C indstart(i) and indend(i), respectively. +C +C First try to assign equal number of conformations to each processor. +C + n=ntot(islice) + write (iout,*) "n=",n + indstart(0)=1 + chunk = N/nprocs1 + scount(0) = chunk +c print *,"i",0," indstart",indstart(0)," scount", +c & scount(0) + do i=1,nprocs1-1 + indstart(i)=chunk+indstart(i-1) + scount(i)=scount(i-1) +c print *,"i",i," indstart",indstart(i)," scount", +c & scount(i) + enddo +C +C Determine how many conformations remained yet unassigned. +C + remainder=N-(indstart(nprocs1-1) + & +scount(nprocs1-1)-1) +c print *,"remainder",remainder +C +C Assign the remainder conformations to consecutive processors, starting +C from the lowest rank; this continues until the list is exhausted. +C + if (remainder .gt. 0) then + do i=1,remainder + scount(i-1) = scount(i-1) + 1 + indstart(i) = indstart(i) + i + enddo + do i=remainder+1,nprocs1-1 + indstart(i) = indstart(i) + remainder + enddo + endif + + indstart(nprocs1)=N+1 + scount(nprocs1)=0 + + do i=0,NProcs1 + indend(i)=indstart(i)+scount(i)-1 + idispl(i)=indstart(i)-1 + enddo + + N=0 + do i=0,Nprocs1-1 + N=N+indend(i)-indstart(i)+1 + enddo + +c print *,"N",n," NTOT",ntot(islice) + if (N.ne.ntot(islice)) then + write (iout,*) "!!! Checksum error on processor",me, + & " slice",islice + call flush(iout) + call MPI_Abort( MPI_COMM_WORLD, Ierror, Errcode ) + endif + + if (lprint) then + write (iout,*) "Partition of work between processors" + do i=0,nprocs1-1 + write (iout,'(a,i5,a,i7,a,i7,a,i7)') + & "Processor",i," indstart",indstart(i), + & " indend",indend(i)," count",scount(i) + enddo + endif + return + end +#endif +#ifdef AIX + subroutine flush(iu) + call flush_(iu) + return + end +#endif diff --git a/source/wham/src-NEWSC-NEWCORR/xdrf/Makefile b/source/wham/src-NEWSC-NEWCORR/xdrf/Makefile new file mode 100644 index 0000000..f03276e --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/xdrf/Makefile @@ -0,0 +1,27 @@ +# This make file is part of the xdrf package. +# +# (C) 1995 Frans van Hoesel, hoesel@chem.rug.nl +# +# 2006 modified by Cezary Czaplewski + +# Set C compiler and flags for ARCH +CC = cc +CFLAGS = -O + +M4 = m4 +M4FILE = underscore.m4 + +libxdrf.a: libxdrf.o ftocstr.o + ar cr libxdrf.a $? + +clean: + rm -f libxdrf.o ftocstr.o libxdrf.a + +ftocstr.o: ftocstr.c + $(CC) $(CFLAGS) -c ftocstr.c + +libxdrf.o: libxdrf.m4 $(M4FILE) + $(M4) $(M4FILE) libxdrf.m4 > libxdrf.c + $(CC) $(CFLAGS) -c libxdrf.c + rm -f libxdrf.c + diff --git a/source/wham/src-NEWSC-NEWCORR/xdrf/ftocstr.c b/source/wham/src-NEWSC-NEWCORR/xdrf/ftocstr.c new file mode 100644 index 0000000..ed2113f --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/xdrf/ftocstr.c @@ -0,0 +1,35 @@ + + +int ftocstr(ds, dl, ss, sl) + char *ds, *ss; /* dst, src ptrs */ + int dl; /* dst max len */ + int sl; /* src len */ +{ + char *p; + + for (p = ss + sl; --p >= ss && *p == ' '; ) ; + sl = p - ss + 1; + dl--; + ds[0] = 0; + if (sl > dl) + return 1; + while (sl--) + (*ds++ = *ss++); + *ds = '\0'; + return 0; +} + + +int ctofstr(ds, dl, ss) + char *ds; /* dest space */ + int dl; /* max dest length */ + char *ss; /* src string (0-term) */ +{ + while (dl && *ss) { + *ds++ = *ss++; + dl--; + } + while (dl--) + *ds++ = ' '; + return 0; +} diff --git a/source/wham/src-NEWSC-NEWCORR/xdrf/libxdrf.m4 b/source/wham/src-NEWSC-NEWCORR/xdrf/libxdrf.m4 new file mode 100644 index 0000000..aecb5b5 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/xdrf/libxdrf.m4 @@ -0,0 +1,1233 @@ +/*____________________________________________________________________________ + | + | libxdrf - portable fortran interface to xdr. some xdr routines + | are C routines for compressed coordinates + | + | version 1.1 + | + | This collection of routines is intended to write and read + | data in a portable way to a file, so data written on one type + | of machine can be read back on a different type. + | + | all fortran routines use an integer 'xdrid', which is an id to the + | current xdr file, and is set by xdrfopen. + | most routines have in integer 'ret' which is the return value. + | The value of 'ret' is zero on failure, and most of the time one + | on succes. + | + | There are three routines useful for C users: + | xdropen(), xdrclose(), xdr3dfcoord(). + | The first two replace xdrstdio_create and xdr_destroy, and *must* be + | used when you plan to use xdr3dfcoord(). (they are also a bit + | easier to interface). For writing data other than compressed coordinates + | you should use the standard C xdr routines (see xdr man page) + | + | xdrfopen(xdrid, filename, mode, ret) + | character *(*) filename + | character *(*) mode + | + | this will open the file with the given filename (string) + | and the given mode, it returns an id in xdrid, which is + | to be used in all other calls to xdrf routines. + | mode is 'w' to create, or update an file, for all other + | values of mode the file is opened for reading + | + | you need to call xdrfclose to flush the output and close + | the file. + | Note that you should not use xdrstdio_create, which comes with the + | standard xdr library + | + | xdrfclose(xdrid, ret) + | flush the data to the file, and closes the file; + | You should not use xdr_destroy (which comes standard with + | the xdr libraries. + | + | xdrfbool(xdrid, bp, ret) + | integer pb + | + | This filter produces values of either 1 or 0 + | + | xdrfchar(xdrid, cp, ret) + | character cp + | + | filter that translate between characters and their xdr representation + | Note that the characters in not compressed and occupies 4 bytes. + | + | xdrfdouble(xdrid, dp, ret) + | double dp + | + | read/write a double. + | + | xdrffloat(xdrid, fp, ret) + | float fp + | + | read/write a float. + | + | xdrfint(xdrid, ip, ret) + | integer ip + | + | read/write integer. + | + | xdrflong(xdrid, lp, ret) + | integer lp + | + | this routine has a possible portablility problem due to 64 bits longs. + | + | xdrfshort(xdrid, sp, ret) + | integer *2 sp + | + | xdrfstring(xdrid, sp, maxsize, ret) + | character *(*) + | integer maxsize + | + | read/write a string, with maximum length given by maxsize + | + | xdrfwrapstring(xdris, sp, ret) + | character *(*) + | + | read/write a string (it is the same as xdrfstring accept that it finds + | the stringlength itself. + | + | xdrfvector(xdrid, cp, size, xdrfproc, ret) + | character *(*) + | integer size + | external xdrfproc + | + | read/write an array pointed to by cp, with number of elements + | defined by 'size'. the routine 'xdrfproc' is the name + | of one of the above routines to read/write data (like xdrfdouble) + | In contrast with the c-version you don't need to specify the + | byte size of an element. + | xdrfstring is not allowed here (it is in the c version) + | + | xdrf3dfcoord(xdrid, fp, size, precision, ret) + | real (*) fp + | real precision + | integer size + | + | this is *NOT* a standard xdr routine. I named it this way, because + | it invites people to use the other xdr routines. + | It is introduced to store specifically 3d coordinates of molecules + | (as found in molecular dynamics) and it writes it in a compressed way. + | It starts by multiplying all numbers by precision and + | rounding the result to integer. effectively converting + | all floating point numbers to fixed point. + | it uses an algorithm for compression that is optimized for + | molecular data, but could be used for other 3d coordinates + | as well. There is subtantial overhead involved, so call this + | routine only if you have a large number of coordinates to read/write + | + | ________________________________________________________________________ + | + | Below are the routines to be used by C programmers. Use the 'normal' + | xdr routines to write integers, floats, etc (see man xdr) + | + | int xdropen(XDR *xdrs, const char *filename, const char *type) + | This will open the file with the given filename and the + | given mode. You should pass it an allocated XDR struct + | in xdrs, to be used in all other calls to xdr routines. + | Mode is 'w' to create, or update an file, and for all + | other values of mode the file is opened for reading. + | You need to call xdrclose to flush the output and close + | the file. + | + | Note that you should not use xdrstdio_create, which + | comes with the standard xdr library. + | + | int xdrclose(XDR *xdrs) + | Flush the data to the file, and close the file; + | You should not use xdr_destroy (which comes standard + | with the xdr libraries). + | + | int xdr3dfcoord(XDR *xdrs, float *fp, int *size, float *precision) + | This is \fInot\fR a standard xdr routine. I named it this + | way, because it invites people to use the other xdr + | routines. + | + | (c) 1995 Frans van Hoesel, hoesel@chem.rug.nl +*/ + + +#include +#include +#include +#include +#include +#include +#include +#include "xdrf.h" + +int ftocstr(char *, int, char *, int); +int ctofstr(char *, int, char *); + +#define MAXID 20 +static FILE *xdrfiles[MAXID]; +static XDR *xdridptr[MAXID]; +static char xdrmodes[MAXID]; +static unsigned int cnt; + +typedef void (* FUNCTION(xdrfproc)) (int *, void *, int *); + +void +FUNCTION(xdrfbool) ARGS(`xdrid, pb, ret') +int *xdrid, *ret; +int *pb; +{ + *ret = xdr_bool(xdridptr[*xdrid], (bool_t *) pb); + cnt += sizeof(int); +} + +void +FUNCTION(xdrfchar) ARGS(`xdrid, cp, ret') +int *xdrid, *ret; +char *cp; +{ + *ret = xdr_char(xdridptr[*xdrid], cp); + cnt += sizeof(char); +} + +void +FUNCTION(xdrfdouble) ARGS(`xdrid, dp, ret') +int *xdrid, *ret; +double *dp; +{ + *ret = xdr_double(xdridptr[*xdrid], dp); + cnt += sizeof(double); +} + +void +FUNCTION(xdrffloat) ARGS(`xdrid, fp, ret') +int *xdrid, *ret; +float *fp; +{ + *ret = xdr_float(xdridptr[*xdrid], fp); + cnt += sizeof(float); +} + +void +FUNCTION(xdrfint) ARGS(`xdrid, ip, ret') +int *xdrid, *ret; +int *ip; +{ + *ret = xdr_int(xdridptr[*xdrid], ip); + cnt += sizeof(int); +} + +void +FUNCTION(xdrflong) ARGS(`xdrid, lp, ret') +int *xdrid, *ret; +long *lp; +{ + *ret = xdr_long(xdridptr[*xdrid], lp); + cnt += sizeof(long); +} + +void +FUNCTION(xdrfshort) ARGS(`xdrid, sp, ret') +int *xdrid, *ret; +short *sp; +{ + *ret = xdr_short(xdridptr[*xdrid], sp); + cnt += sizeof(sp); +} + +void +FUNCTION(xdrfuchar) ARGS(`xdrid, ucp, ret') +int *xdrid, *ret; +char *ucp; +{ + *ret = xdr_u_char(xdridptr[*xdrid], ucp); + cnt += sizeof(char); +} + +void +FUNCTION(xdrfulong) ARGS(`xdrid, ulp, ret') +int *xdrid, *ret; +unsigned long *ulp; +{ + *ret = xdr_u_long(xdridptr[*xdrid], ulp); + cnt += sizeof(unsigned long); +} + +void +FUNCTION(xdrfushort) ARGS(`xdrid, usp, ret') +int *xdrid, *ret; +unsigned short *usp; +{ + *ret = xdr_u_short(xdridptr[*xdrid], usp); + cnt += sizeof(unsigned short); +} + +void +FUNCTION(xdrf3dfcoord) ARGS(`xdrid, fp, size, precision, ret') +int *xdrid, *ret; +float *fp; +int *size; +float *precision; +{ + *ret = xdr3dfcoord(xdridptr[*xdrid], fp, size, precision); +} + +void +FUNCTION(xdrfstring) ARGS(`xdrid, STRING_ARG(sp), maxsize, ret') +int *xdrid, *ret; +STRING_ARG_DECL(sp); +int *maxsize; +{ + char *tsp; + + tsp = (char*) malloc(((STRING_LEN(sp)) + 1) * sizeof(char)); + if (tsp == NULL) { + *ret = -1; + return; + } + if (ftocstr(tsp, *maxsize+1, STRING_PTR(sp), STRING_LEN(sp))) { + *ret = -1; + free(tsp); + return; + } + *ret = xdr_string(xdridptr[*xdrid], (char **) &tsp, (u_int) *maxsize); + ctofstr( STRING_PTR(sp), STRING_LEN(sp), tsp); + cnt += *maxsize; + free(tsp); +} + +void +FUNCTION(xdrfwrapstring) ARGS(`xdrid, STRING_ARG(sp), ret') +int *xdrid, *ret; +STRING_ARG_DECL(sp); +{ + char *tsp; + int maxsize; + maxsize = (STRING_LEN(sp)) + 1; + tsp = (char*) malloc(maxsize * sizeof(char)); + if (tsp == NULL) { + *ret = -1; + return; + } + if (ftocstr(tsp, maxsize, STRING_PTR(sp), STRING_LEN(sp))) { + *ret = -1; + free(tsp); + return; + } + *ret = xdr_string(xdridptr[*xdrid], (char **) &tsp, (u_int)maxsize); + ctofstr( STRING_PTR(sp), STRING_LEN(sp), tsp); + cnt += maxsize; + free(tsp); +} + +void +FUNCTION(xdrfopaque) ARGS(`xdrid, cp, ccnt, ret') +int *xdrid, *ret; +caddr_t *cp; +int *ccnt; +{ + *ret = xdr_opaque(xdridptr[*xdrid], (caddr_t)*cp, (u_int)*ccnt); + cnt += *ccnt; +} + +void +FUNCTION(xdrfsetpos) ARGS(`xdrid, pos, ret') +int *xdrid, *ret; +int *pos; +{ + *ret = xdr_setpos(xdridptr[*xdrid], (u_int) *pos); +} + +void +FUNCTION(xdrf) ARGS(`xdrid, pos') +int *xdrid, *pos; +{ + *pos = xdr_getpos(xdridptr[*xdrid]); +} + +void +FUNCTION(xdrfvector) ARGS(`xdrid, cp, size, elproc, ret') +int *xdrid, *ret; +char *cp; +int *size; +FUNCTION(xdrfproc) elproc; +{ + int lcnt; + cnt = 0; + for (lcnt = 0; lcnt < *size; lcnt++) { + elproc(xdrid, (cp+cnt) , ret); + } +} + + +void +FUNCTION(xdrfclose) ARGS(`xdrid, ret') +int *xdrid; +int *ret; +{ + *ret = xdrclose(xdridptr[*xdrid]); + cnt = 0; +} + +void +FUNCTION(xdrfopen) ARGS(`xdrid, STRING_ARG(fp), STRING_ARG(mode), ret') +int *xdrid; +STRING_ARG_DECL(fp); +STRING_ARG_DECL(mode); +int *ret; +{ + char fname[512]; + char fmode[3]; + + if (ftocstr(fname, sizeof(fname), STRING_PTR(fp), STRING_LEN(fp))) { + *ret = 0; + } + if (ftocstr(fmode, sizeof(fmode), STRING_PTR(mode), + STRING_LEN(mode))) { + *ret = 0; + } + + *xdrid = xdropen(NULL, fname, fmode); + if (*xdrid == 0) + *ret = 0; + else + *ret = 1; +} + +/*___________________________________________________________________________ + | + | what follows are the C routines for opening, closing xdr streams + | and the routine to read/write compressed coordinates together + | with some routines to assist in this task (those are marked + | static and cannot be called from user programs) +*/ +#define MAXABS INT_MAX-2 + +#ifndef MIN +#define MIN(x,y) ((x) < (y) ? (x):(y)) +#endif +#ifndef MAX +#define MAX(x,y) ((x) > (y) ? (x):(y)) +#endif +#ifndef SQR +#define SQR(x) ((x)*(x)) +#endif +static int magicints[] = { + 0, 0, 0, 0, 0, 0, 0, 0, 0, + 8, 10, 12, 16, 20, 25, 32, 40, 50, 64, + 80, 101, 128, 161, 203, 256, 322, 406, 512, 645, + 812, 1024, 1290, 1625, 2048, 2580, 3250, 4096, 5060, 6501, + 8192, 10321, 13003, 16384, 20642, 26007, 32768, 41285, 52015, 65536, + 82570, 104031, 131072, 165140, 208063, 262144, 330280, 416127, 524287, 660561, + 832255, 1048576, 1321122, 1664510, 2097152, 2642245, 3329021, 4194304, 5284491, 6658042, + 8388607, 10568983, 13316085, 16777216 }; + +#define FIRSTIDX 9 +/* note that magicints[FIRSTIDX-1] == 0 */ +#define LASTIDX (sizeof(magicints) / sizeof(*magicints)) + + +/*__________________________________________________________________________ + | + | xdropen - open xdr file + | + | This versions differs from xdrstdio_create, because I need to know + | the state of the file (read or write) so I can use xdr3dfcoord + | in eigther read or write mode, and the file descriptor + | so I can close the file (something xdr_destroy doesn't do). + | +*/ + +int xdropen(XDR *xdrs, const char *filename, const char *type) { + static int init_done = 0; + enum xdr_op lmode; + const char *type1; + int xdrid; + + if (init_done == 0) { + for (xdrid = 1; xdrid < MAXID; xdrid++) { + xdridptr[xdrid] = NULL; + } + init_done = 1; + } + xdrid = 1; + while (xdrid < MAXID && xdridptr[xdrid] != NULL) { + xdrid++; + } + if (xdrid == MAXID) { + return 0; + } + if (*type == 'w' || *type == 'W') { + type = "w+"; + type1 = "a+"; + lmode = XDR_ENCODE; + } else { + type = "r"; + type1 = "r"; + lmode = XDR_DECODE; + } + xdrfiles[xdrid] = fopen(filename, type1); + if (xdrfiles[xdrid] == NULL) { + xdrs = NULL; + return 0; + } + xdrmodes[xdrid] = *type; + /* next test isn't usefull in the case of C language + * but is used for the Fortran interface + * (C users are expected to pass the address of an already allocated + * XDR staructure) + */ + if (xdrs == NULL) { + xdridptr[xdrid] = (XDR *) malloc(sizeof(XDR)); + xdrstdio_create(xdridptr[xdrid], xdrfiles[xdrid], lmode); + } else { + xdridptr[xdrid] = xdrs; + xdrstdio_create(xdrs, xdrfiles[xdrid], lmode); + } + return xdrid; +} + +/*_________________________________________________________________________ + | + | xdrclose - close a xdr file + | + | This will flush the xdr buffers, and destroy the xdr stream. + | It also closes the associated file descriptor (this is *not* + | done by xdr_destroy). + | +*/ + +int xdrclose(XDR *xdrs) { + int xdrid; + + if (xdrs == NULL) { + fprintf(stderr, "xdrclose: passed a NULL pointer\n"); + exit(1); + } + for (xdrid = 1; xdrid < MAXID; xdrid++) { + if (xdridptr[xdrid] == xdrs) { + + xdr_destroy(xdrs); + fclose(xdrfiles[xdrid]); + xdridptr[xdrid] = NULL; + return 1; + } + } + fprintf(stderr, "xdrclose: no such open xdr file\n"); + exit(1); + +} + +/*____________________________________________________________________________ + | + | sendbits - encode num into buf using the specified number of bits + | + | This routines appends the value of num to the bits already present in + | the array buf. You need to give it the number of bits to use and you + | better make sure that this number of bits is enough to hold the value + | Also num must be positive. + | +*/ + +static void sendbits(int buf[], int num_of_bits, int num) { + + unsigned int cnt, lastbyte; + int lastbits; + unsigned char * cbuf; + + cbuf = ((unsigned char *)buf) + 3 * sizeof(*buf); + cnt = (unsigned int) buf[0]; + lastbits = buf[1]; + lastbyte =(unsigned int) buf[2]; + while (num_of_bits >= 8) { + lastbyte = (lastbyte << 8) | ((num >> (num_of_bits -8)) /* & 0xff*/); + cbuf[cnt++] = lastbyte >> lastbits; + num_of_bits -= 8; + } + if (num_of_bits > 0) { + lastbyte = (lastbyte << num_of_bits) | num; + lastbits += num_of_bits; + if (lastbits >= 8) { + lastbits -= 8; + cbuf[cnt++] = lastbyte >> lastbits; + } + } + buf[0] = cnt; + buf[1] = lastbits; + buf[2] = lastbyte; + if (lastbits>0) { + cbuf[cnt] = lastbyte << (8 - lastbits); + } +} + +/*_________________________________________________________________________ + | + | sizeofint - calculate bitsize of an integer + | + | return the number of bits needed to store an integer with given max size + | +*/ + +static int sizeofint(const int size) { + unsigned int num = 1; + int num_of_bits = 0; + + while (size >= num && num_of_bits < 32) { + num_of_bits++; + num <<= 1; + } + return num_of_bits; +} + +/*___________________________________________________________________________ + | + | sizeofints - calculate 'bitsize' of compressed ints + | + | given the number of small unsigned integers and the maximum value + | return the number of bits needed to read or write them with the + | routines receiveints and sendints. You need this parameter when + | calling these routines. Note that for many calls I can use + | the variable 'smallidx' which is exactly the number of bits, and + | So I don't need to call 'sizeofints for those calls. +*/ + +static int sizeofints( const int num_of_ints, unsigned int sizes[]) { + int i, num; + unsigned int num_of_bytes, num_of_bits, bytes[32], bytecnt, tmp; + num_of_bytes = 1; + bytes[0] = 1; + num_of_bits = 0; + for (i=0; i < num_of_ints; i++) { + tmp = 0; + for (bytecnt = 0; bytecnt < num_of_bytes; bytecnt++) { + tmp = bytes[bytecnt] * sizes[i] + tmp; + bytes[bytecnt] = tmp & 0xff; + tmp >>= 8; + } + while (tmp != 0) { + bytes[bytecnt++] = tmp & 0xff; + tmp >>= 8; + } + num_of_bytes = bytecnt; + } + num = 1; + num_of_bytes--; + while (bytes[num_of_bytes] >= num) { + num_of_bits++; + num *= 2; + } + return num_of_bits + num_of_bytes * 8; + +} + +/*____________________________________________________________________________ + | + | sendints - send a small set of small integers in compressed format + | + | this routine is used internally by xdr3dfcoord, to send a set of + | small integers to the buffer. + | Multiplication with fixed (specified maximum ) sizes is used to get + | to one big, multibyte integer. Allthough the routine could be + | modified to handle sizes bigger than 16777216, or more than just + | a few integers, this is not done, because the gain in compression + | isn't worth the effort. Note that overflowing the multiplication + | or the byte buffer (32 bytes) is unchecked and causes bad results. + | + */ + +static void sendints(int buf[], const int num_of_ints, const int num_of_bits, + unsigned int sizes[], unsigned int nums[]) { + + int i; + unsigned int bytes[32], num_of_bytes, bytecnt, tmp; + + tmp = nums[0]; + num_of_bytes = 0; + do { + bytes[num_of_bytes++] = tmp & 0xff; + tmp >>= 8; + } while (tmp != 0); + + for (i = 1; i < num_of_ints; i++) { + if (nums[i] >= sizes[i]) { + fprintf(stderr,"major breakdown in sendints num %d doesn't " + "match size %d\n", nums[i], sizes[i]); + exit(1); + } + /* use one step multiply */ + tmp = nums[i]; + for (bytecnt = 0; bytecnt < num_of_bytes; bytecnt++) { + tmp = bytes[bytecnt] * sizes[i] + tmp; + bytes[bytecnt] = tmp & 0xff; + tmp >>= 8; + } + while (tmp != 0) { + bytes[bytecnt++] = tmp & 0xff; + tmp >>= 8; + } + num_of_bytes = bytecnt; + } + if (num_of_bits >= num_of_bytes * 8) { + for (i = 0; i < num_of_bytes; i++) { + sendbits(buf, 8, bytes[i]); + } + sendbits(buf, num_of_bits - num_of_bytes * 8, 0); + } else { + for (i = 0; i < num_of_bytes-1; i++) { + sendbits(buf, 8, bytes[i]); + } + sendbits(buf, num_of_bits- (num_of_bytes -1) * 8, bytes[i]); + } +} + + +/*___________________________________________________________________________ + | + | receivebits - decode number from buf using specified number of bits + | + | extract the number of bits from the array buf and construct an integer + | from it. Return that value. + | +*/ + +static int receivebits(int buf[], int num_of_bits) { + + int cnt, num; + unsigned int lastbits, lastbyte; + unsigned char * cbuf; + int mask = (1 << num_of_bits) -1; + + cbuf = ((unsigned char *)buf) + 3 * sizeof(*buf); + cnt = buf[0]; + lastbits = (unsigned int) buf[1]; + lastbyte = (unsigned int) buf[2]; + + num = 0; + while (num_of_bits >= 8) { + lastbyte = ( lastbyte << 8 ) | cbuf[cnt++]; + num |= (lastbyte >> lastbits) << (num_of_bits - 8); + num_of_bits -=8; + } + if (num_of_bits > 0) { + if (lastbits < num_of_bits) { + lastbits += 8; + lastbyte = (lastbyte << 8) | cbuf[cnt++]; + } + lastbits -= num_of_bits; + num |= (lastbyte >> lastbits) & ((1 << num_of_bits) -1); + } + num &= mask; + buf[0] = cnt; + buf[1] = lastbits; + buf[2] = lastbyte; + return num; +} + +/*____________________________________________________________________________ + | + | receiveints - decode 'small' integers from the buf array + | + | this routine is the inverse from sendints() and decodes the small integers + | written to buf by calculating the remainder and doing divisions with + | the given sizes[]. You need to specify the total number of bits to be + | used from buf in num_of_bits. + | +*/ + +static void receiveints(int buf[], const int num_of_ints, int num_of_bits, + unsigned int sizes[], int nums[]) { + int bytes[32]; + int i, j, num_of_bytes, p, num; + + bytes[1] = bytes[2] = bytes[3] = 0; + num_of_bytes = 0; + while (num_of_bits > 8) { + bytes[num_of_bytes++] = receivebits(buf, 8); + num_of_bits -= 8; + } + if (num_of_bits > 0) { + bytes[num_of_bytes++] = receivebits(buf, num_of_bits); + } + for (i = num_of_ints-1; i > 0; i--) { + num = 0; + for (j = num_of_bytes-1; j >=0; j--) { + num = (num << 8) | bytes[j]; + p = num / sizes[i]; + bytes[j] = p; + num = num - p * sizes[i]; + } + nums[i] = num; + } + nums[0] = bytes[0] | (bytes[1] << 8) | (bytes[2] << 16) | (bytes[3] << 24); +} + +/*____________________________________________________________________________ + | + | xdr3dfcoord - read or write compressed 3d coordinates to xdr file. + | + | this routine reads or writes (depending on how you opened the file with + | xdropen() ) a large number of 3d coordinates (stored in *fp). + | The number of coordinates triplets to write is given by *size. On + | read this number may be zero, in which case it reads as many as were written + | or it may specify the number if triplets to read (which should match the + | number written). + | Compression is achieved by first converting all floating numbers to integer + | using multiplication by *precision and rounding to the nearest integer. + | Then the minimum and maximum value are calculated to determine the range. + | The limited range of integers so found, is used to compress the coordinates. + | In addition the differences between succesive coordinates is calculated. + | If the difference happens to be 'small' then only the difference is saved, + | compressing the data even more. The notion of 'small' is changed dynamically + | and is enlarged or reduced whenever needed or possible. + | Extra compression is achieved in the case of GROMOS and coordinates of + | water molecules. GROMOS first writes out the Oxygen position, followed by + | the two hydrogens. In order to make the differences smaller (and thereby + | compression the data better) the order is changed into first one hydrogen + | then the oxygen, followed by the other hydrogen. This is rather special, but + | it shouldn't harm in the general case. + | + */ + +int xdr3dfcoord(XDR *xdrs, float *fp, int *size, float *precision) { + + + static int *ip = NULL; + static int oldsize; + static int *buf; + + int minint[3], maxint[3], mindiff, *lip, diff; + int lint1, lint2, lint3, oldlint1, oldlint2, oldlint3, smallidx; + int minidx, maxidx; + unsigned sizeint[3], sizesmall[3], bitsizeint[3], size3, *luip; + int flag, k; + int small, smaller, larger, i, is_small, is_smaller, run, prevrun; + float *lfp, lf; + int tmp, *thiscoord, prevcoord[3]; + unsigned int tmpcoord[30]; + + int bufsize, xdrid, lsize; + unsigned int bitsize; + float inv_precision; + int errval = 1; + + /* find out if xdrs is opened for reading or for writing */ + xdrid = 0; + while (xdridptr[xdrid] != xdrs) { + xdrid++; + if (xdrid >= MAXID) { + fprintf(stderr, "xdr error. no open xdr stream\n"); + exit (1); + } + } + if (xdrmodes[xdrid] == 'w') { + + /* xdrs is open for writing */ + + if (xdr_int(xdrs, size) == 0) + return 0; + size3 = *size * 3; + /* when the number of coordinates is small, don't try to compress; just + * write them as floats using xdr_vector + */ + if (*size <= 9 ) { + return (xdr_vector(xdrs, (char *) fp, size3, sizeof(*fp), + (xdrproc_t)xdr_float)); + } + + xdr_float(xdrs, precision); + if (ip == NULL) { + ip = (int *)malloc(size3 * sizeof(*ip)); + if (ip == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + bufsize = size3 * 1.2; + buf = (int *)malloc(bufsize * sizeof(*buf)); + if (buf == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + oldsize = *size; + } else if (*size > oldsize) { + ip = (int *)realloc(ip, size3 * sizeof(*ip)); + if (ip == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + bufsize = size3 * 1.2; + buf = (int *)realloc(buf, bufsize * sizeof(*buf)); + if (buf == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + oldsize = *size; + } + /* buf[0-2] are special and do not contain actual data */ + buf[0] = buf[1] = buf[2] = 0; + minint[0] = minint[1] = minint[2] = INT_MAX; + maxint[0] = maxint[1] = maxint[2] = INT_MIN; + prevrun = -1; + lfp = fp; + lip = ip; + mindiff = INT_MAX; + oldlint1 = oldlint2 = oldlint3 = 0; + while(lfp < fp + size3 ) { + /* find nearest integer */ + if (*lfp >= 0.0) + lf = *lfp * *precision + 0.5; + else + lf = *lfp * *precision - 0.5; + if (fabs(lf) > MAXABS) { + /* scaling would cause overflow */ + errval = 0; + } + lint1 = lf; + if (lint1 < minint[0]) minint[0] = lint1; + if (lint1 > maxint[0]) maxint[0] = lint1; + *lip++ = lint1; + lfp++; + if (*lfp >= 0.0) + lf = *lfp * *precision + 0.5; + else + lf = *lfp * *precision - 0.5; + if (fabs(lf) > MAXABS) { + /* scaling would cause overflow */ + errval = 0; + } + lint2 = lf; + if (lint2 < minint[1]) minint[1] = lint2; + if (lint2 > maxint[1]) maxint[1] = lint2; + *lip++ = lint2; + lfp++; + if (*lfp >= 0.0) + lf = *lfp * *precision + 0.5; + else + lf = *lfp * *precision - 0.5; + if (fabs(lf) > MAXABS) { + /* scaling would cause overflow */ + errval = 0; + } + lint3 = lf; + if (lint3 < minint[2]) minint[2] = lint3; + if (lint3 > maxint[2]) maxint[2] = lint3; + *lip++ = lint3; + lfp++; + diff = abs(oldlint1-lint1)+abs(oldlint2-lint2)+abs(oldlint3-lint3); + if (diff < mindiff && lfp > fp + 3) + mindiff = diff; + oldlint1 = lint1; + oldlint2 = lint2; + oldlint3 = lint3; + } + xdr_int(xdrs, &(minint[0])); + xdr_int(xdrs, &(minint[1])); + xdr_int(xdrs, &(minint[2])); + + xdr_int(xdrs, &(maxint[0])); + xdr_int(xdrs, &(maxint[1])); + xdr_int(xdrs, &(maxint[2])); + + if ((float)maxint[0] - (float)minint[0] >= MAXABS || + (float)maxint[1] - (float)minint[1] >= MAXABS || + (float)maxint[2] - (float)minint[2] >= MAXABS) { + /* turning value in unsigned by subtracting minint + * would cause overflow + */ + errval = 0; + } + sizeint[0] = maxint[0] - minint[0]+1; + sizeint[1] = maxint[1] - minint[1]+1; + sizeint[2] = maxint[2] - minint[2]+1; + + /* check if one of the sizes is to big to be multiplied */ + if ((sizeint[0] | sizeint[1] | sizeint[2] ) > 0xffffff) { + bitsizeint[0] = sizeofint(sizeint[0]); + bitsizeint[1] = sizeofint(sizeint[1]); + bitsizeint[2] = sizeofint(sizeint[2]); + bitsize = 0; /* flag the use of large sizes */ + } else { + bitsize = sizeofints(3, sizeint); + } + lip = ip; + luip = (unsigned int *) ip; + smallidx = FIRSTIDX; + while (smallidx < LASTIDX && magicints[smallidx] < mindiff) { + smallidx++; + } + xdr_int(xdrs, &smallidx); + maxidx = MIN(LASTIDX, smallidx + 8) ; + minidx = maxidx - 8; /* often this equal smallidx */ + smaller = magicints[MAX(FIRSTIDX, smallidx-1)] / 2; + small = magicints[smallidx] / 2; + sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx]; + larger = magicints[maxidx] / 2; + i = 0; + while (i < *size) { + is_small = 0; + thiscoord = (int *)(luip) + i * 3; + if (smallidx < maxidx && i >= 1 && + abs(thiscoord[0] - prevcoord[0]) < larger && + abs(thiscoord[1] - prevcoord[1]) < larger && + abs(thiscoord[2] - prevcoord[2]) < larger) { + is_smaller = 1; + } else if (smallidx > minidx) { + is_smaller = -1; + } else { + is_smaller = 0; + } + if (i + 1 < *size) { + if (abs(thiscoord[0] - thiscoord[3]) < small && + abs(thiscoord[1] - thiscoord[4]) < small && + abs(thiscoord[2] - thiscoord[5]) < small) { + /* interchange first with second atom for better + * compression of water molecules + */ + tmp = thiscoord[0]; thiscoord[0] = thiscoord[3]; + thiscoord[3] = tmp; + tmp = thiscoord[1]; thiscoord[1] = thiscoord[4]; + thiscoord[4] = tmp; + tmp = thiscoord[2]; thiscoord[2] = thiscoord[5]; + thiscoord[5] = tmp; + is_small = 1; + } + + } + tmpcoord[0] = thiscoord[0] - minint[0]; + tmpcoord[1] = thiscoord[1] - minint[1]; + tmpcoord[2] = thiscoord[2] - minint[2]; + if (bitsize == 0) { + sendbits(buf, bitsizeint[0], tmpcoord[0]); + sendbits(buf, bitsizeint[1], tmpcoord[1]); + sendbits(buf, bitsizeint[2], tmpcoord[2]); + } else { + sendints(buf, 3, bitsize, sizeint, tmpcoord); + } + prevcoord[0] = thiscoord[0]; + prevcoord[1] = thiscoord[1]; + prevcoord[2] = thiscoord[2]; + thiscoord = thiscoord + 3; + i++; + + run = 0; + if (is_small == 0 && is_smaller == -1) + is_smaller = 0; + while (is_small && run < 8*3) { + if (is_smaller == -1 && ( + SQR(thiscoord[0] - prevcoord[0]) + + SQR(thiscoord[1] - prevcoord[1]) + + SQR(thiscoord[2] - prevcoord[2]) >= smaller * smaller)) { + is_smaller = 0; + } + + tmpcoord[run++] = thiscoord[0] - prevcoord[0] + small; + tmpcoord[run++] = thiscoord[1] - prevcoord[1] + small; + tmpcoord[run++] = thiscoord[2] - prevcoord[2] + small; + + prevcoord[0] = thiscoord[0]; + prevcoord[1] = thiscoord[1]; + prevcoord[2] = thiscoord[2]; + + i++; + thiscoord = thiscoord + 3; + is_small = 0; + if (i < *size && + abs(thiscoord[0] - prevcoord[0]) < small && + abs(thiscoord[1] - prevcoord[1]) < small && + abs(thiscoord[2] - prevcoord[2]) < small) { + is_small = 1; + } + } + if (run != prevrun || is_smaller != 0) { + prevrun = run; + sendbits(buf, 1, 1); /* flag the change in run-length */ + sendbits(buf, 5, run+is_smaller+1); + } else { + sendbits(buf, 1, 0); /* flag the fact that runlength did not change */ + } + for (k=0; k < run; k+=3) { + sendints(buf, 3, smallidx, sizesmall, &tmpcoord[k]); + } + if (is_smaller != 0) { + smallidx += is_smaller; + if (is_smaller < 0) { + small = smaller; + smaller = magicints[smallidx-1] / 2; + } else { + smaller = small; + small = magicints[smallidx] / 2; + } + sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx]; + } + } + if (buf[1] != 0) buf[0]++;; + xdr_int(xdrs, &(buf[0])); /* buf[0] holds the length in bytes */ + return errval * (xdr_opaque(xdrs, (caddr_t)&(buf[3]), (u_int)buf[0])); + } else { + + /* xdrs is open for reading */ + + if (xdr_int(xdrs, &lsize) == 0) + return 0; + if (*size != 0 && lsize != *size) { + fprintf(stderr, "wrong number of coordinates in xdr3dfcoor; " + "%d arg vs %d in file", *size, lsize); + } + *size = lsize; + size3 = *size * 3; + if (*size <= 9) { + return (xdr_vector(xdrs, (char *) fp, size3, sizeof(*fp), + (xdrproc_t)xdr_float)); + } + xdr_float(xdrs, precision); + if (ip == NULL) { + ip = (int *)malloc(size3 * sizeof(*ip)); + if (ip == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + bufsize = size3 * 1.2; + buf = (int *)malloc(bufsize * sizeof(*buf)); + if (buf == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + oldsize = *size; + } else if (*size > oldsize) { + ip = (int *)realloc(ip, size3 * sizeof(*ip)); + if (ip == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + bufsize = size3 * 1.2; + buf = (int *)realloc(buf, bufsize * sizeof(*buf)); + if (buf == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + oldsize = *size; + } + buf[0] = buf[1] = buf[2] = 0; + + xdr_int(xdrs, &(minint[0])); + xdr_int(xdrs, &(minint[1])); + xdr_int(xdrs, &(minint[2])); + + xdr_int(xdrs, &(maxint[0])); + xdr_int(xdrs, &(maxint[1])); + xdr_int(xdrs, &(maxint[2])); + + sizeint[0] = maxint[0] - minint[0]+1; + sizeint[1] = maxint[1] - minint[1]+1; + sizeint[2] = maxint[2] - minint[2]+1; + + /* check if one of the sizes is to big to be multiplied */ + if ((sizeint[0] | sizeint[1] | sizeint[2] ) > 0xffffff) { + bitsizeint[0] = sizeofint(sizeint[0]); + bitsizeint[1] = sizeofint(sizeint[1]); + bitsizeint[2] = sizeofint(sizeint[2]); + bitsize = 0; /* flag the use of large sizes */ + } else { + bitsize = sizeofints(3, sizeint); + } + + xdr_int(xdrs, &smallidx); + maxidx = MIN(LASTIDX, smallidx + 8) ; + minidx = maxidx - 8; /* often this equal smallidx */ + smaller = magicints[MAX(FIRSTIDX, smallidx-1)] / 2; + small = magicints[smallidx] / 2; + sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx] ; + larger = magicints[maxidx]; + + /* buf[0] holds the length in bytes */ + + if (xdr_int(xdrs, &(buf[0])) == 0) + return 0; + if (xdr_opaque(xdrs, (caddr_t)&(buf[3]), (u_int)buf[0]) == 0) + return 0; + buf[0] = buf[1] = buf[2] = 0; + + lfp = fp; + inv_precision = 1.0 / * precision; + run = 0; + i = 0; + lip = ip; + while ( i < lsize ) { + thiscoord = (int *)(lip) + i * 3; + + if (bitsize == 0) { + thiscoord[0] = receivebits(buf, bitsizeint[0]); + thiscoord[1] = receivebits(buf, bitsizeint[1]); + thiscoord[2] = receivebits(buf, bitsizeint[2]); + } else { + receiveints(buf, 3, bitsize, sizeint, thiscoord); + } + + i++; + thiscoord[0] += minint[0]; + thiscoord[1] += minint[1]; + thiscoord[2] += minint[2]; + + prevcoord[0] = thiscoord[0]; + prevcoord[1] = thiscoord[1]; + prevcoord[2] = thiscoord[2]; + + + flag = receivebits(buf, 1); + is_smaller = 0; + if (flag == 1) { + run = receivebits(buf, 5); + is_smaller = run % 3; + run -= is_smaller; + is_smaller--; + } + if (run > 0) { + thiscoord += 3; + for (k = 0; k < run; k+=3) { + receiveints(buf, 3, smallidx, sizesmall, thiscoord); + i++; + thiscoord[0] += prevcoord[0] - small; + thiscoord[1] += prevcoord[1] - small; + thiscoord[2] += prevcoord[2] - small; + if (k == 0) { + /* interchange first with second atom for better + * compression of water molecules + */ + tmp = thiscoord[0]; thiscoord[0] = prevcoord[0]; + prevcoord[0] = tmp; + tmp = thiscoord[1]; thiscoord[1] = prevcoord[1]; + prevcoord[1] = tmp; + tmp = thiscoord[2]; thiscoord[2] = prevcoord[2]; + prevcoord[2] = tmp; + *lfp++ = prevcoord[0] * inv_precision; + *lfp++ = prevcoord[1] * inv_precision; + *lfp++ = prevcoord[2] * inv_precision; + } else { + prevcoord[0] = thiscoord[0]; + prevcoord[1] = thiscoord[1]; + prevcoord[2] = thiscoord[2]; + } + *lfp++ = thiscoord[0] * inv_precision; + *lfp++ = thiscoord[1] * inv_precision; + *lfp++ = thiscoord[2] * inv_precision; + } + } else { + *lfp++ = thiscoord[0] * inv_precision; + *lfp++ = thiscoord[1] * inv_precision; + *lfp++ = thiscoord[2] * inv_precision; + } + smallidx += is_smaller; + if (is_smaller < 0) { + small = smaller; + if (smallidx > FIRSTIDX) { + smaller = magicints[smallidx - 1] /2; + } else { + smaller = 0; + } + } else if (is_smaller > 0) { + smaller = small; + small = magicints[smallidx] / 2; + } + sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx] ; + } + } + return 1; +} + + + diff --git a/source/wham/src-NEWSC-NEWCORR/xdrf/libxdrf.m4.org b/source/wham/src-NEWSC-NEWCORR/xdrf/libxdrf.m4.org new file mode 100644 index 0000000..b14b374 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/xdrf/libxdrf.m4.org @@ -0,0 +1,1230 @@ +/*____________________________________________________________________________ + | + | libxdrf - portable fortran interface to xdr. some xdr routines + | are C routines for compressed coordinates + | + | version 1.1 + | + | This collection of routines is intended to write and read + | data in a portable way to a file, so data written on one type + | of machine can be read back on a different type. + | + | all fortran routines use an integer 'xdrid', which is an id to the + | current xdr file, and is set by xdrfopen. + | most routines have in integer 'ret' which is the return value. + | The value of 'ret' is zero on failure, and most of the time one + | on succes. + | + | There are three routines useful for C users: + | xdropen(), xdrclose(), xdr3dfcoord(). + | The first two replace xdrstdio_create and xdr_destroy, and *must* be + | used when you plan to use xdr3dfcoord(). (they are also a bit + | easier to interface). For writing data other than compressed coordinates + | you should use the standard C xdr routines (see xdr man page) + | + | xdrfopen(xdrid, filename, mode, ret) + | character *(*) filename + | character *(*) mode + | + | this will open the file with the given filename (string) + | and the given mode, it returns an id in xdrid, which is + | to be used in all other calls to xdrf routines. + | mode is 'w' to create, or update an file, for all other + | values of mode the file is opened for reading + | + | you need to call xdrfclose to flush the output and close + | the file. + | Note that you should not use xdrstdio_create, which comes with the + | standard xdr library + | + | xdrfclose(xdrid, ret) + | flush the data to the file, and closes the file; + | You should not use xdr_destroy (which comes standard with + | the xdr libraries. + | + | xdrfbool(xdrid, bp, ret) + | integer pb + | + | This filter produces values of either 1 or 0 + | + | xdrfchar(xdrid, cp, ret) + | character cp + | + | filter that translate between characters and their xdr representation + | Note that the characters in not compressed and occupies 4 bytes. + | + | xdrfdouble(xdrid, dp, ret) + | double dp + | + | read/write a double. + | + | xdrffloat(xdrid, fp, ret) + | float fp + | + | read/write a float. + | + | xdrfint(xdrid, ip, ret) + | integer ip + | + | read/write integer. + | + | xdrflong(xdrid, lp, ret) + | integer lp + | + | this routine has a possible portablility problem due to 64 bits longs. + | + | xdrfshort(xdrid, sp, ret) + | integer *2 sp + | + | xdrfstring(xdrid, sp, maxsize, ret) + | character *(*) + | integer maxsize + | + | read/write a string, with maximum length given by maxsize + | + | xdrfwrapstring(xdris, sp, ret) + | character *(*) + | + | read/write a string (it is the same as xdrfstring accept that it finds + | the stringlength itself. + | + | xdrfvector(xdrid, cp, size, xdrfproc, ret) + | character *(*) + | integer size + | external xdrfproc + | + | read/write an array pointed to by cp, with number of elements + | defined by 'size'. the routine 'xdrfproc' is the name + | of one of the above routines to read/write data (like xdrfdouble) + | In contrast with the c-version you don't need to specify the + | byte size of an element. + | xdrfstring is not allowed here (it is in the c version) + | + | xdrf3dfcoord(xdrid, fp, size, precision, ret) + | real (*) fp + | real precision + | integer size + | + | this is *NOT* a standard xdr routine. I named it this way, because + | it invites people to use the other xdr routines. + | It is introduced to store specifically 3d coordinates of molecules + | (as found in molecular dynamics) and it writes it in a compressed way. + | It starts by multiplying all numbers by precision and + | rounding the result to integer. effectively converting + | all floating point numbers to fixed point. + | it uses an algorithm for compression that is optimized for + | molecular data, but could be used for other 3d coordinates + | as well. There is subtantial overhead involved, so call this + | routine only if you have a large number of coordinates to read/write + | + | ________________________________________________________________________ + | + | Below are the routines to be used by C programmers. Use the 'normal' + | xdr routines to write integers, floats, etc (see man xdr) + | + | int xdropen(XDR *xdrs, const char *filename, const char *type) + | This will open the file with the given filename and the + | given mode. You should pass it an allocated XDR struct + | in xdrs, to be used in all other calls to xdr routines. + | Mode is 'w' to create, or update an file, and for all + | other values of mode the file is opened for reading. + | You need to call xdrclose to flush the output and close + | the file. + | + | Note that you should not use xdrstdio_create, which + | comes with the standard xdr library. + | + | int xdrclose(XDR *xdrs) + | Flush the data to the file, and close the file; + | You should not use xdr_destroy (which comes standard + | with the xdr libraries). + | + | int xdr3dfcoord(XDR *xdrs, float *fp, int *size, float *precision) + | This is \fInot\fR a standard xdr routine. I named it this + | way, because it invites people to use the other xdr + | routines. + | + | (c) 1995 Frans van Hoesel, hoesel@chem.rug.nl +*/ + + +#include +#include +#include +#include +#include +#include +#include +#include "xdrf.h" + +int ftocstr(char *, int, char *, int); +int ctofstr(char *, int, char *); + +#define MAXID 20 +static FILE *xdrfiles[MAXID]; +static XDR *xdridptr[MAXID]; +static char xdrmodes[MAXID]; +static unsigned int cnt; + +typedef void (* FUNCTION(xdrfproc)) (int *, void *, int *); + +void +FUNCTION(xdrfbool) ARGS(`xdrid, pb, ret') +int *xdrid, *ret; +int *pb; +{ + *ret = xdr_bool(xdridptr[*xdrid], (bool_t *) pb); + cnt += sizeof(int); +} + +void +FUNCTION(xdrfchar) ARGS(`xdrid, cp, ret') +int *xdrid, *ret; +char *cp; +{ + *ret = xdr_char(xdridptr[*xdrid], cp); + cnt += sizeof(char); +} + +void +FUNCTION(xdrfdouble) ARGS(`xdrid, dp, ret') +int *xdrid, *ret; +double *dp; +{ + *ret = xdr_double(xdridptr[*xdrid], dp); + cnt += sizeof(double); +} + +void +FUNCTION(xdrffloat) ARGS(`xdrid, fp, ret') +int *xdrid, *ret; +float *fp; +{ + *ret = xdr_float(xdridptr[*xdrid], fp); + cnt += sizeof(float); +} + +void +FUNCTION(xdrfint) ARGS(`xdrid, ip, ret') +int *xdrid, *ret; +int *ip; +{ + *ret = xdr_int(xdridptr[*xdrid], ip); + cnt += sizeof(int); +} + +void +FUNCTION(xdrflong) ARGS(`xdrid, lp, ret') +int *xdrid, *ret; +long *lp; +{ + *ret = xdr_long(xdridptr[*xdrid], lp); + cnt += sizeof(long); +} + +void +FUNCTION(xdrfshort) ARGS(`xdrid, sp, ret') +int *xdrid, *ret; +short *sp; +{ + *ret = xdr_short(xdridptr[*xdrid], sp); + cnt += sizeof(sp); +} + +void +FUNCTION(xdrfuchar) ARGS(`xdrid, ucp, ret') +int *xdrid, *ret; +char *ucp; +{ + *ret = xdr_u_char(xdridptr[*xdrid], ucp); + cnt += sizeof(char); +} + +void +FUNCTION(xdrfulong) ARGS(`xdrid, ulp, ret') +int *xdrid, *ret; +unsigned long *ulp; +{ + *ret = xdr_u_long(xdridptr[*xdrid], ulp); + cnt += sizeof(unsigned long); +} + +void +FUNCTION(xdrfushort) ARGS(`xdrid, usp, ret') +int *xdrid, *ret; +unsigned short *usp; +{ + *ret = xdr_u_short(xdridptr[*xdrid], usp); + cnt += sizeof(unsigned short); +} + +void +FUNCTION(xdrf3dfcoord) ARGS(`xdrid, fp, size, precision, ret') +int *xdrid, *ret; +float *fp; +int *size; +float *precision; +{ + *ret = xdr3dfcoord(xdridptr[*xdrid], fp, size, precision); +} + +void +FUNCTION(xdrfstring) ARGS(`xdrid, STRING_ARG(sp), maxsize, ret') +int *xdrid, *ret; +STRING_ARG_DECL(sp); +int *maxsize; +{ + char *tsp; + + tsp = (char*) malloc(((STRING_LEN(sp)) + 1) * sizeof(char)); + if (tsp == NULL) { + *ret = -1; + return; + } + if (ftocstr(tsp, *maxsize+1, STRING_PTR(sp), STRING_LEN(sp))) { + *ret = -1; + free(tsp); + return; + } + *ret = xdr_string(xdridptr[*xdrid], (char **) &tsp, (u_int) *maxsize); + ctofstr( STRING_PTR(sp), STRING_LEN(sp), tsp); + cnt += *maxsize; + free(tsp); +} + +void +FUNCTION(xdrfwrapstring) ARGS(`xdrid, STRING_ARG(sp), ret') +int *xdrid, *ret; +STRING_ARG_DECL(sp); +{ + char *tsp; + int maxsize; + maxsize = (STRING_LEN(sp)) + 1; + tsp = (char*) malloc(maxsize * sizeof(char)); + if (tsp == NULL) { + *ret = -1; + return; + } + if (ftocstr(tsp, maxsize, STRING_PTR(sp), STRING_LEN(sp))) { + *ret = -1; + free(tsp); + return; + } + *ret = xdr_string(xdridptr[*xdrid], (char **) &tsp, (u_int)maxsize); + ctofstr( STRING_PTR(sp), STRING_LEN(sp), tsp); + cnt += maxsize; + free(tsp); +} + +void +FUNCTION(xdrfopaque) ARGS(`xdrid, cp, ccnt, ret') +int *xdrid, *ret; +caddr_t *cp; +int *ccnt; +{ + *ret = xdr_opaque(xdridptr[*xdrid], (caddr_t)*cp, (u_int)*ccnt); + cnt += *ccnt; +} + +void +FUNCTION(xdrfsetpos) ARGS(`xdrid, pos, ret') +int *xdrid, *ret; +int *pos; +{ + *ret = xdr_setpos(xdridptr[*xdrid], (u_int) *pos); +} + +void +FUNCTION(xdrf) ARGS(`xdrid, pos') +int *xdrid, *pos; +{ + *pos = xdr_getpos(xdridptr[*xdrid]); +} + +void +FUNCTION(xdrfvector) ARGS(`xdrid, cp, size, elproc, ret') +int *xdrid, *ret; +char *cp; +int *size; +FUNCTION(xdrfproc) elproc; +{ + int lcnt; + cnt = 0; + for (lcnt = 0; lcnt < *size; lcnt++) { + elproc(xdrid, (cp+cnt) , ret); + } +} + + +void +FUNCTION(xdrfclose) ARGS(`xdrid, ret') +int *xdrid; +int *ret; +{ + *ret = xdrclose(xdridptr[*xdrid]); + cnt = 0; +} + +void +FUNCTION(xdrfopen) ARGS(`xdrid, STRING_ARG(fp), STRING_ARG(mode), ret') +int *xdrid; +STRING_ARG_DECL(fp); +STRING_ARG_DECL(mode); +int *ret; +{ + char fname[512]; + char fmode[3]; + + if (ftocstr(fname, sizeof(fname), STRING_PTR(fp), STRING_LEN(fp))) { + *ret = 0; + } + if (ftocstr(fmode, sizeof(fmode), STRING_PTR(mode), + STRING_LEN(mode))) { + *ret = 0; + } + + *xdrid = xdropen(NULL, fname, fmode); + if (*xdrid == 0) + *ret = 0; + else + *ret = 1; +} + +/*___________________________________________________________________________ + | + | what follows are the C routines for opening, closing xdr streams + | and the routine to read/write compressed coordinates together + | with some routines to assist in this task (those are marked + | static and cannot be called from user programs) +*/ +#define MAXABS INT_MAX-2 + +#ifndef MIN +#define MIN(x,y) ((x) < (y) ? (x):(y)) +#endif +#ifndef MAX +#define MAX(x,y) ((x) > (y) ? (x):(y)) +#endif +#ifndef SQR +#define SQR(x) ((x)*(x)) +#endif +static int magicints[] = { + 0, 0, 0, 0, 0, 0, 0, 0, 0, + 8, 10, 12, 16, 20, 25, 32, 40, 50, 64, + 80, 101, 128, 161, 203, 256, 322, 406, 512, 645, + 812, 1024, 1290, 1625, 2048, 2580, 3250, 4096, 5060, 6501, + 8192, 10321, 13003, 16384, 20642, 26007, 32768, 41285, 52015, 65536, + 82570, 104031, 131072, 165140, 208063, 262144, 330280, 416127, 524287, 660561, + 832255, 1048576, 1321122, 1664510, 2097152, 2642245, 3329021, 4194304, 5284491, 6658042, + 8388607, 10568983, 13316085, 16777216 }; + +#define FIRSTIDX 9 +/* note that magicints[FIRSTIDX-1] == 0 */ +#define LASTIDX (sizeof(magicints) / sizeof(*magicints)) + + +/*__________________________________________________________________________ + | + | xdropen - open xdr file + | + | This versions differs from xdrstdio_create, because I need to know + | the state of the file (read or write) so I can use xdr3dfcoord + | in eigther read or write mode, and the file descriptor + | so I can close the file (something xdr_destroy doesn't do). + | +*/ + +int xdropen(XDR *xdrs, const char *filename, const char *type) { + static int init_done = 0; + enum xdr_op lmode; + 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+"; + lmode = XDR_ENCODE; + } else { + type = "r"; + lmode = XDR_DECODE; + } + xdrfiles[xdrid] = fopen(filename, type); + if (xdrfiles[xdrid] == NULL) { + xdrs = NULL; + return 0; + } + xdrmodes[xdrid] = *type; + /* next test isn't usefull in the case of C language + * but is used for the Fortran interface + * (C users are expected to pass the address of an already allocated + * XDR staructure) + */ + if (xdrs == NULL) { + xdridptr[xdrid] = (XDR *) malloc(sizeof(XDR)); + xdrstdio_create(xdridptr[xdrid], xdrfiles[xdrid], lmode); + } else { + xdridptr[xdrid] = xdrs; + xdrstdio_create(xdrs, xdrfiles[xdrid], lmode); + } + return xdrid; +} + +/*_________________________________________________________________________ + | + | xdrclose - close a xdr file + | + | This will flush the xdr buffers, and destroy the xdr stream. + | It also closes the associated file descriptor (this is *not* + | done by xdr_destroy). + | +*/ + +int xdrclose(XDR *xdrs) { + int xdrid; + + if (xdrs == NULL) { + fprintf(stderr, "xdrclose: passed a NULL pointer\n"); + exit(1); + } + for (xdrid = 1; xdrid < MAXID; xdrid++) { + if (xdridptr[xdrid] == xdrs) { + + xdr_destroy(xdrs); + fclose(xdrfiles[xdrid]); + xdridptr[xdrid] = NULL; + return 1; + } + } + fprintf(stderr, "xdrclose: no such open xdr file\n"); + exit(1); + +} + +/*____________________________________________________________________________ + | + | sendbits - encode num into buf using the specified number of bits + | + | This routines appends the value of num to the bits already present in + | the array buf. You need to give it the number of bits to use and you + | better make sure that this number of bits is enough to hold the value + | Also num must be positive. + | +*/ + +static void sendbits(int buf[], int num_of_bits, int num) { + + unsigned int cnt, lastbyte; + int lastbits; + unsigned char * cbuf; + + cbuf = ((unsigned char *)buf) + 3 * sizeof(*buf); + cnt = (unsigned int) buf[0]; + lastbits = buf[1]; + lastbyte =(unsigned int) buf[2]; + while (num_of_bits >= 8) { + lastbyte = (lastbyte << 8) | ((num >> (num_of_bits -8)) /* & 0xff*/); + cbuf[cnt++] = lastbyte >> lastbits; + num_of_bits -= 8; + } + if (num_of_bits > 0) { + lastbyte = (lastbyte << num_of_bits) | num; + lastbits += num_of_bits; + if (lastbits >= 8) { + lastbits -= 8; + cbuf[cnt++] = lastbyte >> lastbits; + } + } + buf[0] = cnt; + buf[1] = lastbits; + buf[2] = lastbyte; + if (lastbits>0) { + cbuf[cnt] = lastbyte << (8 - lastbits); + } +} + +/*_________________________________________________________________________ + | + | sizeofint - calculate bitsize of an integer + | + | return the number of bits needed to store an integer with given max size + | +*/ + +static int sizeofint(const int size) { + unsigned int num = 1; + int num_of_bits = 0; + + while (size >= num && num_of_bits < 32) { + num_of_bits++; + num <<= 1; + } + return num_of_bits; +} + +/*___________________________________________________________________________ + | + | sizeofints - calculate 'bitsize' of compressed ints + | + | given the number of small unsigned integers and the maximum value + | return the number of bits needed to read or write them with the + | routines receiveints and sendints. You need this parameter when + | calling these routines. Note that for many calls I can use + | the variable 'smallidx' which is exactly the number of bits, and + | So I don't need to call 'sizeofints for those calls. +*/ + +static int sizeofints( const int num_of_ints, unsigned int sizes[]) { + int i, num; + unsigned int num_of_bytes, num_of_bits, bytes[32], bytecnt, tmp; + num_of_bytes = 1; + bytes[0] = 1; + num_of_bits = 0; + for (i=0; i < num_of_ints; i++) { + tmp = 0; + for (bytecnt = 0; bytecnt < num_of_bytes; bytecnt++) { + tmp = bytes[bytecnt] * sizes[i] + tmp; + bytes[bytecnt] = tmp & 0xff; + tmp >>= 8; + } + while (tmp != 0) { + bytes[bytecnt++] = tmp & 0xff; + tmp >>= 8; + } + num_of_bytes = bytecnt; + } + num = 1; + num_of_bytes--; + while (bytes[num_of_bytes] >= num) { + num_of_bits++; + num *= 2; + } + return num_of_bits + num_of_bytes * 8; + +} + +/*____________________________________________________________________________ + | + | sendints - send a small set of small integers in compressed format + | + | this routine is used internally by xdr3dfcoord, to send a set of + | small integers to the buffer. + | Multiplication with fixed (specified maximum ) sizes is used to get + | to one big, multibyte integer. Allthough the routine could be + | modified to handle sizes bigger than 16777216, or more than just + | a few integers, this is not done, because the gain in compression + | isn't worth the effort. Note that overflowing the multiplication + | or the byte buffer (32 bytes) is unchecked and causes bad results. + | + */ + +static void sendints(int buf[], const int num_of_ints, const int num_of_bits, + unsigned int sizes[], unsigned int nums[]) { + + int i; + unsigned int bytes[32], num_of_bytes, bytecnt, tmp; + + tmp = nums[0]; + num_of_bytes = 0; + do { + bytes[num_of_bytes++] = tmp & 0xff; + tmp >>= 8; + } while (tmp != 0); + + for (i = 1; i < num_of_ints; i++) { + if (nums[i] >= sizes[i]) { + fprintf(stderr,"major breakdown in sendints num %d doesn't " + "match size %d\n", nums[i], sizes[i]); + exit(1); + } + /* use one step multiply */ + tmp = nums[i]; + for (bytecnt = 0; bytecnt < num_of_bytes; bytecnt++) { + tmp = bytes[bytecnt] * sizes[i] + tmp; + bytes[bytecnt] = tmp & 0xff; + tmp >>= 8; + } + while (tmp != 0) { + bytes[bytecnt++] = tmp & 0xff; + tmp >>= 8; + } + num_of_bytes = bytecnt; + } + if (num_of_bits >= num_of_bytes * 8) { + for (i = 0; i < num_of_bytes; i++) { + sendbits(buf, 8, bytes[i]); + } + sendbits(buf, num_of_bits - num_of_bytes * 8, 0); + } else { + for (i = 0; i < num_of_bytes-1; i++) { + sendbits(buf, 8, bytes[i]); + } + sendbits(buf, num_of_bits- (num_of_bytes -1) * 8, bytes[i]); + } +} + + +/*___________________________________________________________________________ + | + | receivebits - decode number from buf using specified number of bits + | + | extract the number of bits from the array buf and construct an integer + | from it. Return that value. + | +*/ + +static int receivebits(int buf[], int num_of_bits) { + + int cnt, num; + unsigned int lastbits, lastbyte; + unsigned char * cbuf; + int mask = (1 << num_of_bits) -1; + + cbuf = ((unsigned char *)buf) + 3 * sizeof(*buf); + cnt = buf[0]; + lastbits = (unsigned int) buf[1]; + lastbyte = (unsigned int) buf[2]; + + num = 0; + while (num_of_bits >= 8) { + lastbyte = ( lastbyte << 8 ) | cbuf[cnt++]; + num |= (lastbyte >> lastbits) << (num_of_bits - 8); + num_of_bits -=8; + } + if (num_of_bits > 0) { + if (lastbits < num_of_bits) { + lastbits += 8; + lastbyte = (lastbyte << 8) | cbuf[cnt++]; + } + lastbits -= num_of_bits; + num |= (lastbyte >> lastbits) & ((1 << num_of_bits) -1); + } + num &= mask; + buf[0] = cnt; + buf[1] = lastbits; + buf[2] = lastbyte; + return num; +} + +/*____________________________________________________________________________ + | + | receiveints - decode 'small' integers from the buf array + | + | this routine is the inverse from sendints() and decodes the small integers + | written to buf by calculating the remainder and doing divisions with + | the given sizes[]. You need to specify the total number of bits to be + | used from buf in num_of_bits. + | +*/ + +static void receiveints(int buf[], const int num_of_ints, int num_of_bits, + unsigned int sizes[], int nums[]) { + int bytes[32]; + int i, j, num_of_bytes, p, num; + + bytes[1] = bytes[2] = bytes[3] = 0; + num_of_bytes = 0; + while (num_of_bits > 8) { + bytes[num_of_bytes++] = receivebits(buf, 8); + num_of_bits -= 8; + } + if (num_of_bits > 0) { + bytes[num_of_bytes++] = receivebits(buf, num_of_bits); + } + for (i = num_of_ints-1; i > 0; i--) { + num = 0; + for (j = num_of_bytes-1; j >=0; j--) { + num = (num << 8) | bytes[j]; + p = num / sizes[i]; + bytes[j] = p; + num = num - p * sizes[i]; + } + nums[i] = num; + } + nums[0] = bytes[0] | (bytes[1] << 8) | (bytes[2] << 16) | (bytes[3] << 24); +} + +/*____________________________________________________________________________ + | + | xdr3dfcoord - read or write compressed 3d coordinates to xdr file. + | + | this routine reads or writes (depending on how you opened the file with + | xdropen() ) a large number of 3d coordinates (stored in *fp). + | The number of coordinates triplets to write is given by *size. On + | read this number may be zero, in which case it reads as many as were written + | or it may specify the number if triplets to read (which should match the + | number written). + | Compression is achieved by first converting all floating numbers to integer + | using multiplication by *precision and rounding to the nearest integer. + | Then the minimum and maximum value are calculated to determine the range. + | The limited range of integers so found, is used to compress the coordinates. + | In addition the differences between succesive coordinates is calculated. + | If the difference happens to be 'small' then only the difference is saved, + | compressing the data even more. The notion of 'small' is changed dynamically + | and is enlarged or reduced whenever needed or possible. + | Extra compression is achieved in the case of GROMOS and coordinates of + | water molecules. GROMOS first writes out the Oxygen position, followed by + | the two hydrogens. In order to make the differences smaller (and thereby + | compression the data better) the order is changed into first one hydrogen + | then the oxygen, followed by the other hydrogen. This is rather special, but + | it shouldn't harm in the general case. + | + */ + +int xdr3dfcoord(XDR *xdrs, float *fp, int *size, float *precision) { + + + static int *ip = NULL; + static int oldsize; + static int *buf; + + int minint[3], maxint[3], mindiff, *lip, diff; + int lint1, lint2, lint3, oldlint1, oldlint2, oldlint3, smallidx; + int minidx, maxidx; + unsigned sizeint[3], sizesmall[3], bitsizeint[3], size3, *luip; + int flag, k; + int small, smaller, larger, i, is_small, is_smaller, run, prevrun; + float *lfp, lf; + int tmp, *thiscoord, prevcoord[3]; + unsigned int tmpcoord[30]; + + int bufsize, xdrid, lsize; + unsigned int bitsize; + float inv_precision; + int errval = 1; + + /* find out if xdrs is opened for reading or for writing */ + xdrid = 0; + while (xdridptr[xdrid] != xdrs) { + xdrid++; + if (xdrid >= MAXID) { + fprintf(stderr, "xdr error. no open xdr stream\n"); + exit (1); + } + } + if (xdrmodes[xdrid] == 'w') { + + /* xdrs is open for writing */ + + if (xdr_int(xdrs, size) == 0) + return 0; + size3 = *size * 3; + /* when the number of coordinates is small, don't try to compress; just + * write them as floats using xdr_vector + */ + if (*size <= 9 ) { + return (xdr_vector(xdrs, (char *) fp, size3, sizeof(*fp), + (xdrproc_t)xdr_float)); + } + + xdr_float(xdrs, precision); + if (ip == NULL) { + ip = (int *)malloc(size3 * sizeof(*ip)); + if (ip == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + bufsize = size3 * 1.2; + buf = (int *)malloc(bufsize * sizeof(*buf)); + if (buf == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + oldsize = *size; + } else if (*size > oldsize) { + ip = (int *)realloc(ip, size3 * sizeof(*ip)); + if (ip == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + bufsize = size3 * 1.2; + buf = (int *)realloc(buf, bufsize * sizeof(*buf)); + if (buf == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + oldsize = *size; + } + /* buf[0-2] are special and do not contain actual data */ + buf[0] = buf[1] = buf[2] = 0; + minint[0] = minint[1] = minint[2] = INT_MAX; + maxint[0] = maxint[1] = maxint[2] = INT_MIN; + prevrun = -1; + lfp = fp; + lip = ip; + mindiff = INT_MAX; + oldlint1 = oldlint2 = oldlint3 = 0; + while(lfp < fp + size3 ) { + /* find nearest integer */ + if (*lfp >= 0.0) + lf = *lfp * *precision + 0.5; + else + lf = *lfp * *precision - 0.5; + if (fabs(lf) > MAXABS) { + /* scaling would cause overflow */ + errval = 0; + } + lint1 = lf; + if (lint1 < minint[0]) minint[0] = lint1; + if (lint1 > maxint[0]) maxint[0] = lint1; + *lip++ = lint1; + lfp++; + if (*lfp >= 0.0) + lf = *lfp * *precision + 0.5; + else + lf = *lfp * *precision - 0.5; + if (fabs(lf) > MAXABS) { + /* scaling would cause overflow */ + errval = 0; + } + lint2 = lf; + if (lint2 < minint[1]) minint[1] = lint2; + if (lint2 > maxint[1]) maxint[1] = lint2; + *lip++ = lint2; + lfp++; + if (*lfp >= 0.0) + lf = *lfp * *precision + 0.5; + else + lf = *lfp * *precision - 0.5; + if (fabs(lf) > MAXABS) { + /* scaling would cause overflow */ + errval = 0; + } + lint3 = lf; + if (lint3 < minint[2]) minint[2] = lint3; + if (lint3 > maxint[2]) maxint[2] = lint3; + *lip++ = lint3; + lfp++; + diff = abs(oldlint1-lint1)+abs(oldlint2-lint2)+abs(oldlint3-lint3); + if (diff < mindiff && lfp > fp + 3) + mindiff = diff; + oldlint1 = lint1; + oldlint2 = lint2; + oldlint3 = lint3; + } + xdr_int(xdrs, &(minint[0])); + xdr_int(xdrs, &(minint[1])); + xdr_int(xdrs, &(minint[2])); + + xdr_int(xdrs, &(maxint[0])); + xdr_int(xdrs, &(maxint[1])); + xdr_int(xdrs, &(maxint[2])); + + if ((float)maxint[0] - (float)minint[0] >= MAXABS || + (float)maxint[1] - (float)minint[1] >= MAXABS || + (float)maxint[2] - (float)minint[2] >= MAXABS) { + /* turning value in unsigned by subtracting minint + * would cause overflow + */ + errval = 0; + } + sizeint[0] = maxint[0] - minint[0]+1; + sizeint[1] = maxint[1] - minint[1]+1; + sizeint[2] = maxint[2] - minint[2]+1; + + /* check if one of the sizes is to big to be multiplied */ + if ((sizeint[0] | sizeint[1] | sizeint[2] ) > 0xffffff) { + bitsizeint[0] = sizeofint(sizeint[0]); + bitsizeint[1] = sizeofint(sizeint[1]); + bitsizeint[2] = sizeofint(sizeint[2]); + bitsize = 0; /* flag the use of large sizes */ + } else { + bitsize = sizeofints(3, sizeint); + } + lip = ip; + luip = (unsigned int *) ip; + smallidx = FIRSTIDX; + while (smallidx < LASTIDX && magicints[smallidx] < mindiff) { + smallidx++; + } + xdr_int(xdrs, &smallidx); + maxidx = MIN(LASTIDX, smallidx + 8) ; + minidx = maxidx - 8; /* often this equal smallidx */ + smaller = magicints[MAX(FIRSTIDX, smallidx-1)] / 2; + small = magicints[smallidx] / 2; + sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx]; + larger = magicints[maxidx] / 2; + i = 0; + while (i < *size) { + is_small = 0; + thiscoord = (int *)(luip) + i * 3; + if (smallidx < maxidx && i >= 1 && + abs(thiscoord[0] - prevcoord[0]) < larger && + abs(thiscoord[1] - prevcoord[1]) < larger && + abs(thiscoord[2] - prevcoord[2]) < larger) { + is_smaller = 1; + } else if (smallidx > minidx) { + is_smaller = -1; + } else { + is_smaller = 0; + } + if (i + 1 < *size) { + if (abs(thiscoord[0] - thiscoord[3]) < small && + abs(thiscoord[1] - thiscoord[4]) < small && + abs(thiscoord[2] - thiscoord[5]) < small) { + /* interchange first with second atom for better + * compression of water molecules + */ + tmp = thiscoord[0]; thiscoord[0] = thiscoord[3]; + thiscoord[3] = tmp; + tmp = thiscoord[1]; thiscoord[1] = thiscoord[4]; + thiscoord[4] = tmp; + tmp = thiscoord[2]; thiscoord[2] = thiscoord[5]; + thiscoord[5] = tmp; + is_small = 1; + } + + } + tmpcoord[0] = thiscoord[0] - minint[0]; + tmpcoord[1] = thiscoord[1] - minint[1]; + tmpcoord[2] = thiscoord[2] - minint[2]; + if (bitsize == 0) { + sendbits(buf, bitsizeint[0], tmpcoord[0]); + sendbits(buf, bitsizeint[1], tmpcoord[1]); + sendbits(buf, bitsizeint[2], tmpcoord[2]); + } else { + sendints(buf, 3, bitsize, sizeint, tmpcoord); + } + prevcoord[0] = thiscoord[0]; + prevcoord[1] = thiscoord[1]; + prevcoord[2] = thiscoord[2]; + thiscoord = thiscoord + 3; + i++; + + run = 0; + if (is_small == 0 && is_smaller == -1) + is_smaller = 0; + while (is_small && run < 8*3) { + if (is_smaller == -1 && ( + SQR(thiscoord[0] - prevcoord[0]) + + SQR(thiscoord[1] - prevcoord[1]) + + SQR(thiscoord[2] - prevcoord[2]) >= smaller * smaller)) { + is_smaller = 0; + } + + tmpcoord[run++] = thiscoord[0] - prevcoord[0] + small; + tmpcoord[run++] = thiscoord[1] - prevcoord[1] + small; + tmpcoord[run++] = thiscoord[2] - prevcoord[2] + small; + + prevcoord[0] = thiscoord[0]; + prevcoord[1] = thiscoord[1]; + prevcoord[2] = thiscoord[2]; + + i++; + thiscoord = thiscoord + 3; + is_small = 0; + if (i < *size && + abs(thiscoord[0] - prevcoord[0]) < small && + abs(thiscoord[1] - prevcoord[1]) < small && + abs(thiscoord[2] - prevcoord[2]) < small) { + is_small = 1; + } + } + if (run != prevrun || is_smaller != 0) { + prevrun = run; + sendbits(buf, 1, 1); /* flag the change in run-length */ + sendbits(buf, 5, run+is_smaller+1); + } else { + sendbits(buf, 1, 0); /* flag the fact that runlength did not change */ + } + for (k=0; k < run; k+=3) { + sendints(buf, 3, smallidx, sizesmall, &tmpcoord[k]); + } + if (is_smaller != 0) { + smallidx += is_smaller; + if (is_smaller < 0) { + small = smaller; + smaller = magicints[smallidx-1] / 2; + } else { + smaller = small; + small = magicints[smallidx] / 2; + } + sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx]; + } + } + if (buf[1] != 0) buf[0]++;; + xdr_int(xdrs, &(buf[0])); /* buf[0] holds the length in bytes */ + return errval * (xdr_opaque(xdrs, (caddr_t)&(buf[3]), (u_int)buf[0])); + } else { + + /* xdrs is open for reading */ + + if (xdr_int(xdrs, &lsize) == 0) + return 0; + if (*size != 0 && lsize != *size) { + fprintf(stderr, "wrong number of coordinates in xdr3dfcoor; " + "%d arg vs %d in file", *size, lsize); + } + *size = lsize; + size3 = *size * 3; + if (*size <= 9) { + return (xdr_vector(xdrs, (char *) fp, size3, sizeof(*fp), + (xdrproc_t)xdr_float)); + } + xdr_float(xdrs, precision); + if (ip == NULL) { + ip = (int *)malloc(size3 * sizeof(*ip)); + if (ip == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + bufsize = size3 * 1.2; + buf = (int *)malloc(bufsize * sizeof(*buf)); + if (buf == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + oldsize = *size; + } else if (*size > oldsize) { + ip = (int *)realloc(ip, size3 * sizeof(*ip)); + if (ip == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + bufsize = size3 * 1.2; + buf = (int *)realloc(buf, bufsize * sizeof(*buf)); + if (buf == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + oldsize = *size; + } + buf[0] = buf[1] = buf[2] = 0; + + xdr_int(xdrs, &(minint[0])); + xdr_int(xdrs, &(minint[1])); + xdr_int(xdrs, &(minint[2])); + + xdr_int(xdrs, &(maxint[0])); + xdr_int(xdrs, &(maxint[1])); + xdr_int(xdrs, &(maxint[2])); + + sizeint[0] = maxint[0] - minint[0]+1; + sizeint[1] = maxint[1] - minint[1]+1; + sizeint[2] = maxint[2] - minint[2]+1; + + /* check if one of the sizes is to big to be multiplied */ + if ((sizeint[0] | sizeint[1] | sizeint[2] ) > 0xffffff) { + bitsizeint[0] = sizeofint(sizeint[0]); + bitsizeint[1] = sizeofint(sizeint[1]); + bitsizeint[2] = sizeofint(sizeint[2]); + bitsize = 0; /* flag the use of large sizes */ + } else { + bitsize = sizeofints(3, sizeint); + } + + xdr_int(xdrs, &smallidx); + maxidx = MIN(LASTIDX, smallidx + 8) ; + minidx = maxidx - 8; /* often this equal smallidx */ + smaller = magicints[MAX(FIRSTIDX, smallidx-1)] / 2; + small = magicints[smallidx] / 2; + sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx] ; + larger = magicints[maxidx]; + + /* buf[0] holds the length in bytes */ + + if (xdr_int(xdrs, &(buf[0])) == 0) + return 0; + if (xdr_opaque(xdrs, (caddr_t)&(buf[3]), (u_int)buf[0]) == 0) + return 0; + buf[0] = buf[1] = buf[2] = 0; + + lfp = fp; + inv_precision = 1.0 / * precision; + run = 0; + i = 0; + lip = ip; + while ( i < lsize ) { + thiscoord = (int *)(lip) + i * 3; + + if (bitsize == 0) { + thiscoord[0] = receivebits(buf, bitsizeint[0]); + thiscoord[1] = receivebits(buf, bitsizeint[1]); + thiscoord[2] = receivebits(buf, bitsizeint[2]); + } else { + receiveints(buf, 3, bitsize, sizeint, thiscoord); + } + + i++; + thiscoord[0] += minint[0]; + thiscoord[1] += minint[1]; + thiscoord[2] += minint[2]; + + prevcoord[0] = thiscoord[0]; + prevcoord[1] = thiscoord[1]; + prevcoord[2] = thiscoord[2]; + + + flag = receivebits(buf, 1); + is_smaller = 0; + if (flag == 1) { + run = receivebits(buf, 5); + is_smaller = run % 3; + run -= is_smaller; + is_smaller--; + } + if (run > 0) { + thiscoord += 3; + for (k = 0; k < run; k+=3) { + receiveints(buf, 3, smallidx, sizesmall, thiscoord); + i++; + thiscoord[0] += prevcoord[0] - small; + thiscoord[1] += prevcoord[1] - small; + thiscoord[2] += prevcoord[2] - small; + if (k == 0) { + /* interchange first with second atom for better + * compression of water molecules + */ + tmp = thiscoord[0]; thiscoord[0] = prevcoord[0]; + prevcoord[0] = tmp; + tmp = thiscoord[1]; thiscoord[1] = prevcoord[1]; + prevcoord[1] = tmp; + tmp = thiscoord[2]; thiscoord[2] = prevcoord[2]; + prevcoord[2] = tmp; + *lfp++ = prevcoord[0] * inv_precision; + *lfp++ = prevcoord[1] * inv_precision; + *lfp++ = prevcoord[2] * inv_precision; + } else { + prevcoord[0] = thiscoord[0]; + prevcoord[1] = thiscoord[1]; + prevcoord[2] = thiscoord[2]; + } + *lfp++ = thiscoord[0] * inv_precision; + *lfp++ = thiscoord[1] * inv_precision; + *lfp++ = thiscoord[2] * inv_precision; + } + } else { + *lfp++ = thiscoord[0] * inv_precision; + *lfp++ = thiscoord[1] * inv_precision; + *lfp++ = thiscoord[2] * inv_precision; + } + smallidx += is_smaller; + if (is_smaller < 0) { + small = smaller; + if (smallidx > FIRSTIDX) { + smaller = magicints[smallidx - 1] /2; + } else { + smaller = 0; + } + } else if (is_smaller > 0) { + smaller = small; + small = magicints[smallidx] / 2; + } + sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx] ; + } + } + return 1; +} + + + diff --git a/source/wham/src-NEWSC-NEWCORR/xdrf/underscore.m4 b/source/wham/src-NEWSC-NEWCORR/xdrf/underscore.m4 new file mode 100644 index 0000000..4d620a0 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/xdrf/underscore.m4 @@ -0,0 +1,19 @@ +divert(-1) +undefine(`len') +# +# append an underscore to FORTRAN function names +# +define(`FUNCTION',`$1_') +# +# FORTRAN character strings are passed as follows: +# a pointer to the base of the string is passed in the normal +# argument list, and the length is passed by value as an extra +# argument, after all of the other arguments. +# +define(`ARGS',`($1`'undivert(1))') +define(`SAVE',`divert(1)$1`'divert(0)') +define(`STRING_ARG',`$1_ptr`'SAVE(`, $1_len')') +define(`STRING_ARG_DECL',`char * $1_ptr; int $1_len') +define(`STRING_LEN',`$1_len') +define(`STRING_PTR',`$1_ptr') +divert(0) diff --git a/source/wham/src-NEWSC-NEWCORR/xdrf/xdrf.h b/source/wham/src-NEWSC-NEWCORR/xdrf/xdrf.h new file mode 100644 index 0000000..dedf5a2 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/xdrf/xdrf.h @@ -0,0 +1,10 @@ +/*_________________________________________________________________ + | + | 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) ; + diff --git a/source/wham/src-NEWSC-NEWCORR/xread.F b/source/wham/src-NEWSC-NEWCORR/xread.F new file mode 100644 index 0000000..ac35de1 --- /dev/null +++ b/source/wham/src-NEWSC-NEWCORR/xread.F @@ -0,0 +1,187 @@ + subroutine xread(nazwa,ii,jj,kk,ll,mm,iR,ib,iparm) + implicit none + include "DIMENSIONS" + include "DIMENSIONS.ZSCOPT" + include "DIMENSIONS.FREE" + integer MaxTraj + parameter (MaxTraj=2050) +#ifdef MPI + include "mpif.h" + integer IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE) + include "COMMON.MPI" +#endif + include "COMMON.CHAIN" + include "COMMON.IOUNITS" + include "COMMON.PROTFILES" + include "COMMON.NAMES" + include "COMMON.VAR" + include "COMMON.GEO" + include "COMMON.ENEPS" + include "COMMON.PROT" + include "COMMON.INTERACT" + include "COMMON.FREE" + include "COMMON.SBRIDGE" + include "COMMON.OBCINKA" + real*4 csingle(3,maxres2) + character*64 nazwa,bprotfile_temp + integer i,j,k,l,ii,jj(maxslice),kk(maxslice),ll(maxslice), + & mm(maxslice) + integer iscor,islice,islice1,slice + double precision energ + integer ilen,iroof + external ilen,iroof + double precision rmsdev,energia(0:max_ene),efree,eini,temp + double precision prop(maxQ) + integer ntot_all(0:maxprocs-1) + integer iparm,ib,iib,ir,nprop,nthr + double precision etot,time,ts(maxslice),te(maxslice) + integer is(maxslice),ie(maxslice),itraj,ntraj,it,iset + integer nstep(0:MaxTraj-1) + logical lerr + + call set_slices(is,ie,ts,te,iR,ib,iparm) + do i=1,nQ + prop(i)=0.0d0 + enddo + do i=0,MaxTraj-1 + nstep(i)=0 + enddo + ntraj=0 + it=0 + islice1=1 + call opentmp(islice1,ientout,bprotfile_temp) + do while (.true.) + if (replica(iparm)) then + if (hamil_rep .or. umbrella(iparm)) then + read (ientin,*,end=1112,err=1112) time,eini, + & etot,temp,nss,(ihpb(j),jhpb(j),j=1,nss), + & nprop,(prop(j),j=1,nprop),iset + else + read (ientin,*,end=1112,err=1112) time,eini, + & etot,temp,nss,(ihpb(j),jhpb(j),j=1,nss), + & nprop,(prop(j),j=1,nprop) + endif + temp=1.0d0/(temp*1.987D-3) +c write (iout,*) time,eini,etot,nss, +c & (ihpb(j),jhpb(j),j=1,nss),(prop(j),j=1,nprop) +c call flush(iout) + do i=1,nT_h(iparm) + if (beta_h(i,iparm).eq.temp) then + iib = i + goto 22 + endif + enddo + 22 continue + if (i.gt.nT_h(iparm)) then + write (iout,*) "Error - temperature of conformation", + & ii,1.0d0/(temp*1.987D-3), + & " does not match any of the list" + write (iout,*) + & 1.0d0/(temp*1.987D-3), + & (1.0d0/(beta_h(i,iparm)*1.987D-3),i=1,nT_h(iparm)) + call flush(iout) + call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) + endif + else + read (ientin,*,end=1112,err=1112) time,eini, + & etot,nss,(ihpb(j),jhpb(j),j=1,nss), + & nprop,(prop(j),j=1,nprop) + iib = ib + endif + itraj=mod(it,totraj(iR,iparm)) +c write (*,*) "ii",ii," itraj",itraj +c call flush(iout) + it=it+1 + if (itraj.gt.ntraj) ntraj=itraj + nstep(itraj)=nstep(itraj)+1 + islice=slice(nstep(itraj),time,is,ie,ts,te) + read (ientin,'(8f10.5)',end=1112,err=1112) + & ((csingle(l,k),l=1,3),k=1,nres), + & ((csingle(l,k+nres),l=1,3),k=nnt,nct) + efree=0.0d0 + if (islice.gt.0 .and. islice.le.nslice) then + ii=ii+1 + kk(islice)=kk(islice)+1 + mm(islice)=mm(islice)+1 + if (mod(nstep(itraj),isampl(iparm)).eq.0) then + jj(islice)=jj(islice)+1 + if (hamil_rep) then + snk(iR,iib,iset,islice)=snk(iR,iib,iset,islice)+1 + else if (umbrella(iparm)) then + snk(iset,iib,iparm,islice)=snk(iset,iib,iparm,islice)+1 + else + snk(iR,iib,iparm,islice)=snk(iR,iib,iparm,islice)+1 + endif + ll(islice)=ll(islice)+1 +c write (iout,*) ii,kk,jj,ll,eini,(prop(j),j=1,nprop) +#ifdef DEBUG +c write (iout,*) "Writing conformation, record",ll(islice) +c write (iout,*) "ib",ib," iib",iib + if (replica(iparm)) then + write (iout,*) "TEMP",1.0d0/(temp*1.987D-3) + write (iout,*) "TEMP list" + write (iout,*) + & (1.0d0/(beta_h(i,iparm)*1.987D-3),i=1,nT_h(iparm)) + endif + call flush(iout) +#endif +c write (iout,*) "iparm",iparm," ib",ib," iR",iR," nQ",nQ +c write (iout,*) "nres",nres," nnt",nnt," nct",nct," nss",nss +c write (iout,*) "length",nres*4+(nct-nnt+1)*4+4+2*nss*4 +c call flush(iout) + if (islice.ne.islice1) then +c write (iout,*) "islice",islice," islice1",islice1 + close(ientout) +c write (iout,*) "Closing file ", +c & bprotfile_temp(:ilen(bprotfile_temp)) + call opentmp(islice,ientout,bprotfile_temp) +c write (iout,*) "Opening file ", +c & bprotfile_temp(:ilen(bprotfile_temp)) +c call flush(iout) + islice1=islice + endif + write(ientout,rec=ll(islice)) + & ((csingle(l,k),l=1,3),k=1,nres), + & ((csingle(l,k+nres),l=1,3),k=nnt,nct), + & nss,(ihpb(k),jhpb(k),k=1,nss), + & eini,efree,rmsdev,(prop(i),i=1,nQ),iR,iib,iparm +#ifdef DEBUG + do i=1,2*nres + do j=1,3 + c(j,i)=csingle(j,i) + enddo + enddo + call int_from_cart1(.false.) + write (iout,*) "Writing conformation, record",ll(islice) + write (iout,*) "Cartesian coordinates" + write (iout,'(8f10.5)') ((c(j,i),j=1,3),i=1,nres) + write (iout,'(8f10.5)') ((c(j,i+nres),j=1,3),i=nnt,nct) + write (iout,*) "Internal coordinates" + write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) + write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) + write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) + write (iout,'(8f10.4)') (rad2deg*phi(k),k=4,nres) + write (iout,'(8f10.4)') (rad2deg*alph(k),k=2,nres-1) + write (iout,'(8f10.4)') (rad2deg*omeg(k),k=2,nres-1) + write (iout,'(16i5)') nss,(ihpb(k),jhpb(k),k=1,nss) +c write (iout,'(8f10.5)') (prop(j),j=1,nQ) + write (iout,'(16i5)') iscor + call flush(iout) +#endif + endif + endif + enddo + 1112 continue + close(ientout) + write (iout,'(i10," trajectories found in file.")') ntraj+1 + write (iout,'(a)') "Numbers of steps in trajectories:" + write (iout,'(8i10)') (nstep(i),i=0,ntraj) + write (iout,*) ii," conformations read from file", + & nazwa(:ilen(nazwa)) + write (iout,*) mm(islice)," conformations read so far, slice", + & islice + write (iout,*) ll(islice)," conformations stored so far, slice", + & islice + call flush(iout) + return + end