# add_subdirectory(source/unres/src_CSA_DiL)
# add_subdirectory(source/wham/src)
# add_subdirectory(source/wham/src-M)
+ add_subdirectory(source/wham/src-M-SAXS-homology)
# add_subdirectory(source/cluster/wham/src)
# add_subdirectory(source/cluster/wham/src-M)
add_subdirectory(source/cluster/wham/src-M-SAXS-homology)
--- /dev/null
+#
+# CMake project file for WHAM multichain version
+#
+
+enable_language (Fortran)
+
+#================================
+# Set source file lists
+#================================
+set(UNRES_WHAM_M_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
+ read_constr_homology.F
+ arcos.f
+ cartder.f
+ cartprint.f
+ chainbuild.F
+ geomout.F
+ gnmr1.f
+ icant.f
+ intcor.f
+ int_from_cart.f
+ refsys.f
+ make_ensemble1.F
+ matmult.f
+ misc.f
+ mygetenv.F
+ parmread.F
+ permut.F
+ seq2chains.f
+ chain_symmetry.F
+ iperm.f
+ pinorm.f
+ printmat.f
+ rescode.f
+ setup_var.f
+ slices.F
+ store_parm.F
+ timing.F
+ wham_calc1.F
+ PMFprocess.F
+ oligomer.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
+ ssMD.F
+)
+
+set(UNRES_WHAM_M_PP_SRC
+ bxread.F
+ chainbuild.F
+ chain_symmetry.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
+ oligomer.F
+ openunits.F
+ parmread.F
+ permut.F
+ PMFprocess.F
+ read_constr_homology.F
+ read_dist_constr.F
+ readpdb.F
+ read_ref_str.F
+ readrtns_compar.F
+ readrtns.F
+ rmscalc.F
+ slices.F
+ ssMD.F
+ store_parm.F
+ timing.F
+ wham_calc1.F
+ wham_multparm.F
+ xread.F
+)
+
+if(UNRES_DFA)
+ set(UNRES_WHAM_M_SRC0 ${UNRES_WHAM_M_SRC0} dfa.F )
+ set(UNRES_WHAM_M_PP_SRC ${UNRES_WHAM_M_PP_SRC} dfa.F )
+endif(UNRES_DFA)
+
+
+#================================================
+# Set comipiler flags for different sourcefiles
+#================================================
+if (Fortran_COMPILER_NAME STREQUAL "ifort")
+ set(FFLAGS0 "-mcmodel=medium -shared-intel -I. -I${CMAKE_CURRENT_SOURCE_DIR}/include_unres" )
+elseif (Fortran_COMPILER_NAME STREQUAL "gfortran")
+ set(FFLAGS0 "-mcmodel=medium -std=legacy -I. -I${CMAKE_CURRENT_SOURCE_DIR}/include_unres" )
+elseif (Fortran_COMPILER_NAME STREQUAL "pgf90")
+ set(FFLAGS0 "-mcmodel=medium -Mlarge_arrays -I. -I${CMAKE_CURRENT_SOURCE_DIR}/include_unres" )
+else ()
+ set(FFLAGS0 "-g -mcmodel=medium -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${MPI_Fortran_INCLUDE_PATH}")
+endif(UNRES_WITH_MPI)
+
+set_property(SOURCE ${UNRES_WHAM_M_SRC0} PROPERTY COMPILE_FLAGS ${FFLAGS0} )
+
+#=========================================
+# Settings for GAB force field
+#=========================================
+if(UNRES_MD_FF STREQUAL "GAB" )
+ # set preprocesor flags
+ set(CPPFLAGS "PROCOR -DSPLITELE -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DSCCORPDB" )
+
+
+#=========================================
+# Settings for E0LL2Y force field
+#=========================================
+elseif(UNRES_MD_FF STREQUAL "E0LL2Y")
+ # set preprocesor flags
+ set(CPPFLAGS "PROCOR -DSPLITELE -DSCCORPDB" )
+elseif(UNRES_MD_FF STREQUAL "4P")
+ set(CPPFLAGS "SPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DSCCORPDB" )
+endif(UNRES_MD_FF STREQUAL "GAB")
+
+#=========================================
+# Additional flags
+#=========================================
+set(CPPFLAGS "${CPPFLAGS} -DUNRES -DISNAN")
+
+if(UNRES_DFA)
+ set(CPPFLAGS "${CPPFLAGS} -DDFA")
+endif(UNRES_DFA)
+
+
+#=========================================
+# 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")
+elseif (Fortran_COMPILER_NAME STREQUAL "pgf90")
+ set(CPPFLAGS "${CPPFLAGS} -DPGI")
+ FILE(COPY ${CMAKE_SOURCE_DIR}/source/lib/isnan_pgi.f DESTINATION ${CMAKE_CURRENT_BINARY_DIR} )
+ list(APPEND UNRES_WHAM_M_SRC0 ${CMAKE_CURRENT_BINARY_DIR}/isnan_pgi.f)
+ set(CMAKE_EXE_LINKER_FLAGS "-Bdynamic")
+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_M_PP_SRC} PROPERTY COMPILE_DEFINITIONS ${CPPFLAGS} )
+
+
+#========================================
+# Setting binary name
+#========================================
+if(UNRES_DFA)
+ set(UNRES_WHAM_M_BIN "wham-mult_${Fortran_COMPILER_NAME}_MPI_${UNRES_MD_FF}_DFA.exe")
+else(UNRES_DFA)
+ set(UNRES_WHAM_M_BIN "wham-mult_${Fortran_COMPILER_NAME}_MPI_${UNRES_MD_FF}.exe")
+endif(UNRES_DFA)
+#=========================================
+# 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 paths
+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_M_SRCS ${UNRES_WHAM_M_SRC0} ${CMAKE_CURRENT_BINARY_DIR}/cinfo.f )
+
+#=========================================
+# Build the binary
+#=========================================
+add_executable(UNRES_WHAM_M_BIN ${UNRES_WHAM_M_SRCS} )
+set_target_properties(UNRES_WHAM_M_BIN PROPERTIES OUTPUT_NAME ${UNRES_WHAM_M_BIN})
+set_property(TARGET UNRES_WHAM_M_BIN PROPERTY RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/bin )
+#add_dependencies (${UNRES_BIN} ${UNRES_XDRFLIB})
+
+#=========================================
+# Link libraries
+#=========================================
+# link MPI library (libmpich.a)
+target_link_libraries( UNRES_WHAM_M_BIN ${MPI_Fortran_LIBRARIES} )
+# link libxdrf.a
+target_link_libraries( UNRES_WHAM_M_BIN xdrf )
+
+
+#=========================================
+# Install Path
+#=========================================
+install(TARGETS UNRES_WHAM_M_BIN DESTINATION ${CMAKE_INSTALL_PREFIX}/wham)
+
+
+#=========================================
+# TESTS
+#=========================================
+
+# MESSAGE (STATUS "${MPI_Fortran_LIBRARIES}")
+ if ("${MPI_Fortran_LIBRARIES}" MATCHES "lam")
+ MESSAGE (STATUS "LAM MPI library detected")
+ set (boot_lam "-boot")
+ else()
+ set (boot_lam "")
+ endif()
+
+ if (UNRES_SRUN)
+ set (np "-n")
+ set (mpiexec "srun")
+ elseif(UNRES_MPIRUN)
+ set (np "-np")
+ set (mpiexec "mpirun")
+ else()
+ set (np "-np")
+ set (mpiexec "mpiexec")
+ endif()
+
+FILE(WRITE ${CMAKE_CURRENT_BINARY_DIR}/scripts/wham_mpi_E0LL2Y.sh
+"#!/bin/sh
+export POT=GB
+export PREFIX=$1
+#-----------------------------------------------------------------------------
+WHAM_BIN=${CMAKE_BINARY_DIR}/bin/${UNRES_WHAM_M_BIN}
+#-----------------------------------------------------------------------------
+DD=${CMAKE_SOURCE_DIR}/PARAM
+export BONDPAR=$DD/bond_AM1_ext_dum.parm
+export THETPAR=$DD/theta_abinitio_old_ext.parm
+export ROTPAR=$DD/rotamers_AM1_aura_ext.10022007.parm
+export TORPAR=$DD/torsion_631Gdp_old_ext.parm
+export TORDPAR=$DD/torsion_double_631Gdp_old_ext.parm
+export ELEPAR=$DD/electr_631Gdp_ext.parm
+export SIDEPAR=$DD/scinter_GB_ext_lip.parm
+export FOURIER=$DD/fourier_opt_ext.parm.1igd_hc_iter3_3
+export SCPPAR=$DD/scp_ext.parm
+export SCCORPAR=$DD/sccor_am1_pawel_ext.dat
+export THETPARPDB=$DD/thetaml_ext.5parm
+export ROTPARPDB=$DD/scgauss_ext.parm
+export PATTERN=$DD/patterns.cart
+export LIPTRANPAR=$DD/Lip_tran_initial_ext.parm
+export CONTFUNC=GB
+export SIDEP=$DD/contact_ext.3.parm
+export SCRATCHDIR=.
+#-----------------------------------------------------------------------------
+echo CTEST_FULL_OUTPUT
+${mpiexec} ${boot_lam} ${np} $2 $WHAM_BIN
+./wham_check.sh $1
+")
+
+#
+# File permissions workaround
+#
+FILE( COPY ${CMAKE_CURRENT_BINARY_DIR}/scripts/wham_mpi_E0LL2Y.sh
+ DESTINATION ${CMAKE_CURRENT_BINARY_DIR}
+ FILE_PERMISSIONS OWNER_READ OWNER_WRITE OWNER_EXECUTE GROUP_READ GROUP_EXECUTE WORLD_READ WORLD_EXECUTE
+)
+
+FILE(COPY ${CMAKE_SOURCE_DIR}/ctest/wham_check.sh
+ DESTINATION ${CMAKE_CURRENT_BINARY_DIR}
+ FILE_PERMISSIONS OWNER_READ OWNER_WRITE OWNER_EXECUTE GROUP_READ GROUP_EXECUTE WORLD_READ WORLD_EXECUTE
+)
+
+FILE(COPY ${CMAKE_SOURCE_DIR}/ctest/1L2Y_wham.inp
+ DESTINATION ${CMAKE_CURRENT_BINARY_DIR} )
+
+FILE(COPY ${CMAKE_SOURCE_DIR}/ctest/1L2Y_remd_MD000.cx
+ DESTINATION ${CMAKE_CURRENT_BINARY_DIR} )
+
+FILE(COPY ${CMAKE_SOURCE_DIR}/ctest/1L2Y.pdb
+ DESTINATION ${CMAKE_CURRENT_BINARY_DIR} )
+
+if(UNRES_DFA)
+FILE(COPY ${CMAKE_SOURCE_DIR}/ctest/dfa
+ DESTINATION ${CMAKE_CURRENT_BINARY_DIR} )
+
+FILE(WRITE ${CMAKE_CURRENT_BINARY_DIR}/scripts/wham_mpi_E0LL2Y_dfa.sh
+"#!/bin/sh
+export POT=GB
+export INPUT=$1
+export INTIN=dfa_wham
+export OUTPUT=dfa_clust
+export PDB=CART
+export COORD=CX
+export PRINTCOOR=PRINT_PDB
+#-----------------------------------------------------------------------------
+WHAM_BIN=${CMAKE_BINARY_DIR}/bin/${WHAM_M_BIN}
+#-----------------------------------------------------------------------------
+DD=${CMAKE_SOURCE_DIR}/PARAM
+export BONDPAR=$DD/bond_AM1_ext_dum.parm
+export THETPAR=$DD/theta_abinitio_old_ext.parm
+export ROTPAR=$DD/rotamers_AM1_aura_ext.10022007.parm
+export TORPAR=$DD/torsion_631Gdp_old_ext.parm
+export TORDPAR=$DD/torsion_double_631Gdp_old_ext.parm
+export ELEPAR=$DD/electr_631Gdp_ext.parm
+export SIDEPAR=$DD/scinter_GB_ext_lip.parm
+export FOURIER=$DD/fourier_opt_ext.parm.1igd_hc_iter3_3
+export SCPPAR=$DD/scp_ext.parm
+export SCCORPAR=$DD/sccor_am1_pawel_ext.dat
+export THETPARPDB=$DD/thetaml_ext.5parm
+export ROTPARPDB=$DD/scgauss_ext.parm
+export PATTERN=$DD/patterns.cart
+export LIPTRANPAR=$DD/Lip_tran_initial_ext.parm
+export CONTFUNC=GB
+export SIDEP=$DD/contact_ext.3.parm
+export SCRATCHDIR=.
+#-----------------------------------------------------------------------------
+echo CTEST_FULL_OUTPUT
+${mpiexec} ${boot_lam} ${np} $2 $WHAM_BIN
+./cluster_wham_check.sh $1
+")
+
+FILE( COPY ${CMAKE_CURRENT_BINARY_DIR}/scripts/wham_mpi_E0LL2Y_dfa.sh
+ DESTINATION ${CMAKE_CURRENT_BINARY_DIR}/dfa
+ FILE_PERMISSIONS OWNER_READ OWNER_WRITE OWNER_EXECUTE GROUP_READ GROUP_EXECUTE WORLD_READ WORLD_EXECUTE
+)
+
+
+endif()
+
+
+
+
+if(UNRES_MD_FF STREQUAL "E0LL2Y")
+ add_test(NAME WHAM_M_remd COMMAND sh ${CMAKE_CURRENT_BINARY_DIR}/wham_mpi_E0LL2Y.sh 1L2Y_wham 2 )
+ if(UNRES_DFA)
+ add_test(NAME WHAM_M_remd_dfa COMMAND sh ${CMAKE_CURRENT_BINARY_DIR}/dfa/wham_mpi_E0LL2Y_dfa.sh dfa_wham 2 WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/dfa )
+ endif()
+endif(UNRES_MD_FF STREQUAL "E0LL2Y")
--- /dev/null
+ 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:ntyp,max_parm),
+ & athet_all(2,-ntyp:ntyp,-1:1,-1:1,max_parm),
+ & bthet_all(2,-ntyp:ntyp,-1:1,-1:1,max_parm),
+ & polthet_all(0:3,-ntyp:ntyp,max_parm),
+ & gthet_all(3,-ntyp:ntyp,max_parm),theta0_all(-ntyp:ntyp,max_parm),
+ & sig0_all(-ntyp:ntyp,max_parm),sigc0_all(-ntyp:ntyp,max_parm),
+ & aa0thet_all(-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,
+ & -maxthetyp1:maxthetyp1,2,max_parm),
+ & aathet_all(maxtheterm,-maxthetyp1:maxthetyp1,
+ & -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2,max_parm),
+ & bbthet_all(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1,
+ & -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2,max_parm),
+ & ccthet_all(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1,
+ &-maxthetyp1:maxthetyp1,
+ & -maxthetyp1:maxthetyp1,2,max_parm),
+ & ddthet_all(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1,
+ & -maxthetyp1:maxthetyp1,
+ & -maxthetyp1:maxthetyp1,2,max_parm),
+ & eethet_all(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1,
+ & -maxthetyp1:maxthetyp1,
+ & -maxthetyp1:maxthetyp1,2,max_parm),
+ & ffthet_all1(maxdouble,maxdouble,maxtheterm3,
+ & -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,
+ & -maxthetyp1:maxthetyp1,max_parm),
+ & ggthet_all1(maxdouble,maxdouble,maxtheterm3,
+ & -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,
+ & -maxthetyp1:maxthetyp1,max_parm),
+ & ffthet_all2(maxdouble,maxdouble,maxtheterm3,
+ & -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,
+ & -maxthetyp1:maxthetyp1,max_parm),
+ & ggthet_all2(maxdouble,maxdouble,maxtheterm3,
+ & -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,
+ & -maxthetyp1:maxthetyp1,max_parm),
+ & dsc_all(ntyp1,max_parm),bsc_all(maxlob,ntyp,max_parm),
+ & censc_all(3,maxlob,-ntyp:ntyp,max_parm),
+ & gaussc_all(3,3,maxlob,-ntyp:ntyp,max_parm),
+ & dsc0_all(ntyp1,max_parm),
+ & sc_parmin_all(65,ntyp,max_parm),
+ & v0_all(-maxtor:maxtor,-maxtor:maxtor,2,max_parm),
+ & v1_all(maxterm,-maxtor:maxtor,-maxtor:maxtor,2,max_parm),
+ & v2_all(maxterm,-maxtor:maxtor,-maxtor:maxtor,2,max_parm),
+ & vlor1_all(maxlor,maxtor,maxtor,max_parm),
+ & vlor2_all(maxlor,maxtor,maxtor,max_parm),
+ & vlor3_all(maxlor,maxtor,maxtor,max_parm),
+ & v1c_all(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,
+ & -maxtor:maxtor,2,max_parm),
+ & v1s_all(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,
+ & -maxtor:maxtor,2,max_parm),
+ & v2c_all(maxtermd_2,maxtermd_2,-maxtor:maxtor,
+ & -maxtor:maxtor,-maxtor:maxtor,2,max_parm),
+ & v2s_all(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor,
+ & -maxtor:maxtor,2,max_parm),
+ & b_all(5,-maxtor:maxtor,max_parm),
+ & ccold_all(2,2,-maxtor:maxtor,max_parm),
+ & ddold_all(2,2,-maxtor:maxtor,max_parm),
+ & eeold_all(2,2,-maxtor:maxtor,max_parm),
+ & bnew1_all(3,2,-maxtor:maxtor,max_parm),
+ & bnew2_all(3,2,-maxtor:maxtor,max_parm),
+ & ccnew_all(3,2,-maxtor:maxtor,max_parm),
+ & ddnew_all(3,2,-maxtor:maxtor,max_parm),
+ & eenew_all(2,2,2,-maxtor:maxtor,max_parm),
+ & e0new_all(2,-maxtor:maxtor,max_parm),
+ & app_all(2,2,max_parm),bpp_all(2,2,max_parm),
+ & ael6_all(2,2,max_parm),ael3_all(2,2,max_parm),
+ & aad_all(ntyp,2,max_parm),bad_all(ntyp,2,max_parm),
+ & aa_aq_all(ntyp,ntyp,max_parm),bb_aq_all(ntyp,ntyp,max_parm),
+ & aa_lip_all(ntyp,ntyp,max_parm),bb_lip_all(ntyp,ntyp,max_parm),
+ & augm_all(ntyp,ntyp,max_parm),eps_all(ntyp,ntyp,max_parm),
+ & epslip_all(ntyp,ntyp,max_parm),
+ & sigma_all(ntyp,ntyp,max_parm),r0_all(ntyp,ntyp,max_parm),
+ & chi_all(ntyp,ntyp,max_parm),chip_all(ntyp,max_parm),
+ & alp_all(ntyp,max_parm),ebr_all(max_parm),d0cm_all(max_parm),
+ & 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,-ntyp:ntyp,max_parm),
+ & v2sccor_all(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp,max_parm)
+ integer nlob_all(ntyp1,max_parm),
+ & nlor_all(-maxtor:maxtor,-maxtor:maxtor,2,max_parm),
+ & nterm_all(-maxtor:maxtor,-maxtor:maxtor,2,max_parm),
+ & ntermd1_all(-maxtor:maxtor,-maxtor:maxtor,
+ & -maxtor:maxtor,2,max_parm),
+ & ntermd2_all(-maxtor:maxtor,-maxtor:maxtor,
+ & -maxtor:maxtor,2,max_parm),
+ & nbondterm_all(ntyp,max_parm),nthetyp_all(max_parm),
+ & ithetyp_all(-ntyp1:ntyp1,max_parm),ntheterm_all(max_parm),
+ & ntheterm2_all(max_parm),ntheterm3_all(max_parm),
+ & nsingle_all(max_parm),ndouble_all(max_parm),
+ & nntheterm_all(max_parm),
+ &nterm_sccor_all(-ntyp:ntyp,-ntyp:ntyp,max_parm)
+ common /allparm/ ww_all,vbldp0_all,akp_all,vbldsc0_all,aksc_all,
+ & abond0_all,aa0thet_all,aathet_all,bbthet_all,ccthet_all,
+ & ddthet_all,eethet_all,ffthet_all1,ggthet_all1,
+ & ffthet_all2,ggthet_all2,
+ & a0thet_all,athet_all,bthet_all,polthet_all,gthet_all,theta0_all,
+ & sig0_all,sigc0_all,dsc_all,bsc_all,censc_all,gaussc_all,dsc0_all,
+ & sc_parmin_all,
+ & v0_all,v1_all,v2_all,vlor1_all,vlor2_all,vlor3_all,v1c_all,
+ & v1s_all,v2c_all,v2s_all,b_all,ccold_all,ddold_all,eeold_all,
+ & bnew1_all,bnew2_all,ccnew_all,ddnew_all,eenew_all,e0new_all,
+ & app_all,bpp_all,ael6_all,
+ & ael3_all,aad_all,bad_all,aa_aq_all,bb_aq_all,augm_all,
+ & aa_lip_all,bb_lip_all,epslip_all,
+ & eps_all,sigma_all,r0_all,chi_all,chip_all,alp_all,ebr_all,
+ & d0cm_all,akcm_all,akth_all,akct_all,v1ss_all,v2ss_all,v3ss_all,
+ & v1sccor_all,v2sccor_all,nbondterm_all,
+ & 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
--- /dev/null
+ integer nres,nres0,nsup,nstart_sup,nend_sup,nstart_seq,
+ & ishift_pdb,chain_length,chain_border,ichanres,tabpermchain,
+ & nchain ,npermchain,ireschain,iz_sc
+ double precision c,cref,crefjlee,dc,xloc,xrot,dc_norm,t,r,prod,rt,
+ & rmssing,anatemp,chomo
+ 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),crefjlee(3,maxres2+2),
+ & rmssing,anatemp,iz_sc,nsup,
+ & nstart_sup,nend_sup,chain_length(maxchain),npermchain,
+ & ireschain(maxres),tabpermchain(maxchain,maxperm),
+ & chain_border(2,maxchain),nchain,nstart_seq,ishift_pdb
+ double precision boxxsize,boxysize,boxzsize,enecut,sscut,sss,
+ & sssgrad,
+ & buflipbot, bufliptop,bordlipbot,bordliptop,lipbufthick,lipthick
+ common /box/ boxxsize,boxysize,boxzsize,enecut,sscut,sss,sssgrad,
+ & buflipbot, bufliptop,bordlipbot,bordliptop,lipbufthick,lipthick
+ common /chomo_models/ chomo(3,maxres2+2,max_template)
--- /dev/null
+ 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
--- /dev/null
+ 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)
--- /dev/null
+ integer iscode,indpdb,outpdb,outmol2,icomparfunc,pdbint,
+ & ensembles,constr_dist,symetr,shield_mode,tor_mode,
+ & homol_nset,constr_homology
+ logical refstr,pdbref,punch_dist,print_rms,caonly,verbose,
+ & merge_helices,bxfile,cxfile,histfile,entfile,zscfile,unres_pdb,
+ & rmsrgymap,with_dihed_constr,check_conf,histout,with_theta_constr,
+ & energy_dec,adaptive,read2sigma,read_homol_frag,
+ & out_template_coord,out_template_restr
+ common /cntrl/ iscode,indpdb,refstr,pdbref,outpdb,outmol2,
+ & punch_dist,print_rms,caonly,verbose,icomparfunc,pdbint,
+ & merge_helices,bxfile,cxfile,histfile,entfile,zscfile,unres_pdb,
+ & rmsrgymap,ensembles,with_dihed_constr,constr_dist,check_conf,
+ & histout,with_theta_constr,
+ & constr_homology,homol_nset,read2sigma,read_homol_frag,
+ & out_template_coord,out_template_restr,
+ & symetr,tor_mode,shield_mode,energy_dec,adaptive
--- /dev/null
+ 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
--- /dev/null
+C =======
+C COMMON.DFA
+C =======
+C 2010/12/20 By Juyong Lee
+C
+c parameter
+C [ 8 * ( Nres - 8 ) ] distance restraints
+C [ 2 * ( Nres - 8 ) ] angle restraints
+C [ Nres ] neighbor restraints
+C Total : ~ 11 * Nres restraints
+C
+C
+ INTEGER IDFAMAX,IDFAMX2,IDFACMD,IDMAXMIN, MAXN
+ PARAMETER(IDFAMAX=4000,IDFAMX2=1000,IDFACMD=500,IDMAXMIN=500)
+ PARAMETER(MAXN=4)
+ real*8 wwdist,wwangle,wwnei
+ parameter(wwdist=1.0d0,wwangle=1.0d0,wwnei=1.0d0)
+
+C IDFAMAX - maximum number of DFA restraint including distance, angle and
+C number of neighbors ( Max of assign statement )
+C IDFAMX2 - maximum number of atoms which are targets of restraints
+C IDFACMD - maximum number of 'DFA' command call
+C IDMAXMIN - Maximum number of minima of dist, angle and neighbor info. from fragments
+C MAXN - Maximum Number of shell, currently 4
+C MAXRES - Maximum number of CAs
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCc
+C INTEGER
+C DFANUM - Number of ALL DFA restrants
+c IDFA[DIS, PHI, THE, NEI] - NUMBER of restraints
+c IDISNUM - number of minima for a distance restraint
+c IPHINUM - number of minima for a phi angle restraint
+c ITHENUM - number of minima for a theta angle restraint
+c INEINUM - number of minima for a number of neighbors restraint
+
+c IDISLIS - atom number of two atoms for distance restraint
+c IPHILIS - atom numbers of four atoms for angle restraint
+c ITHELIS - atom numbers of four atoms for angle restraint
+c INEILIS - atom number of center of neighbor calculation
+c JNEILIS - atom number of target of neighboring calculation
+c JNEINUM - number of target atoms of neighboring term
+C KSHELL - SHELL number
+
+C ishiftca - index shift for CA atoms in UNRES (1 if the 1st aa != GLY)
+C ilastca - index of the last CA atom in UNRES (nres-1 if last aa != GLY)
+
+C old only for CHARMM
+C STOAGDF - Store assign information ( How many assign within one command )
+C NMAP - mapping between dfanum and ndis, nphi, nthe, nnei
+
+ INTEGER IDFADIS,IDFAPHI,IDFATHE,IDFANEI,
+ & IDISLIS,IPHILIS,ITHELIS,INEILIS,
+ & IDISNUM,IPHINUM,ITHENUM,INEINUM,
+ & FNEI,DFACMD, DFANUM,
+ & NCA,ICAIDX,
+ & STOAGDF, NMAP, IDFACAT, KDISNUM, KSHELL
+ & ishiftca,ilastca
+ COMMON /IDFA/ DFACMD, DFANUM,
+ & IDFADIS, IDFAPHI, IDFANEI, IDFATHE,
+ & IDISNUM(IDFAMAX), IPHINUM(IDFAMAX),
+ & ITHENUM(IDFAMAX), INEINUM(IDFAMAX),
+ & FNEI(IDFAMAX,IDMAXMIN), IDISLIS(2,IDFAMAX),
+ & IPHILIS(5,IDFAMAX), ITHELIS(5,IDFAMAX),
+ & INEILIS(IDFAMAX),
+ & KSHELL(IDFAMAX),
+ & IDFACAT(IDFACMD),
+ & KDISNUM(IDFAMAX),
+ & NCA, ICAIDX(MAXRES)
+ COMMON /IDFA2/ ishiftca,ilastca
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C REAL VARIABLES
+C
+c SCC[DIST, PHI, THE] - weight of each calculations
+c FDIST - distance minima
+C FPHI - phi minima
+c FTHE - theta minima
+C DFAEXP : calculate expential function in advance
+C
+ REAL*8 SCCDIST, SCCPHI, SCCTHE, SCCNEI, FDIST, FPHI1, FPHI2,
+ & FTHE1, FTHE2,
+ & DIS_INC, PHI_INC, THE_INC, NEI_INC, BETA_INC,
+ & WSHET, EDFABET,
+ & CK, SCK, S1, S2
+c & ,DFAEXP
+
+ COMMON /RDFA/ SCCDIST(IDFAMAX,IDMAXMIN),FDIST(IDFAMAX,IDMAXMIN),
+ & SCCPHI(IDFAMAX,IDMAXMIN), SCCTHE(IDFAMAX,IDMAXMIN),
+ & SCCNEI(IDFAMAX,IDMAXMIN),
+ & FPHI1(IDFAMAX,IDMAXMIN), FPHI2(IDFAMAX,IDMAXMIN),
+ & FTHE1(IDFAMAX,IDMAXMIN), FTHE2(IDFAMAX,IDMAXMIN),
+ & DIS_INC, PHI_INC, THE_INC, NEI_INC, BETA_INC,
+ & WSHET(MAXRES,MAXRES), EDFABET,
+ & CK(4),SCK(4),S1(4),S2(4)
+c & ,DFAEXP(15001),
+
+ DATA CK/1.0D0,1.58740105197D0,2.08008382305D0,2.51984209979D0/
+ DATA SCK/1.0D0,1.25992104989D0,1.44224957031D0,1.58740105197D0/
+ DATA S1/3.75D0,5.75D0,7.75D0,9.75D0/
+ DATA S2/4.25D0,6.25D0,8.25D0,10.25D0/
--- /dev/null
+ double precision eneps_temp(2,nntyp)
+ integer n_ene
+ common /weightder/ eneps_temp,n_ene
--- /dev/null
+ 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
--- /dev/null
+ 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),tole,delta,deltrms,deltrgy,fimin,
+ & f(maxR,maxT_h,max_parm),beta_h(MaxT_h,max_parm)
+ 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)
+ logical replica(max_parm),umbrella(max_parm),read_iset(max_parm)
+ common /wham/ Kh,q0,f,beta_h,delta,tole,deltrms,deltrgy,fimin,
+ & snk,nR,
+ & nRR,nT_h,nQ,stot,nparmset,maxit,rescale_mode,replica,umbrella,
+ & read_iset,totraj,hamil_rep,separate_parset,iparmprint,myparm
--- /dev/null
+ logical l_homo
+ integer iset,ihset
+ real*8 waga_homology
+ real*8 waga_dist, waga_angle, waga_theta, waga_d, dist_cut,
+ & dist2_cut
+ common /homol/ waga_homology(maxR),
+ & waga_dist,waga_angle,waga_theta,waga_d,dist_cut,dist2_cut,
+ & iset,ihset,l_homo(max_template,maxdim)
--- /dev/null
+ real*8 odl(max_template,maxdim),sigma_odl(max_template,maxdim),
+ & dih(max_template,maxres),sigma_dih(max_template,maxres),
+ & sigma_odlir(max_template,maxdim)
+c
+c Specification of new variables used in subroutine e_modeller
+c modified by FP (Nov.,2014)
+ real*8 xxtpl(max_template,maxres),yytpl(max_template,maxres),
+ & zztpl(max_template,maxres),thetatpl(max_template,maxres),
+ & sigma_theta(max_template,maxres),
+ & sigma_d(max_template,maxres)
+c
+
+ integer ires_homo(maxdim),jres_homo(maxdim)
+
+ double precision
+ & Ucdfrag,Ucdpair,dUdconst(3,0:MAXRES),Uconst,
+ & dUdxconst(3,0:MAXRES),dqwol(3,0:MAXRES),dxqwol(3,0:MAXRES),
+ & dutheta(maxres),dugamma(maxres),
+ & duscdiff(3,maxres),
+ & duscdiffx(3,maxres),
+ & uconst_back
+ integer lim_odl,lim_dih,link_start_homo,link_end_homo,
+ & idihconstr_start_homo,idihconstr_end_homo
+c
+c FP (30/10/2014)
+c
+c integer ithetaconstr_start_homo,ithetaconstr_end_homo
+c
+ integer nresn,nyosh,nnos
+ common /back_constr/ uconst_back,
+ & dutheta,dugamma,duscdiff,duscdiffx
+ common /homrestr/ odl,dih,sigma_dih,sigma_odl,
+ & lim_odl,lim_dih,ires_homo,jres_homo,link_start_homo,
+ & link_end_homo,idihconstr_start_homo,idihconstr_end_homo,
+c
+c FP (30/10/2014,04/03/2015)
+c
+ & xxtpl,yytpl,zztpl,thetatpl,sigma_theta,sigma_d,sigma_odlir
+c
--- /dev/null
+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,
+ & iliptranpar
+ common /iounits/ inp,iout,igeom,intin,ipdb,imol2,ipdbin,ithep,
+ & irotam,itorp,itordp,ifourier,ielep,isidep,iscpp,isccor,
+ & icbase,istat,ientin,ientout,isidep1,ibond,ihist,izsc,
+ & idistr,iliptranpar
+ 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,
+ & liptranname
+ common /parfiles/ thetname,rotname,torname,tordname,bondname,
+ & fouriername,elename,sidename,scpname,sccorname,patname,
+ & liptranname
+ 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-----------------------------------------------------------------------
--- /dev/null
+ double precision scal_fric,rwat,etawat,gamp,
+ & gamsc(ntyp1),stdfp,stdfsc(ntyp),stdforcp(MAXRES),
+ & stdforcsc(MAXRES),pstok,restok(ntyp+1),cPoise,Rb
+ common /langevin/ pstok,restok,gamp,gamsc,
+ & stdfp,stdfsc,stdforcp,stdforcsc,rwat,etawat,cPoise,Rb
+ double precision IP,ISC(ntyp+1),mp,
+ & msc(ntyp+1)
+ common /inertia/ IP,ISC,MP,MSC
--- /dev/null
+ 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)
--- /dev/null
+ 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
--- /dev/null
+ 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)
--- /dev/null
+ double precision PMFtab(0:maxHdim,maxT_h,maxR,max_parm),delta_q
+ integer tmin(0:maxT_h,maxR,max_parm),tmax(maxT_h,maxR,max_parm)
+ common /PMF/ PMFtab,delta_q,tmin,tmax
--- /dev/null
+ integer ntot(maxslice),isampl(max_parm),nslice
+ common /protein/ ntot,isampl,nslice
--- /dev/null
+ 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
--- /dev/null
+! SAXS restraint parameters
+ integer nsaxs,saxs_mode
+ double precision Psaxs(maxsaxs),distsaxs(maxsaxs),
+ & CSAXS(3,maxsaxs),scal_rad,wsaxs0,saxs_cutoff
+ common /saxsretr/ Psaxs,distsaxs,csaxs,Wsaxs0,scal_rad,
+ & saxs_cutoff,nsaxs,saxs_mode
+
--- /dev/null
+ double precision VSolvSphere,VSolvSphere_div,long_r_sidechain,
+ & short_r_sidechain,fac_shield,grad_shield_side,grad_shield,
+ & buff_shield,wshield,grad_shield_loc
+ integer ishield_list,shield_list,ees0plist
+ common /shield/ VSolvSphere,VSolvSphere_div,buff_shield,
+ & long_r_sidechain(ntyp),
+ & short_r_sidechain(ntyp),fac_shield(maxres),wshield,
+ & grad_shield_side(3,maxcont,-1:maxres),grad_shield(3,-1:maxres),
+ & grad_shield_loc(3,maxcont,-1:maxres),
+ & ishield_list(maxres),shield_list(maxcont,maxres),
+ & ees0plist(maxcont,maxres)
+
+
+
--- /dev/null
+ double precision r_cut,rlamb
+ common /splitele/ r_cut,rlamb
--- /dev/null
+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,tauangle,omicron,
+ & xxtab,yytab,zztab,
+ & thetaref,phiref,xxref,yyref,zzref
+ common /var/ theta(maxres),phi(maxres),alph(maxres),omeg(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,
+ & omicron(2,maxres),tauangle(3,maxres)
+C Angles from experimental structure
+ common /varref/ vbld_ref(maxres),
+ & theta_ref(maxres),phi_ref(maxres),
+ & alph_ref(maxres),omeg_ref(maxres)
--- /dev/null
+********************************************************************************
+* 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=1200)
+c parameter (maxres=3300)
+C Appr. max. number of interaction sites
+ integer maxres2
+ parameter (maxres2=2*maxres)
+c Max. number of chains
+ integer maxchain
+ parameter (maxchain=6)
+C Max number of symetries
+ integer maxsym,maxperm
+ parameter (maxsym=maxchain,maxperm=720)
+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 parameter (maxdim=10000)
+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=24,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,maxtor_kcc,
+ & maxval_kcc
+ parameter (maxtor=4,maxterm=10,maxlor=3,maxtermd_1=8,maxtermd_2=8)
+ parameter (maxtor_kcc=6,maxval_kcc=6)
+c Max number of new valence-angle (only) terms
+ integer maxang_kcc
+ parameter (maxang_kcc=36)
+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)
+C Maximum number of bins in SAXS restraints
+ integer MaxSAXS
+ parameter (MaxSAXS=1000)
+C Maximum number of templates in homology-modeling restraints
+ integer max_template
+ parameter(max_template=50)
+c Maximum number of clusters of templates containing same fragments
+ integer maxclust
+ parameter(maxclust=1000)
--- /dev/null
+******************************************************************
+*
+* 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)
+*
+*******************************************************************
--- /dev/null
+ integer Max_Parm
+ integer MaxQ,MaxQ1
+ integer MaxR,MaxT_h,maxHdim
+ integer MaxSlice
+ parameter (Max_Parm=5)
+ parameter (MaxQ=4,MaxQ1=MaxQ+2)
+ parameter(MaxR=8,MaxT_h=36)
+ parameter(MaxSlice=40)
+ parameter(maxHdim=200)
+ integer MaxN
+ parameter (MaxN=100)
+ integer MaxPrintConf
+ parameter (MaxPrintConf=1000)
--- /dev/null
+ 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)
--- /dev/null
+ 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=31,maxprot=7,maxclass=10)
+ 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 = 128)
+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)
--- /dev/null
+Makefile_MPICH_ifort-okeanos
\ No newline at end of file
--- /dev/null
+#
+FC= ftn
+OPT = -O3 -hfp3
+
+FFLAGS = -c ${OPT} -I. -Iinclude_unres
+FFLAGS1 = -c -g -Rb
+FFLAGS2 = -c -g -O0
+FFLAGSE = ${FFLAGS}
+
+BIN = ~/bin
+LIBS = 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 \
+ permut.o \
+ pinorm.o \
+ printmat.o \
+ rescode.o \
+ setup_var.o \
+ slices.o \
+ store_parm.o \
+ timing.o \
+ wham_calc1.o \
+ ssMD.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
+
+all: no_option
+ @echo "Specify force field: GAB, 4P or E0LL2Y"
+
+no_option:
+
+GAB: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 \
+ -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DWHAM
+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_MPI-GAB.exe
+
+4P: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPGI -DISNAN -DAMD64 \
+ -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DWHAM
+4P: ${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_MPI-4P.exe
+
+E0LL2Y: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 -DWHAM
+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_MPI-E0LL2Y.exe
+
+NEWCORR: CPPFLAGS = -DMPI -DCRAY -DUNRES -DSPLITELE -DPROCOR -DNEWCORR -DPGI -DISNAN -DAMD64 -DWHAM
+NEWCORR: ${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_MPI-NEWCORR.exe
+
+xdrf/libxdrf.a:
+ cd xdrf && make
+
+
+clean:
+ /bin/rm -f *.o && /bin/rm -f compinfo && cd xdrf && make clean
+
--- /dev/null
+INSTALL_DIR = /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh
+BIN = ../../../bin/wham
+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
+
+.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 \
+ permut.o \
+ pinorm.o \
+ printmat.o \
+ proc_proc.o \
+ rescode.o \
+ setup_var.o \
+ slices.o \
+ store_parm.o \
+ timing.o \
+ wham_calc1.o \
+ ssMD.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
+
+all: no_option
+ @echo "Specify force field: GAB, 4P or E0LL2Y"
+
+no_option:
+
+GAB: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 \
+ -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DWHAM
+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_GAB.exe
+
+4P: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPGI -DISNAN -DAMD64 \
+ -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DWHAM
+4P: ${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_4P.exe
+
+E0LL2Y: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 -DWHAM
+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_E0LL2Y.exe
+
+NEWCORR: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DNEWCORR -DPGI -DISNAN -DAMD64 -DWHAM
+NEWCORR: ${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_NEWCORR.exe
+
+xdrf/libxdrf.a:
+ cd xdrf && make
+
+
+clean:
+ /bin/rm -f *.o && /bin/rm -f compinfo && cd xdrf && make clean
+
--- /dev/null
+BIN = ~/bin
+FC = ftn
+OPT = -mcmodel=medium -shared-intel -O3 -dynamic
+#OPT = -O3 -intel-static -mcmodel=medium
+#OPT = -O3 -ip -w
+#OPT = -g -CB -mcmodel=medium -shared-intel -dynamic
+FFLAGS = ${OPT} -c -I. -I./include_unres -I$(INSTALL_DIR)/include
+LIBS = -L$(INSTALL_DIR)/lib -lmpich 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 \
+ read_constr_homology.o \
+ arcos.o \
+ cartder.o \
+ cartprint.o \
+ chainbuild.o \
+ geomout.o \
+ icant.o \
+ intcor.o \
+ int_from_cart.o \
+ refsys.o \
+ make_ensemble1.o \
+ matmult.o \
+ misc.o \
+ mygetenv.o \
+ parmread.o \
+ permut.o \
+ seq2chains.o \
+ chain_symmetry.o \
+ iperm.o \
+ pinorm.o \
+ printmat.o \
+ proc_proc.o \
+ rescode.o \
+ setup_var.o \
+ slices.o \
+ store_parm.o \
+ timing.o \
+ wham_calc1.o \
+ PMFprocess.o \
+ ssMD.o \
+ oligomer.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
+
+all: no_option
+ @echo "Specify force field: GAB, 4P or E0LL2Y"
+
+no_option:
+
+GAB: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 \
+ -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DWHAM
+GAB: ${objects} ${objects_compar} xdrf/libxdrf.a
+ gcc -o compinfo compinfo.c
+ ./compinfo
+ ${FC} -c ${FFLAGS} cinfo.f
+ $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \
+ ${LIBS} -o ${BIN}/wham_ifort_KCC_MPICH-okeanos_GAB-SAXS-homology.exe
+
+GAB_DFA: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 \
+ -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DWHAM -DDFA
+GAB_DFA: ${objects} ${objects_compar} dfa.o xdrf/libxdrf.a
+ gcc -o compinfo compinfo.c
+ ./compinfo
+ ${FC} -c ${FFLAGS} cinfo.f
+ $(FC) ${OPT} ${objects} ${objects_compar} dfa.o cinfo.o \
+ ${LIBS} -o ${BIN}/wham_ifort_KCC_MPICH-okeanos_GAB-SAXS-homology-DFA.exe
+
+4P: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPGI -DISNAN -DAMD64 \
+ -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DWHAM
+4P: ${objects} ${objects_compar} xdrf/libxdrf.a
+ gcc -o compinfo compinfo.c
+ ./compinfo
+ ${FC} -c ${FFLAGS} cinfo.f
+ $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \
+ ${LIBS} -o ${BIN}/wham_ifort_KCC_MPICH-okeanos_4P-SAXS-homology.exe
+
+4P_DFA: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPGI -DISNAN -DAMD64 \
+ -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DWHAM -DDFA
+4P_DFA: ${objects} ${objects_compar} dfa.o xdrf/libxdrf.a
+ gcc -o compinfo compinfo.c
+ ./compinfo
+ ${FC} -c ${FFLAGS} cinfo.f
+ $(FC) ${OPT} ${objects} ${objects_compar} dfa.o cinfo.o \
+ ${LIBS} -o ${BIN}/wham_ifort_KCC_MPICH-okeanos_4P-SAXS-homology-DFA.exe
+
+E0LL2Y: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 -DWHAM
+E0LL2Y: ${objects} ${objects_compar} xdrf/libxdrf.a
+ gcc -o compinfo compinfo.c
+ ./compinfo
+ ${FC} -c ${FFLAGS} cinfo.f
+ $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \
+ ${LIBS} -o ${BIN}/wham_ifort_KCC_MPICH-okeanos_E0LL2Y-SAXS-homology.exe
+
+E0LL2Y_DFA: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 -DWHAM -DDFA
+E0LL2Y_DFA: ${objects} ${objects_compar} dfa.o xdrf/libxdrf.a
+ gcc -o compinfo compinfo.c
+ ./compinfo
+ ${FC} -c ${FFLAGS} cinfo.f
+ $(FC) ${OPT} ${objects} ${objects_compar} dfa.o cinfo.o \
+ ${LIBS} -o ${BIN}/wham_ifort_KCC_MPICH-okeanos_E0LL2Y-SAXS-homology-DFA.exe
+
+NEWCORR: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DNEWCORR -DCORRCD -DPGI -DISNAN -DAMD64 -DWHAM
+NEWCORR: ${objects} ${objects_compar} xdrf/libxdrf.a
+ gcc -o compinfo compinfo.c
+ ./compinfo
+ ${FC} -c ${FFLAGS} cinfo.f
+ $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \
+ ${LIBS} -o ${BIN}/wham_ifort_KCC_MPICH-okeanos_NEWCORR-SAXS-homology.exe
+
+NEWCORR_DFA: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DNEWCORR -DCORRCD -DDFA -DPGI -DISNAN -DAMD64 -DWHAM -DDFA
+NEWCORR_DFA: ${objects} ${objects_compar} dfa.o xdrf/libxdrf.a
+ gcc -o compinfo compinfo.c
+ ./compinfo
+ ${FC} -c ${FFLAGS} cinfo.f
+ $(FC) ${OPT} ${objects} ${objects_compar} dfa.o cinfo.o \
+ ${LIBS} -o ${BIN}/wham_ifort_KCC_MPICH-okeanos_NEWCORR-SAXS-homology-DFA.exe
+
+xdrf/libxdrf.a:
+ cd xdrf && make
+
+
+clean:
+ /bin/rm -f *.o && /bin/rm -f compinfo && cd xdrf && make clean
+
--- /dev/null
+BIN = ~/unres/bin
+
+FC = mpif90 -fc=ifort
+
+OPT = -O3 -ip -mcmodel=medium -shared-intel
+#OPT = -O3
+OPT = -g -CA -CB -mcmodel=medium -shared-intel
+
+FFLAGS = -c ${OPT} -Iinclude_unres
+FFLAGS1 = -c -g -CA -CB -mcmodel=medium -shared-intel
+#FFLAGS = ${FFLAGS1}
+FFLAGS2 = -c -g -O0 -mcmodel=medium -shared-intel
+FFLAGSE = -c -O3 -ipo -mcmodel=medium -shared-intel
+#FFLAGSE = ${FFLAGS}
+
+
+#LIBS = -L$(INSTALL_DIR)/lib -lmpi xdrf/libxdrf.a
+LIBS = -lmpi xdrf/libxdrf.a
+#/opt/cray/mpt/7.3.2/gni/mpich-intel/15.0/lib/libmpich.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 \
+ permut.o \
+ pinorm.o \
+ printmat.o \
+ proc_proc.o \
+ rescode.o \
+ setup_var.o \
+ slices.o \
+ store_parm.o \
+ timing.o \
+ wham_calc1.o \
+ PMFprocess.o \
+ ssMD.o \
+ oligomer.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
+
+all: no_option
+ @echo "Specify force field: GAB, 4P or E0LL2Y"
+
+no_option:
+
+GAB: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 \
+ -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DWHAM
+GAB: ${objects} ${objects_compar} xdrf/libxdrf.a
+ gcc -o compinfo compinfo.c
+ ./compinfo
+ ${FC} -c ${FFLAGS} cinfo.f
+ $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \
+ ${LIBS} -o ${BIN}/wham_ifort_KCC_MPICH-okeanos_GAB-SAXS.exe
+
+4P: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPGI -DISNAN -DAMD64 \
+ -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DWHAM
+4P: ${objects} ${objects_compar} xdrf/libxdrf.a
+ gcc -o compinfo compinfo.c
+ ./compinfo
+ ${FC} -c ${FFLAGS} cinfo.f
+ $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \
+ ${LIBS} -o ${BIN}/wham_ifort_KCC_MPICH-okeanos_4P-SAXS.exe
+
+E0LL2Y: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 -DWHAM
+E0LL2Y: ${objects} ${objects_compar} xdrf/libxdrf.a
+ gcc -o compinfo compinfo.c
+ ./compinfo
+ ${FC} -c ${FFLAGS} cinfo.f
+ $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \
+ ${LIBS} -o ${BIN}/wham_ifort_KCC_MPICH-okeanos_E0LL2Y-SAXS.exe
+
+NEWCORR: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DNEWCORR -DCORRCD -DPGI -DISNAN -DAMD64 -DWHAM
+NEWCORR: ${objects} ${objects_compar} xdrf/libxdrf.a
+ gcc -o compinfo compinfo.c
+ ./compinfo
+ ${FC} -c ${FFLAGS} cinfo.f
+ $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \
+ ${LIBS} -o ${BIN}/wham_ifort_KCC_MPICH-okeanos_NEWCORR-SAXS-NMRAMB.exe
+
+xdrf/libxdrf.a:
+ cd xdrf && make
+
+
+clean:
+ /bin/rm -f *.o && /bin/rm -f compinfo && cd xdrf && make clean
+
--- /dev/null
+INSTALL_DIR = /users/software/mpich-1.2.7p1_pgi_9.0_64bit_ssh
+CC = cc
+FC = pgf90
+#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
+
+.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
+
+all: no_option
+ @echo "Specify force field: GAB, 4P or E0LL2Y"
+
+no_option:
+
+GAB: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 \
+ -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DWHAM
+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-mult_pgf90_MPICH_GAB.exe
+
+4P: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPGI -DISNAN -DAMD64 \
+ -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DWHAM
+4P: ${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-mult_pgf90_MPICH_4P.exe
+
+E0LL2Y: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DPGI -DISNAN -DAMD64 -DWHAM
+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-mult_pgf90_MPICH_E0LL2Y.exe
+
+xdrf/libxdrf.a:
+ cd xdrf && make
+
+
+clean:
+ /bin/rm -f *.o && /bin/rm -f compinfo && cd xdrf && make clean
+
--- /dev/null
+ subroutine PMFread(*)
+c Read the PMFs from wham
+ implicit none
+ include 'DIMENSIONS'
+ include 'DIMENSIONS.FREE'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.FREE'
+ include 'COMMON.PMF'
+ integer i,iumb,iiset,j,t,nbin,iparm,nRmax
+ double precision beta_h_temp,qtemp,htemp
+ read(inp,*,err=10,end=10) delta_q
+ write(iout,*) "delta_q",delta_q
+
+ do iparm = 1, nparmset
+
+ write(iout,*) "PMFread: iparm",iparm," nT",nT_h(iparm),
+ & " nR",nR(:nT_h(iparm),iparm)
+c print *,(beta_h(i),i=1,nT(iparm))
+ do j=1,nT_h(iparm)
+ do iumb=1,nR(j,iparm)
+ read (inp,*,end=10,err=10) iiset,beta_h_temp,nbin
+ write (iout,*) iiset,beta_h_temp,nbin
+ if (iiset.ne.iumb) then
+ write(iout,*) "Error: inconsistency in US windows",
+ & iiset,iumb
+ return1
+ endif
+ beta_h_temp=1.0d0/(0.001987*beta_h_temp)
+ if (dabs(beta_h_temp-beta_h(j,iparm)).gt.1.0d-6) then
+ write (iout,*)
+ & "Error replica temperatures do not match PMF temperatures"
+ write (iout,*) 1.0d0/(0.001987*beta_h_temp),
+ & 1.0d0/(0.001987*beta_h(j,iparm))
+ stop
+ endif
+ do i=1,nbin
+ read (inp,*,end=10,err=10) qtemp,htemp
+ t = int(qtemp/delta_q+1.0d-4)
+ write (iout,*) qtemp,t,htemp
+ if (i.eq.1) tmin(j,iumb,iparm)=t
+ if (i.eq.nbin) tmax(j,iumb,iparm)=t
+ PMFtab(t,j,iumb,iparm)=dlog(htemp)/beta_h_temp
+ enddo ! i
+ enddo ! iumb
+ enddo ! j
+
+ nRmax=nR(1,iparm)
+ do i=2,nT_h(iparm)
+ if (nR(i,iparm).gt.nRmax) nRmax=nR(i,iparm)
+ enddo
+ do iumb=1,nR(j,iparm)
+ write (iout,*)"Input PMFs, restraint",iumb,
+ & " q0",q0(1,iumb,:nT_h(iparm),iparm)
+ write (iout,'(5x,20f10.1)') (1.0d0/(0.001987*beta_h(j,iparm)),
+ & j=1,nT_h(iparm))
+ do i=0,int(1.0/delta_q)
+ write (iout,'(f5.2,$)') i*delta_q
+ do j=1,nT_h(iparm)
+ if (i.lt.tmin(j,iumb,iparm).or.i.gt.tmax(j,iumb,iparm)) then
+ write (iout,'(" ------",$)')
+ else
+ write (iout,'(f10.3$)') PMFtab(i,j,iumb,iparm)
+ endif
+ enddo
+ write (iout,*)
+ enddo ! i
+ enddo ! iumb
+
+ enddo ! iparm
+ return
+ 10 return1
+ end
+c------------------------------------------------------------------------
+ subroutine PMF_energy(q,irep,iset,iparm,ePMF,ePMF_q)
+c Calculate the energy and derivative in q due to the biasing PMF
+c Caution! Only ONE q is handled, no multi-D q-restraints available!
+ implicit none
+ include 'DIMENSIONS'
+ include 'DIMENSIONS.FREE'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.FREE'
+ include 'COMMON.PMF'
+ integer i,iqmin,iqmax,irep,iset,iparm
+ double precision q,qmin,qmax,ePMF,ePMF_q
+c Determine the location of the q
+ iqmin=tmin(irep,iset,iparm)
+ iqmax=tmax(irep,iset,iparm)
+ qmin=iqmin*delta_q
+ qmax=iqmax*delta_q
+#ifdef DEBUG
+ write (iout,*) "PMF_energy q",q," qmin",qmin," qmax",qmax,
+ & " irep",irep," iset",iset
+#endif
+ if (q.le.qmin) then
+ ePMF_q=(PMFtab(iqmin+1,irep,iset,iparm)-
+ & PMFtab(iqmin,irep,iset,iparm))/delta_q
+ ePMF=PMFtab(iqmin,irep,iset,iparm)+ePMF_q*(q-qmin)
+#ifdef DEBUG
+ write (iout,*) "q<=qmin ePMF",ePMF," ePMF_q",ePMF_q
+#endif
+ else if (q.ge.qmax) then
+ ePMF_q=(PMFtab(iqmax,irep,iset,iparm)-
+ & PMFtab(iqmax-1,irep,iset,iparm))/delta_q
+ ePMF=PMFtab(iqmax,irep,iset,iparm)+ePMF_q*(q-qmax)
+#ifdef DEBUG
+ write (iout,*) "q>=qmax ePMF",ePMF," ePMF_q",ePMF_q
+#endif
+ else
+ do i=iqmin+1,iqmax
+ qmax=i*delta_q
+ if (q.ge.qmin .and. q.le.qmax) then
+ ePMF_q=(PMFtab(i,irep,iset,iparm)-
+ & PMFtab(i-1,irep,iset,iparm))/delta_q
+ ePMF=PMFtab(i-1,irep,iset,iparm)+ePMF_q*(q-qmin)
+#ifdef DEBUG
+ write (iout,*) "qmin<q<qmax bin",i," ePMF",ePMF," ePMF_q",ePMF_q
+#endif
+ exit
+ endif
+ qmin=qmax
+ enddo
+ endif
+ return
+ end
--- /dev/null
+ 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,
+ & ipermmin,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) then
+ write (iout,'(80(1h*))')
+ write (iout,*) "angnorm"
+ write (iout,'(80(1h*))')
+ endif
+ 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) then
+ write (iout,*) "i=",i," nbeg",nbeg," nend",nend,
+ & " nn",nn," ishift1",ishif1," ishift2",ishif2
+ write (iout,*) "angles"
+ call flush(iout)
+ endif
+ 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(iperm(j,ipermmin)),
+ & theta(iperm(j-1,ipermmin)),theta(iperm(j,ipermmin)))
+ 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,ipermmin)
+ 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
+ integer iperm,ipermmin
+ 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(iperm(j,ipermmin)),
+ & theta(iperm(j-1,ipermmin)),theta(iperm(j,ipermmin)))
+ 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,ipermmin,
+ & 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
+ integer iperm,ipermmin
+ 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(iperm(ia2,ipemmin)),
+ & theta(iperm(ia2-1,ipermmin)),theta(iperm(ia2-1,ipermmin)))
+ 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,ipermmin)
+ 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
+ integer ipermm,ipermmin
+ 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(iperm(j,ipermmin)),theta(iperm(j-1,ipermmin)),
+ & theta(iperm(j,ipermmin)))
+ 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
--- /dev/null
+ 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
--- /dev/null
+ 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
--- /dev/null
+ 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(iabs(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
+
--- /dev/null
+ 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
--- /dev/null
+ subroutine chain_symmetry(nchain,nres,itype,chain_border,
+ & chain_length,npermchain,tabpermchain)
+c
+c Determine chain symmetry. nperm is the number of permutations and
+c tabperchain contains the allowed permutations of the chains.
+c
+ implicit none
+ include "DIMENSIONS"
+ include "COMMON.IOUNITS"
+ integer nchain,nres,itype(nres),chain_border(2,maxchain),
+ & chain_length(nchain),itemp(maxchain),
+ & npermchain,tabpermchain(maxchain,maxperm),
+ & tabperm(maxchain,maxperm),mapchain(maxchain),
+ & iequiv(maxchain,maxres),iflag(maxres)
+ integer i,j,k,l,ii,nchain_group,nequiv(maxchain),iieq,
+ & nperm,npermc,ind
+ if (nchain.eq.1) then
+ npermchain=1
+ tabpermchain(1,1)=1
+c print*,"npermchain",npermchain," tabpermchain",tabpermchain(1,1)
+ return
+ endif
+c
+c Look for equivalent chains
+c
+#ifdef DEBUG
+ write(iout,*) "nchain",nchain
+ do i=1,nchain
+ write(iout,*) "chain",i," from",chain_border(1,i),
+ & " to",chain_border(2,i)
+ write(iout,*)
+ & "sequence ",(itype(j),j=chain_border(1,i),chain_border(2,i))
+ enddo
+#endif
+ do i=1,nchain
+ iflag(i)=0
+ enddo
+ nchain_group=0
+ do i=1,nchain
+ if (iflag(i).gt.0) cycle
+ iflag(i)=1
+ nchain_group=nchain_group+1
+ iieq=1
+ iequiv(iieq,nchain_group)=i
+ do j=i+1,nchain
+ if (iflag(j).gt.0.or.chain_length(i).ne.chain_length(j)) cycle
+c k=0
+c do while(k.lt.chain_length(i) .and.
+c & itype(chain_border(1,i)+k).eq.itype(chain_border(1,j)+k))
+ do k=0,chain_length(i)-1
+c k=k+1
+ if (itype(chain_border(1,i)+k).ne.
+ & itype(chain_border(1,j)+k)) exit
+ enddo
+ if (k.lt.chain_length(i)) cycle
+ iflag(j)=1
+ iieq=iieq+1
+ iequiv(iieq,nchain_group)=j
+ enddo
+ nequiv(nchain_group)=iieq
+ enddo
+ write(iout,*) "Number of equivalent chain groups:",nchain_group
+ write(iout,*) "Equivalent chain groups"
+ do i=1,nchain_group
+ write(iout,*) "group",i," #members",nequiv(i)," chains",
+ & (iequiv(j,i),j=1,nequiv(i))
+ enddo
+ ind=0
+ do i=1,nchain_group
+ do j=1,nequiv(i)
+ ind=ind+1
+ mapchain(ind)=iequiv(j,i)
+ enddo
+ enddo
+ write (iout,*) "mapchain"
+ do i=1,nchain
+ write (iout,*) i,mapchain(i)
+ enddo
+ ii=0
+ do i=1,nchain_group
+ call permut(nequiv(i),nperm,tabperm)
+ if (ii.eq.0) then
+ ii=nequiv(i)
+ npermchain=nperm
+ do j=1,nperm
+ do k=1,ii
+ tabpermchain(k,j)=iequiv(tabperm(k,j),i)
+ enddo
+ enddo
+ else
+ npermc=npermchain
+ npermchain=npermchain*nperm
+ ind=0
+ do k=1,nperm
+ do j=1,npermc
+ ind=ind+1
+ do l=1,ii
+ tabpermchain(l,ind)=tabpermchain(l,j)
+ enddo
+ do l=1,nequiv(i)
+ tabpermchain(ii+l,ind)=iequiv(tabperm(l,k),i)
+ enddo
+ enddo
+ enddo
+ ii=ii+nequiv(i)
+ endif
+ enddo
+ do i=1,npermchain
+ do j=1,nchain
+ itemp(mapchain(j))=tabpermchain(j,i)
+ enddo
+ do j=1,nchain
+ tabpermchain(j,i)=itemp(j)
+ enddo
+ enddo
+ write(iout,*) "Number of chain permutations",npermchain
+ write(iout,*) "Permutations"
+ do i=1,npermchain
+ write(iout,'(20i4)') (tabpermchain(j,i),j=1,nchain)
+ enddo
+ return
+ end
+c---------------------------------------------------------------------
+ integer function tperm(i,iperm,tabpermchain)
+ implicit none
+ include 'DIMENSIONS'
+ integer i,iperm
+ integer tabpermchain(maxchain,maxperm)
+ if (i.eq.0) then
+ tperm=0
+ else
+ tperm=tabpermchain(i,iperm)
+ endif
+ return
+ end
--- /dev/null
+ 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
--- /dev/null
+#include <stdio.h>
+#include <sys/utsname.h>
+#include <sys/types.h>
+#include <time.h>
+#include <string.h>
+
+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");
+}
--- /dev/null
+ 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),ipermmin
+ integer isecstr(maxres)
+ integer itemp(maxfrag)
+ character*4 liczba
+ double precision Epot
+c print *,"Enter conf_compar",jcon
+ if (lprn) then
+ write (iout,*) "phi_ref theta_ref"
+ do i=1,nres
+ write (iout,"(i5,2f8.3)") i,theta_ref(i),phi_ref(i)
+ enddo
+ endif
+ rms_nat=rmsnat(jcon,ipermmin)
+ qnat=qwolynes(0,0,ipermmin)
+ call angnorm12(rmsang,ipermmin)
+c Level 1: check secondary and supersecondary structure
+ call elecont(lprn,ncont,icont,nnt,nct,ipermmin)
+ if (lprn) then
+ write (iout,*) "elecont finished"
+ call flush(iout)
+ endif
+ call secondary2(lprn,.false.,ncont,icont,isecstr)
+ if (lprn) then
+ write (iout,*) "secondary2 finished"
+ call flush(iout)
+ endif
+ call contact(lprn,ncontsc,icontsc,nnt,nct,ipermmin)
+ if (lprn) then
+ write(iout,*) "Assigning electrostatic contacts"
+ call flush(iout)
+ endif
+ call contacts_between_fragments(lprn,3,ncont,icont,ncont_frag,
+ & icont_frag)
+ if (lprn) then
+ write(iout,*) "Assigning sidechain contacts"
+ call flush(iout)
+ endif
+ call contacts_between_fragments(lprn,3,ncontsc,icontsc,
+ & nsccont_frag,isccont_frag)
+ if (lprn) then
+ write(iout,*) "--> After contacts_between_fragments"
+ call flush(iout)
+ endif
+ 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
+ call flush(iout)
+ rmsfrag(j,1)=rmscalc_frag(0,1,j,jcon,ipermmin,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"
+ call flush(iout)
+ ncnat=ncont_frag_ref(ind)
+c write (iout,*) "before match_contact:",nc_fragm(j,1),
+c & nc_req_setf(j,1)
+c call flush(iout)
+ call match_secondary(j,isecstr,nsec_match,ipermmin,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),ipermmin,.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),ipermmin,.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),ipermmin,.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,ipermmin)
+ 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_frag(-ishiff,1,j,jcon,ipermmin,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_frag(ishiff,1,j,jcon,ipermmin,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,ipermmin,.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,ipermmin,.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,ipermmin)
+ if (lprn) write (iout,*)
+ & "Comparing rms: fragments",
+ & (ipiece(k,j,i),k=1,npiece(j,i))
+ rmsfrag(j,i)=rmscalc_frag(0,i,j,jcon,ipermmin,lprn)
+ if (lprn) write (iout,*) "ij",i,j,"rmsfrag",rmsfrag(j,i),
+ & " irma",irms(j,i)
+ 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_frag(-ishif,i,j,jcon,ipermmin,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_frag(ishif,i,j,jcon,ipermmin,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
+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
--- /dev/null
+ 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
--- /dev/null
+ subroutine contact(lprint,ncont,icont,ist,ien,ipermmin)
+ 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
+ integer iperm,ipermmin,ii,jj
+ 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=iabs(itype(i))
+ ii = iperm(i,ipermmin)
+ if (iti.le.0 .or. iti.gt.ntyp) cycle
+ do j=i+kkk,ien
+ jj = iperm(j,ipermmin)
+ itj=iabs(itype(j))
+ if (itj.le.0 .or. itj.gt.ntyp) cycle
+ itypi=iti
+ itypj=itj
+ xj = c(1,nres+jj)-c(1,nres+ii)
+ yj = c(2,nres+jj)-c(2,nres+ii)
+ zj = c(3,nres+jj)-c(3,nres+ii)
+ dxi = dc_norm(1,nres+ii)
+ dyi = dc_norm(2,nres+ii)
+ dzi = dc_norm(3,nres+ii)
+ dxj = dc_norm(1,nres+jj)
+ dyj = dc_norm(2,nres+jj)
+ dzj = dc_norm(3,nres+jj)
+ do k=1,3
+ a(k)=dc(k,nres+ii)
+ b(k)=dc(k,nres+jj)
+ 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(iabs(it1),iabs(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
--- /dev/null
+ 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
--- /dev/null
+ 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
+ logical conf_check
+ write (iout,*) "cxread"
+ call flush(iout)
+ call set_slices(is,ie,ts,te,iR,ib,iparm)
+ write (iout,*) "after set_slices"
+ call flush(iout)
+ 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
+c call flush(iout)
+ call xdrffloat_(ixdrf, ruconst, iret)
+ call xdrffloat_(ixdrf, rt_bath, iret)
+ call xdrfint_(ixdrf, nss, iret)
+ do j=1,nss
+ if (dyn_ss) then
+ call xdrfint(ixdrf, idssb(j), iret)
+ call xdrfint(ixdrf, jdssb(j), iret)
+ idssb(j)=idssb(j)-nres
+ jdssb(j)=jdssb(j)-nres
+ else
+ call xdrfint_(ixdrf, ihpb(j), iret)
+ call xdrfint_(ixdrf, jhpb(j), iret)
+ endif
+ 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
+ call xdrffloat(ixdrf, rtime, iret)
+ call xdrffloat(ixdrf, rpotE, iret)
+c write (iout,*) "rpotE",rpotE," iret",iret
+c call flush(iout)
+ call xdrffloat(ixdrf, ruconst, iret)
+ call xdrffloat(ixdrf, rt_bath, iret)
+ call xdrfint(ixdrf, nss, iret)
+c write (iout,*) "ruconst",ruconst," rt_bath",rt_bath," nss",nss
+c call flush(iout)
+ do j=1,nss
+ if (dyn_ss) then
+ call xdrfint(ixdrf, idssb(j), iret)
+ call xdrfint(ixdrf, jdssb(j), iret)
+ else
+ call xdrfint(ixdrf, ihpb(j), iret)
+ call xdrfint(ixdrf, jhpb(j), iret)
+ endif
+ enddo
+ call xdrfint(ixdrf, nprop, iret)
+c write (iout,*) "nprop",nprop
+ 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))
+#ifdef DEBUG
+ write (iout,*) "ii",ii," itraj",itraj," it",it
+#endif
+ 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
+c Box shift
+ call oligomer
+ do i=1,nres
+ do j=1,3
+ xoord(j,i)=c(j,i)
+ enddo
+ enddo
+ do i=1,nct-nnt+1
+ do j=1,3
+ xoord(j,i+nres)=c(j,i+nres+nnt-1)
+ enddo
+ enddo
+c end change
+
+ 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
+#ifdef DEBUG
+ write (iout,*) "islice",islice," ii",ii," kk",kk(islice),
+ & " mm",mm(islice)
+ write (iout,*) "itraj",itraj," nstep",nstep(itraj),
+ & " isampl",isampl(iparm)
+ call flush(iout)
+#endif
+ if (mod(nstep(itraj),isampl(iparm)).eq.0 .and.
+ & conf_check(ll(islice)+1,1)) then
+ if (replica(iparm)) then
+ if (rt_bath.eq.0.0d0) then
+ write (iout,*) "ERROR: zero temperature",
+ & islice,kk(islice),mm(islice)
+ call flush(iout)
+ endif
+ 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
+ write (iout,*) "nss",nss
+ write (iout,*) (ihpb(k),jhpb(k),k=1,nss)
+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
+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
+ 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 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
--- /dev/null
+ 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
--- /dev/null
+ 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
--- /dev/null
+ subroutine init_dfa_vars
+
+ include 'DIMENSIONS'
+ include 'COMMON.INTERACT'
+ include 'COMMON.DFA'
+
+ integer ii
+
+C Number of restraints
+ idisnum = 0
+ iphinum = 0
+ ithenum = 0
+ ineinum = 0
+
+ idislis = 0
+ iphilis = 0
+ ithelis = 0
+ ineilis = 0
+ jneilis = 0
+ jneinum = 0
+ kshell = 0
+ fnei = 0
+C For beta
+ nca = 0
+ icaidx = 0
+
+C real variables
+CC WEIGHTS for each min
+ sccdist = 0.0d0
+ fdist = 0.0d0
+ sccphi = 0.0d0
+ sccthe = 0.0d0
+ sccnei = 0.0d0
+ fphi1 = 0.0d0
+ fphi2 = 0.0d0
+ fthe1 = 0.0d0
+ fthe2 = 0.0d0
+C energies
+ edfatot = 0.0d0
+ edfadis = 0.0d0
+ edfaphi = 0.0d0
+ edfathe = 0.0d0
+ edfanei = 0.0d0
+ edfabet = 0.0d0
+C weights for each E term
+C these should be identical with
+ dis_inc = 0.0d0
+ phi_inc = 0.0d0
+ the_inc = 0.0d0
+ nei_inc = 0.0d0
+ beta_inc = 0.0d0
+ wshet = 0.0d0
+C precalculate exp table!
+c dfaexp = 0.0d0
+c do ii = 1, 15001
+c dfaexp(ii) = exp(-ii*0.001d0 + 0.0005d0)
+c end do
+
+ ishiftca=nnt-1
+ ilastca=nct
+
+ print *,'ishiftca=',ishiftca,'ilastca=',ilastca
+
+ return
+ end
+
+
+ subroutine read_dfa_info
+C
+C read fragment informations
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'DIMENSIONS.ZSCOPT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DFA'
+ include 'COMMON.FFIELD'
+
+
+C NOTE THAT FILENAMES are FIXED, CURRENTLY!!
+C THIS SHOULD BE MODIFIED!!
+
+ character*320 buffer
+ integer iodfa
+ parameter(iodfa=89)
+
+ integer i, j, nval
+ integer ica1, ica2,ica3,ica4,ica5
+ integer ishell, inca, itmp,iitmp
+ double precision wtmp
+C
+C READ DISTANCE
+C
+ open(iodfa, file = 'dist_dfa.dat', status = 'old', err=33)
+ goto 34
+ 33 write(iout,'(a)') 'Error opening dist_dfa.dat file'
+ stop
+ 34 continue
+ write(iout,'(a)') 'dist_dfa.dat is opened!'
+C read title
+ read(iodfa, '(a)') buffer
+C read number of restraints
+ read(iodfa, *) IDFADIS
+ read(iodfa, *) dis_inc
+ do i=1, idfadis
+ read(iodfa, '(i10,1x,i10,1x,i10)') ica1, ica2, nval
+
+ idisnum(i)=nval
+ idislis(1,i)=ica1
+ idislis(2,i)=ica2
+
+ do j=1, nval
+ read(iodfa,*) tmp
+ fdist(i,j) = tmp
+ enddo
+
+ do j=1, nval
+ read(iodfa,*) tmp
+ sccdist(i,j) = tmp
+ enddo
+
+ enddo
+ close(iodfa)
+
+C READ ANGLE RESTRAINTS
+C PHI RESTRAINTS
+ open(iodfa, file='phi_dfa.dat',status='old',err=35)
+ goto 36
+ 35 write(iout,'(a)') 'Error opening dist_dfa.dat file'
+ stop
+
+ 36 continue
+ write(iout,'(a)') 'phi_dfa.dat is opened!'
+
+C READ TITLE
+ read(iodfa, '(a)') buffer
+C READ NUMBER OF RESTRAINTS
+ READ(iodfa, *) IDFAPHI
+ read(iodfa,*) phi_inc
+ do i=1, idfaphi
+ read(iodfa,'(5(i10,1x),1x,i10)')ica1,ica2,ica3,ica4,ica5,nval
+
+ iphinum(i)=nval
+
+ iphilis(1,i)=ica1
+ iphilis(2,i)=ica2
+ iphilis(3,i)=ica3
+ iphilis(4,i)=ica4
+ iphilis(5,i)=ica5
+
+ do j=1, nval
+ read(iodfa,*) tmp1,tmp2
+ fphi1(i,j) = tmp1
+ fphi2(i,j) = tmp2
+ enddo
+
+ do j=1, nval
+ read(iodfa,*) tmp
+ sccphi(i,j) = tmp
+ enddo
+
+ enddo
+ close(iodfa)
+
+C THETA RESTRAINTS
+ open(iodfa, file='theta_dfa.dat',status='old',err=41)
+ goto 42
+ 41 write(iout,'(a)') 'Error opening dist_dfa.dat file'
+ stop
+ 42 continue
+ write(iout,'(a)') 'theta_dfa.dat is opened!'
+C READ TITLE
+ read(iodfa, '(a)') buffer
+C READ NUMBER OF RESTRAINTS
+ READ(iodfa, *) IDFATHE
+ read(iodfa,*) the_inc
+
+ do i=1, idfathe
+ read(iodfa, '(5(i10,1x),1x,i10)')ica1,ica2,ica3,ica4,ica5,nval
+
+ ithenum(i)=nval
+
+ ithelis(1,i)=ica1
+ ithelis(2,i)=ica2
+ ithelis(3,i)=ica3
+ ithelis(4,i)=ica4
+ ithelis(5,i)=ica5
+
+ do j=1, nval
+ read(iodfa,*) tmp1,tmp2
+ fthe1(i,j) = tmp1
+ fthe2(i,j) = tmp2
+ enddo
+
+ do j=1, nval
+ read(iodfa,*) tmp
+ sccthe(i,j) = tmp
+ enddo
+
+ enddo
+ close(iodfa)
+C END of READING ANGLE RESTRAINT!
+
+C NUMBER OF NEIGHBOR CAs
+ open(iodfa,file='nei_dfa.dat',status='old',err=37)
+ goto 38
+ 37 write(iout,'(a)') 'Error opening nei_dfa.dat file'
+ stop
+ 38 continue
+ write(iout,'(a)') 'nei_dfa.dat is opened!'
+C READ TITLE
+ read(iodfa, '(a)') buffer
+C READ NUMBER OF RESTRAINTS
+ READ(iodfa, *) idfanei
+ read(iodfa,*) nei_inc
+
+ do i=1, idfanei
+ read(iodfa,'(2(i10,1x),i10)')ica1,ishell,nval
+
+ ineilis(i)=ica1
+ kshell(i)=ishell
+ ineinum(i)=nval
+
+ do j=1, nval
+ read(iodfa,*) inca
+ fnei(i,j) = inca
+C write(*,*) 'READ NEI:',i,j,fnei(i,j)
+ enddo
+
+ do j=1, nval
+ read(iodfa,*) tmp
+ sccnei(i,j) = tmp
+ enddo
+
+ enddo
+ close(iodfa)
+C END OF NEIGHBORING CA
+
+C READ BETA RESTRAINT
+ if (wdfa_beta.eq.0.0) return
+ open(iodfa, file='beta_dfa.dat',status='old',err=39)
+ goto 40
+ 39 write(iout,'(a)') 'Error opening beta_dfa.dat file'
+ stop
+ 40 continue
+ write(iout,'(a)') 'beta_dfa.dat is opened!'
+
+ read(iodfa,'(a)') buffer
+ read(iodfa,*) itmp
+ read(iodfa,*) beta_inc
+
+ do i=1,itmp
+ read(iodfa,*) ica1, iitmp
+ do j=1,itmp
+ read(iodfa,*) wtmp
+ wshet(i,j) = wtmp
+c write(*,*) 'BETA:',i,j,wtmp,wshet(i,j)
+ enddo
+ enddo
+
+ close(iodfa)
+C END OF BETA RESTRAINT
+
+ return
+ END
+
+ subroutine edfad(edfadis)
+
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.DFA'
+
+ double precision edfadis
+ integer i, iatm1, iatm2,idiff
+ double precision ckk, sckk,dist,texp
+ double precision jix,jiy,jiz,ep,fp,scc
+
+ edfadis=0
+ gdfad=0.0d0
+
+ do i=1, idfadis
+
+ iatm1=idislis(1,i)+ishiftca
+ iatm2=idislis(2,i)+ishiftca
+ idiff = abs(iatm1-iatm2)
+
+ JIX=c(1,iatm2)-c(1,iatm1)
+ JIY=c(2,iatm2)-c(2,iatm1)
+ JIZ=c(3,iatm2)-c(3,iatm1)
+ DIST=SQRT(JIX*JIX+JIY*JIY+JIZ*JIZ)
+
+ ckk=ck(idiff)
+ sckk=sck(idiff)
+
+ scc = 0.0d0
+ ep = 0.0d0
+ fp = 0.0d0
+
+ do j=1,idisnum(i)
+
+ dd = dist-fdist(i,j)
+ dtmp = dd*dd/ckk
+ if (dtmp.ge.15.0d0) then
+ texp = 0.0d0
+ else
+c texp = dfaexp( idint(dtmp*1000)+1 )/sckk
+ texp = exp(-dtmp)/sckk
+ endif
+
+ ep=ep+sccdist(i,j)*texp
+ fp=fp+sccdist(i,j)*texp*dd*2.0d0/ckk
+ scc=scc+sccdist(i,j)
+C write(*,'(2i8,6f12.5)') i, j, dist,
+C & fdist(i,j), ep, fp, sccdist(i,j), scc
+
+ enddo
+
+ ep = -ep/scc
+ fp = fp/scc
+
+
+c IF(ABS(EP).lt.1.0d-20)THEN
+c EP=0.0D0
+c ENDIF
+c IF (ABS(FP).lt.1.0d-20) THEN
+c FP=0.0D0
+c ENDIF
+
+ edfadis=edfadis+ep*dis_inc*wwdist
+
+ gdfad(1,iatm1) = gdfad(1,iatm1)-jix/dist*fp*dis_inc*wwdist
+ gdfad(2,iatm1) = gdfad(2,iatm1)-jiy/dist*fp*dis_inc*wwdist
+ gdfad(3,iatm1) = gdfad(3,iatm1)-jiz/dist*fp*dis_inc*wwdist
+
+ gdfad(1,iatm2) = gdfad(1,iatm2)+jix/dist*fp*dis_inc*wwdist
+ gdfad(2,iatm2) = gdfad(2,iatm2)+jiy/dist*fp*dis_inc*wwdist
+ gdfad(3,iatm2) = gdfad(3,iatm2)+jiz/dist*fp*dis_inc*wwdist
+
+ enddo
+
+ return
+ end
+
+ subroutine edfat(edfator)
+C DFA torsion angle
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.DFA'
+
+ integer i,j,ii,iii
+ integer iatom(5)
+ double precision aphi(2),athe(2),tdx(5),tdy(5),tdz(5)
+ double precision cwidth, cwidth2
+ PARAMETER(CWIDTH=0.1D0,CWIDTH2=0.2D0,PAI=3.14159265358979323846D0)
+ parameter (TENM20=1.0d-20)
+
+ edfator= 0.0d0
+ enephi = 0.0d0
+ enethe = 0.0d0
+ gdfat(:,:) = 0.0d0
+
+C START OF PHI ANGLE
+ do i=1, idfaphi
+
+ aphi = 0.0d0
+ do iii=1,5
+ iatom(iii)=iphilis(iii,i)+ishiftca
+ enddo
+
+C ANGLE VECTOR CALCULTION
+ RIX=C(1,IATOM(2))-C(1,IATOM(1))
+ RIY=C(2,IATOM(2))-C(2,IATOM(1))
+ RIZ=C(3,IATOM(2))-C(3,IATOM(1))
+
+ RIPX=C(1,IATOM(3))-C(1,IATOM(2))
+ RIPY=C(2,IATOM(3))-C(2,IATOM(2))
+ RIPZ=C(3,IATOM(3))-C(3,IATOM(2))
+
+ RIPPX=C(1,IATOM(4))-C(1,IATOM(3))
+ RIPPY=C(2,IATOM(4))-C(2,IATOM(3))
+ RIPPZ=C(3,IATOM(4))-C(3,IATOM(3))
+
+ RIP3X=C(1,IATOM(5))-C(1,IATOM(4))
+ RIP3Y=C(2,IATOM(5))-C(2,IATOM(4))
+ RIP3Z=C(3,IATOM(5))-C(3,IATOM(4))
+
+ GIX=RIY*RIPZ-RIZ*RIPY
+ GIY=RIZ*RIPX-RIX*RIPZ
+ GIZ=RIX*RIPY-RIY*RIPX
+
+ GIPX=RIPY*RIPPZ-RIPZ*RIPPY
+ GIPY=RIPZ*RIPPX-RIPX*RIPPZ
+ GIPZ=RIPX*RIPPY-RIPY*RIPPX
+
+ CIPX=C(1,IATOM(3))-C(1,IATOM(1))
+ CIPY=C(2,IATOM(3))-C(2,IATOM(1))
+ CIPZ=C(3,IATOM(3))-C(3,IATOM(1))
+
+ CIPPX=C(1,IATOM(4))-C(1,IATOM(2))
+ CIPPY=C(2,IATOM(4))-C(2,IATOM(2))
+ CIPPZ=C(3,IATOM(4))-C(3,IATOM(2))
+
+ CIP3X=C(1,IATOM(5))-C(1,IATOM(3))
+ CIP3Y=C(2,IATOM(5))-C(2,IATOM(3))
+ CIP3Z=C(3,IATOM(5))-C(3,IATOM(3))
+
+ DGI=SQRT(GIX*GIX+GIY*GIY+GIZ*GIZ)
+ DGIP=SQRT(GIPX*GIPX+GIPY*GIPY+GIPZ*GIPZ)
+ DRIPP=SQRT(RIPPX*RIPPX+RIPPY*RIPPY+RIPPZ*RIPPZ)
+ DRIP3=SQRT(RIP3X*RIP3X+RIP3Y*RIP3Y+RIP3Z*RIP3Z)
+
+C END OF ANGLE VECTOR CALCULTION
+
+ TDOT=GIX*RIPPX+GIY*RIPPY+GIZ*RIPPZ
+ APHI(1)=TDOT/(DGI*DRIPP)
+ TDOT=GIPX*RIP3X+GIPY*RIP3Y+GIPZ*RIP3Z
+ APHI(2)=TDOT/(DGIP*DRIP3)
+
+ ephi = 0.0d0
+ tfphi1=0.0d0
+ tfphi2=0.0d0
+ scc=0.0d0
+
+ do j=1, iphinum(i)
+ DDPS1=APHI(1)-FPHI1(i,j)
+ DDPS2=APHI(2)-FPHI2(i,j)
+
+ DTMP = (DDPS1**2+DDPS2**2)/CWIDTH2
+
+ if (dtmp.ge.15.0d0) then
+ ps_tmp = 0.0d0
+ else
+c ps_tmp = dfaexp(idint(dtmp*1000)+1)
+ ps_tmp = exp(-dtmp)
+ endif
+
+ ephi=ephi+sccphi(i,j)*ps_tmp
+
+ tfphi1=tfphi1+sccphi(i,j)*ddps1/cwidth*ps_tmp
+ tfphi2=tfphi2+sccphi(i,j)*ddps2/cwidth*ps_tmp
+
+ scc=scc+sccphi(i,j)
+c write(*,'(2i8,8f12.6)')i,j,aphi(1),fphi1(i,j),
+c & aphi(2),fphi2(i,j),tfphi1,tfphi2,ephi,sccphi(i,j)
+ ENDDO
+
+ ephi=-ephi/scc*phi_inc*wwangle
+ tfphi1=tfphi1/scc*phi_inc*wwangle
+ tfphi2=tfphi2/scc*phi_inc*wwangle
+
+ IF (ABS(EPHI).LT.1d-20) THEN
+ EPHI=0.0D0
+ ENDIF
+ IF (ABS(TFPHI1).LT.1d-20) THEN
+ TFPHI1=0.0D0
+ ENDIF
+ IF (ABS(TFPHI2).LT.1d-20) THEN
+ TFPHI2=0.0D0
+ ENDIF
+
+C FORCE DIRECTION CALCULATION
+ TDX(1:5)=0.0D0
+ TDY(1:5)=0.0D0
+ TDZ(1:5)=0.0D0
+
+ DM1=1.0d0/(DGI*DRIPP)
+
+ GIRPP=GIX*RIPPX+GIY*RIPPY+GIZ*RIPPZ
+ DM2=GIRPP/(DGI**3*DRIPP)
+ DM3=GIRPP/(DGI*DRIPP**3)
+
+ DM4=1.0d0/(DGIP*DRIP3)
+
+ GIRP3=GIPX*RIP3X+GIPY*RIP3Y+GIPZ*RIP3Z
+ DM5=GIRP3/(DGIP**3*DRIP3)
+ DM6=GIRP3/(DGIP*DRIP3**3)
+C FIRST ATOM BY PHI1
+ TDX(1)=(RIPZ*RIPPY-RIPY*RIPPZ)*DM1
+ & +( GIZ* RIPY- GIY* RIPZ)*DM2
+ TDY(1)=(RIPX*RIPPZ-RIPZ*RIPPX)*DM1
+ & +( GIX* RIPZ- GIZ* RIPX)*DM2
+ TDZ(1)=(RIPY*RIPPX-RIPX*RIPPY)*DM1
+ & +( GIY* RIPX- GIX* RIPY)*DM2
+ TDX(1)=TDX(1)*TFPHI1
+ TDY(1)=TDY(1)*TFPHI1
+ TDZ(1)=TDZ(1)*TFPHI1
+C SECOND ATOM BY PHI1
+ TDX(2)=(CIPY*RIPPZ-CIPZ*RIPPY)*DM1
+ & -(CIPY*GIZ-CIPZ*GIY)*DM2
+ TDY(2)=(CIPZ*RIPPX-CIPX*RIPPZ)*DM1
+ & -(CIPZ*GIX-CIPX*GIZ)*DM2
+ TDZ(2)=(CIPX*RIPPY-CIPY*RIPPX)*DM1
+ & -(CIPX*GIY-CIPY*GIX)*DM2
+ TDX(2)=TDX(2)*TFPHI1
+ TDY(2)=TDY(2)*TFPHI1
+ TDZ(2)=TDZ(2)*TFPHI1
+C SECOND ATOM BY PHI2
+ TDX(2)=TDX(2)+
+ & ((RIPPZ*RIP3Y-RIPPY*RIP3Z)*DM4
+ & +( GIPZ*RIPPY- GIPY*RIPPZ)*DM5)*TFPHI2
+ TDY(2)=TDY(2)+
+ & ((RIPPX*RIP3Z-RIPPZ*RIP3X)*DM4
+ & +( GIPX*RIPPZ- GIPZ*RIPPX)*DM5)*TFPHI2
+ TDZ(2)=TDZ(2)+
+ & ((RIPPY*RIP3X-RIPPX*RIP3Y)*DM4
+ & +( GIPY*RIPPX- GIPX*RIPPY)*DM5)*TFPHI2
+C THIRD ATOM BY PHI1
+ TDX(3)=(-GIX+RIPPY*RIZ-RIPPZ*RIY)*DM1
+ & -(GIY*RIZ-RIY*GIZ)*DM2+RIPPX*DM3
+ TDY(3)=(-GIY+RIPPZ*RIX-RIPPX*RIZ)*DM1
+ & -(GIZ*RIX-RIZ*GIX)*DM2+RIPPY*DM3
+ TDZ(3)=(-GIZ+RIPPX*RIY-RIPPY*RIX)*DM1
+ & -(GIX*RIY-RIX*GIY)*DM2+RIPPZ*DM3
+ TDX(3)=TDX(3)*TFPHI1
+ TDY(3)=TDY(3)*TFPHI1
+ TDZ(3)=TDZ(3)*TFPHI1
+C THIRD ATOM BY PHI2
+ TDX(3)=TDX(3)+
+ & ((CIPPY*RIP3Z-CIPPZ*RIP3Y)*DM4
+ & -(CIPPY*GIPZ-CIPPZ*GIPY)*DM5)*TFPHI2
+ TDY(3)=TDY(3)+
+ & ((CIPPZ*RIP3X-CIPPX*RIP3Z)*DM4
+ & -(CIPPZ*GIPX-CIPPX*GIPZ)*DM5)*TFPHI2
+ TDZ(3)=TDZ(3)+
+ & ((CIPPX*RIP3Y-CIPPY*RIP3X)*DM4
+ & -(CIPPX*GIPY-CIPPY*GIPX)*DM5)*TFPHI2
+C FOURTH ATOM BY PHI1
+ TDX(4)=(GIX*DM1-RIPPX*DM3)*TFPHI1
+ TDY(4)=(GIY*DM1-RIPPY*DM3)*TFPHI1
+ TDZ(4)=(GIZ*DM1-RIPPZ*DM3)*TFPHI1
+C FOURTH ATOM BY PHI2
+ TDX(4)=TDX(4)+
+ & ((-GIPX+RIP3Y*RIPZ-RIP3Z*RIPY)*DM4
+ & -( GIPY*RIPZ-RIPY*GIPZ)*DM5
+ & + RIP3X*DM6)*TFPHI2
+ TDY(4)=TDY(4)+
+ & ((-GIPY+RIP3Z*RIPX-RIP3X*RIPZ)*DM4
+ & -( GIPZ*RIPX-RIPZ*GIPX)*DM5
+ & + RIP3Y*DM6)*TFPHI2
+ TDZ(4)=TDZ(4)+
+ & ((-GIPZ+RIP3X*RIPY-RIP3Y*RIPX)*DM4
+ & -( GIPX*RIPY-RIPX*GIPY)*DM5
+ & + RIP3Z*DM6)*TFPHI2
+C FIFTH ATOM BY PHI2
+ TDX(5)=(GIPX*DM4-RIP3X*DM6)*TFPHI2
+ TDY(5)=(GIPY*DM4-RIP3Y*DM6)*TFPHI2
+ TDZ(5)=(GIPZ*DM4-RIP3Z*DM6)*TFPHI2
+C END OF FORCE DIRECTION
+c force calcuation
+ DO II=1,5
+ gdfat(1,IATOM(II))=gdfat(1,IATOM(II))+TDX(II)
+ gdfat(2,IATOM(II))=gdfat(2,IATOM(II))+TDY(II)
+ gdfat(3,IATOM(II))=gdfat(3,IATOM(II))+TDZ(II)
+ ENDDO
+c energy calculation
+ enephi = enephi + ephi
+c end of single assignment statement
+ ENDDO
+C END OF PHI RESTRAINT
+
+C START OF THETA ANGLE
+ do i=1, idfathe
+
+ athe = 0.0d0
+ do iii=1,5
+ iatom(iii)=ithelis(iii,i)+ishiftca
+ enddo
+
+
+C ANGLE VECTOR CALCULTION
+ RIX=C(1,IATOM(2))-C(1,IATOM(1))
+ RIY=C(2,IATOM(2))-C(2,IATOM(1))
+ RIZ=C(3,IATOM(2))-C(3,IATOM(1))
+
+ RIPX=C(1,IATOM(3))-C(1,IATOM(2))
+ RIPY=C(2,IATOM(3))-C(2,IATOM(2))
+ RIPZ=C(3,IATOM(3))-C(3,IATOM(2))
+
+ RIPPX=C(1,IATOM(4))-C(1,IATOM(3))
+ RIPPY=C(2,IATOM(4))-C(2,IATOM(3))
+ RIPPZ=C(3,IATOM(4))-C(3,IATOM(3))
+
+ RIP3X=C(1,IATOM(5))-C(1,IATOM(4))
+ RIP3Y=C(2,IATOM(5))-C(2,IATOM(4))
+ RIP3Z=C(3,IATOM(5))-C(3,IATOM(4))
+
+ GIX=RIY*RIPZ-RIZ*RIPY
+ GIY=RIZ*RIPX-RIX*RIPZ
+ GIZ=RIX*RIPY-RIY*RIPX
+
+ GIPX=RIPY*RIPPZ-RIPZ*RIPPY
+ GIPY=RIPZ*RIPPX-RIPX*RIPPZ
+ GIPZ=RIPX*RIPPY-RIPY*RIPPX
+
+ GIPPX=RIPPY*RIP3Z-RIPPZ*RIP3Y
+ GIPPY=RIPPZ*RIP3X-RIPPX*RIP3Z
+ GIPPZ=RIPPX*RIP3Y-RIPPY*RIP3X
+
+ CIPX=C(1,IATOM(3))-C(1,IATOM(1))
+ CIPY=C(2,IATOM(3))-C(2,IATOM(1))
+ CIPZ=C(3,IATOM(3))-C(3,IATOM(1))
+
+ CIPPX=C(1,IATOM(4))-C(1,IATOM(2))
+ CIPPY=C(2,IATOM(4))-C(2,IATOM(2))
+ CIPPZ=C(3,IATOM(4))-C(3,IATOM(2))
+
+ CIP3X=C(1,IATOM(5))-C(1,IATOM(3))
+ CIP3Y=C(2,IATOM(5))-C(2,IATOM(3))
+ CIP3Z=C(3,IATOM(5))-C(3,IATOM(3))
+
+ DGI=SQRT(GIX*GIX+GIY*GIY+GIZ*GIZ)
+ DGIP=SQRT(GIPX*GIPX+GIPY*GIPY+GIPZ*GIPZ)
+ DGIPP=SQRT(GIPPX*GIPPX+GIPPY*GIPPY+GIPPZ*GIPPZ)
+ DRIPP=SQRT(RIPPX*RIPPX+RIPPY*RIPPY+RIPPZ*RIPPZ)
+ DRIP3=SQRT(RIP3X*RIP3X+RIP3Y*RIP3Y+RIP3Z*RIP3Z)
+C END OF ANGLE VECTOR CALCULTION
+
+ TDOT=GIX*GIPX+GIY*GIPY+GIZ*GIPZ
+ ATHE(1)=TDOT/(DGI*DGIP)
+ TDOT=GIPX*GIPPX+GIPY*GIPPY+GIPZ*GIPPZ
+ ATHE(2)=TDOT/(DGIP*DGIPP)
+
+ ETHE=0.0D0
+ TFTHE1=0.0D0
+ TFTHE2=0.0D0
+ SCC=0.0D0
+ TH_TMP=0.0d0
+
+ do j=1,ithenum(i)
+ ddth1=athe(1)-fthe1(i,j) !cos(the1)-cos(the1_ref)
+ ddth2=athe(2)-fthe2(i,j) !cos(the2)-cos(the2_ref)
+ dtmp= (ddth1**2+ddth2**2)/cwidth2
+ if ( dtmp .ge. 15.0d0) then
+ th_tmp = 0.0d0
+ else
+c th_tmp = dfaexp ( idint(dtmp*1000)+1 )
+ th_tmp = exp(-dtmp)
+ end if
+
+ ethe=ethe+sccthe(i,j)*th_tmp
+
+ tfthe1=tfthe1+sccthe(i,j)*ddth1/cwidth*th_tmp !-dv/dcos(the1)
+ tfthe2=tfthe2+sccthe(i,j)*ddth2/cwidth*th_tmp !-dv/dcos(the2)
+ scc=scc+sccthe(i,j)
+c write(2,'(2i8,8f12.6)')i,j,athe(1),fthe1(i,j),
+c & athe(2),fthe2(i,j),tfthe1,tfthe2,ethe,sccthe(i,j)
+ enddo
+
+ ethe=-ethe/scc*the_inc*wwangle
+ tfthe1=tfthe1/scc*the_inc*wwangle
+ tfthe2=tfthe2/scc*the_inc*wwangle
+
+ IF (ABS(ETHE).LT.TENM20) THEN
+ ETHE=0.0D0
+ ENDIF
+ IF (ABS(TFTHE1).LT.TENM20) THEN
+ TFTHE1=0.0D0
+ ENDIF
+ IF (ABS(TFTHE2).LT.TENM20) THEN
+ TFTHE2=0.0D0
+ ENDIF
+
+ TDX(1:5)=0.0D0
+ TDY(1:5)=0.0D0
+ TDZ(1:5)=0.0D0
+
+ DM1=1.0d0/(DGI*DGIP)
+ DM2=(GIX*GIPX+GIY*GIPY+GIZ*GIPZ)/(DGI**3*DGIP)
+ DM3=(GIX*GIPX+GIY*GIPY+GIZ*GIPZ)/(DGI*DGIP**3)
+
+ DM4=1.0d0/(DGIP*DGIPP)
+ DM5=(GIPX*GIPPX+GIPY*GIPPY+GIPZ*GIPPZ)/(DGIP**3*DGIPP)
+ DM6=(GIPX*GIPPX+GIPY*GIPPY+GIPZ*GIPPZ)/(DGIP*DGIPP**3)
+
+C FIRST ATOM BY THETA1
+ TDX(1)=((RIPZ*GIPY-RIPY*GIPZ)*DM1
+ & -(GIY*RIPZ-GIZ*RIPY)*DM2)*TFTHE1
+ TDY(1)=((-RIPZ*GIPX+RIPX*GIPZ)*DM1
+ & -(-GIX*RIPZ+GIZ*RIPX)*DM2)*TFTHE1
+ TDZ(1)=((RIPY*GIPX-RIPX*GIPY)*DM1
+ & -(GIX*RIPY-GIY*RIPX)*DM2)*TFTHE1
+C SECOND ATOM BY THETA1
+ TDX(2)=((CIPY*GIPZ-CIPZ*GIPY-RIPPY*GIZ+RIPPZ*GIY)*DM1
+ & -(CIPY*GIZ-CIPZ*GIY)*DM2
+ & +(RIPPY*GIPZ-RIPPZ*GIPY)*DM3)*TFTHE1
+ TDY(2)=((CIPZ*GIPX-CIPX*GIPZ-RIPPZ*GIX+RIPPX*GIZ)*DM1
+ & -(CIPZ*GIX-CIPX*GIZ)*DM2
+ & +(RIPPZ*GIPX-RIPPX*GIPZ)*DM3)*TFTHE1
+ TDZ(2)=((CIPX*GIPY-CIPY*GIPX-RIPPX*GIY+RIPPY*GIX)*DM1
+ & -(CIPX*GIY-CIPY*GIX)*DM2
+ & +(RIPPX*GIPY-RIPPY*GIPX)*DM3)*TFTHE1
+C SECOND ATOM BY THETA2
+ TDX(2)=TDX(2)+
+ & ((RIPPZ*GIPPY-RIPPY*GIPPZ)*DM4
+ & -(GIPY*RIPPZ-GIPZ*RIPPY)*DM5)*TFTHE2
+ TDY(2)=TDY(2)+
+ & ((-RIPPZ*GIPPX+RIPPX*GIPPZ)*DM4
+ & -(-GIPX*RIPPZ+GIPZ*RIPPX)*DM5)*TFTHE2
+ TDZ(2)=TDZ(2)+
+ & ((RIPPY*GIPPX-RIPPX*GIPPY)*DM4
+ & -(GIPX*RIPPY-GIPY*RIPPX)*DM5)*TFTHE2
+C THIRD ATOM BY THETA1
+ TDX(3)=((GIPY*RIZ-GIPZ*RIY-GIY*CIPPZ+GIZ*CIPPY)*DM1
+ & -(GIY*RIZ-GIZ*RIY)*DM2
+ & -(CIPPY*GIPZ-CIPPZ*GIPY)*DM3) *TFTHE1
+ TDY(3)=((GIPZ*RIX-GIPX*RIZ-GIZ*CIPPX+GIX*CIPPZ)*DM1
+ & -(GIZ*RIX-GIX*RIZ)*DM2
+ & -(CIPPZ*GIPX-CIPPX*GIPZ)*DM3) *TFTHE1
+ TDZ(3)=((GIPX*RIY-GIPY*RIX-GIX*CIPPY+GIY*CIPPX)*DM1
+ & -(GIX*RIY-GIY*RIX)*DM2
+ & -(CIPPX*GIPY-CIPPY*GIPX)*DM3) *TFTHE1
+C THIRD ATOM BY THETA2
+ TDX(3)=TDX(3)+
+ & ((CIPPY*GIPPZ-CIPPZ*GIPPY-RIP3Y*GIPZ+RIP3Z*GIPY)*DM4
+ & -(CIPPY*GIPZ-CIPPZ*GIPY)*DM5
+ & +(RIP3Y*GIPpZ-RIP3Z*GIPpY)*DM6) *TFTHE2
+ TDY(3)=TDY(3)+
+ & ((CIPPZ*GIPPX-CIPPX*GIPPZ-RIP3Z*GIPX+RIP3X*GIPZ)*DM4
+ & -(CIPPZ*GIPX-CIPPX*GIPZ)*DM5
+ & +(RIP3Z*GIPpX-RIP3X*GIPpZ)*DM6) *TFTHE2
+ TDZ(3)=TDZ(3)+
+ & ((CIPPX*GIPPY-CIPPY*GIPPX-RIP3X*GIPY+RIP3Y*GIPX)*DM4
+ & -(CIPPX*GIPY-CIPPY*GIPX)*DM5
+ & +(RIP3X*GIPpY-RIP3Y*GIPpX)*DM6) *TFTHE2
+C FOURTH ATOM BY THETA1
+ TDX(4)=-((GIZ*RIPY-GIY*RIPZ)*DM1
+ & -(GIPZ*RIPY-GIPY*RIPZ)*DM3) *TFTHE1
+ TDY(4)=-((GIX*RIPZ-GIZ*RIPX)*DM1
+ & -(GIPX*RIPZ-GIPZ*RIPX)*DM3) *TFTHE1
+ TDZ(4)=-((GIY*RIPX-GIX*RIPY)*DM1
+ & -(GIPY*RIPX-GIPX*RIPY)*DM3) *TFTHE1
+C FOURTH ATOM BY THETA2
+ TDX(4)=TDX(4)+
+ & ((GIPPY*RIPZ-GIPPZ*RIPY-GIPY*CIP3Z+GIPZ*CIP3Y)*DM4
+ & -(GIPY*RIPZ-GIPZ*RIPY)*DM5
+ & -(CIP3Y*GIPPZ-CIP3Z*GIPPY)*DM6)*TFTHE2
+ TDY(4)=TDY(4)+
+ & ((GIPPZ*RIPX-GIPPX*RIPZ-GIPZ*CIP3X+GIPX*CIP3Z)*DM4
+ & -(GIPZ*RIPX-GIPX*RIPZ)*DM5
+ & -(CIP3Z*GIPPX-CIP3X*GIPPZ)*DM6)*TFTHE2
+ TDZ(4)=TDZ(4)+
+ & ((GIPPX*RIPY-GIPPY*RIPX-GIPX*CIP3Y+GIPY*CIP3X)*DM4
+ & -(GIPX*RIPY-GIPY*RIPX)*DM5
+ & -(CIP3X*GIPPY-CIP3Y*GIPPX)*DM6)*TFTHE2
+C FIFTH ATOM BY THETA2
+ TDX(5)=-((GIPZ*RIPPY-GIPY*RIPPZ)*DM4
+ & -(GIPPZ*RIPPY-GIPPY*RIPPZ)*DM6)*TFTHE2
+ TDY(5)=-((GIPX*RIPPZ-GIPZ*RIPPX)*DM4
+ & -(GIPPX*RIPPZ-GIPPZ*RIPPX)*DM6)*TFTHE2
+ TDZ(5)=-((GIPY*RIPPX-GIPX*RIPPY)*DM4
+ & -(GIPPY*RIPPX-GIPPX*RIPPY)*DM6)*TFTHE2
+C !! END OF FORCE DIRECTION!!!!
+ DO II=1,5
+ gdfat(1,iatom(II))=gdfat(1,iatom(II))+TDX(II)
+ gdfat(2,iatom(II))=gdfat(2,iatom(II))+TDY(II)
+ gdfat(3,iatom(II))=gdfat(3,iatom(II))+TDZ(II)
+ ENDDO
+C energy calculation
+ enethe = enethe + ethe
+ ENDDO
+
+ edfator = enephi + enethe
+
+ RETURN
+ END
+
+ subroutine edfan(edfanei)
+C DFA neighboring CA restraint
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.DFA'
+
+ integer i,j,imin
+ integer kshnum, n1atom
+
+ double precision enenei,tmp_n
+ double precision pai,hpai
+ double precision jix,jiy,jiz,ndiff,snorm_nei
+ double precision t2dx(maxres),t2dy(maxres),t2dz(maxres)
+ double precision dr,dr2,half,ntmp,dtmp
+
+ parameter(dr=0.25d0,dr2=0.50d0,half=0.50d0)
+ parameter(pai=3.14159265358979323846D0)
+ parameter(hpai=1.5707963267948966D0)
+ parameter(snorm_nei=0.886226925452758D0)
+
+ edfanei = 0.0d0
+ enenei = 0.0d0
+ gdfan = 0.0d0
+
+c print*, 's1:', s1(:)
+c print*, 's2:', s2(:)
+
+ do i=1, idfanei
+
+ kshnum=kshell(i)
+ n1atom=ineilis(i)+ishiftca
+C write(*,*) 'kshnum,n1atom:', kshnum, n1atom
+
+ tmp_n=0.0d0
+ ftmp=0.0d0
+ dnei=0.0d0
+ dist=0.0d0
+ t1dx=0.0d0
+ t1dy=0.0d0
+ t1dz=0.0d0
+ t2dx=0.0d0
+ t2dy=0.0d0
+ t2dz=0.0d0
+
+ do j = ishiftca+1, ilastca
+
+ if (n1atom.eq.j) cycle
+
+ jix=c(1,j)-c(1,n1atom)
+ jiy=c(2,j)-c(2,n1atom)
+ jiz=c(3,j)-c(3,n1atom)
+ dist=sqrt(jix*jix+jiy*jiy+jiz*jiz)
+
+c write(*,*) n1atom, j, dist
+
+ if(kshnum.ne.1)then
+ if (dist.lt.s1(kshnum).and.
+ & dist.gt.s2(kshnum-1)) then
+
+ tmp_n=tmp_n+1.0d0
+
+c write(*,*) 'case1:',tmp_n
+
+cc t1dx=t1dx+0.0d0
+cc t1dy=t1dy+0.0d0
+cc t1dz=t1dz+0.0d0
+ t2dx(j)=0.0d0
+ t2dy(j)=0.0d0
+ t2dz(j)=0.0d0
+
+ elseif(dist.ge.s1(kshnum).and.
+ & dist.le.s2(kshnum)) then
+
+ dnei=(dist-s1(kshnum))/dr2*pai
+ tmp_n=tmp_n + half*(1+cos(dnei))
+c write(*,*) 'case2:',tmp_n
+ ftmp=-pai*sin(dnei)/dr2/dist/2.0d0
+c center atom
+ t1dx=t1dx+jix*ftmp
+ t1dy=t1dy+jiy*ftmp
+ t1dz=t1dz+jiz*ftmp
+c neighbor atoms
+ t2dx(j)=-jix*ftmp
+ t2dy(j)=-jiy*ftmp
+ t2dz(j)=-jiz*ftmp
+c
+ elseif(dist.ge.s1(kshnum-1).and.
+ & dist.le.s2(kshnum-1)) then
+ dnei=(dist-s1(kshnum-1))/dr2*pai
+ tmp_n=tmp_n + 1.0d0 - half*(1+cos(dnei))
+c write(*,*) 'case3:',tmp_n
+ ftmp = hpai*sin(dnei)/dr2/dist
+c center atom
+ t1dx=t1dx+jix*ftmp
+ t1dy=t1dy+jiy*ftmp
+ t1dz=t1dz+jiz*ftmp
+c neighbor atoms
+ t2dx(j)=-jix*ftmp
+ t2dy(j)=-jiy*ftmp
+ t2dz(j)=-jiz*ftmp
+
+ endif
+
+ elseif(kshnum.eq.1) then
+
+ if(dist.lt.s1(kshnum))then
+
+ tmp_n=tmp_n+1.0d0
+c write(*,*) 'case4:',tmp_n
+cc t1dx=t1dx+0.0d0
+cc t1dy=t1dy+0.0d0
+cc t1dz=t1dz+0.0d0
+ t2dx(j)=0.0d0
+ t2dy(j)=0.0d0
+ t2dz(j)=0.0d0
+
+ elseif(dist.ge.s1(kshnum).and.
+ & dist.le.s2(kshnum))then
+
+ dnei=(dist-s1(kshnum))/dr2*pai
+ tmp_n=tmp_n + half*(1+cos(dnei))
+c write(*,*) 'case5:',tmp_n
+ ftmp = -hpai*sin(dnei)/dr2/dist
+c center atom
+ t1dx=t1dx+jix*ftmp
+ t1dy=t1dy+jiy*ftmp
+ t1dz=t1dz+jiz*ftmp
+c neighbor atoms
+ t2dx(j)=-jix*ftmp
+ t2dy(j)=-jiy*ftmp
+ t2dz(j)=-jiz*ftmp
+
+ endif
+ endif
+ enddo
+
+ scc=0.0d0
+ enei=0.0d0
+ tmp_fnei=0.0d0
+ ndiff=0.0d0
+
+ do imin=1,ineinum(i)
+
+ ndiff = tmp_n-fnei(i,imin)
+ dtmp = ndiff*ndiff
+
+ if (dtmp.ge.15.0d0) then
+ ntmp = 0.0d0
+ else
+c ntmp = dfaexp( idint(dtmp*1000) + 1 )
+ ntmp = exp(-dtmp)
+ end if
+
+ enei=enei+sccnei(i,imin)*ntmp
+ tmp_fnei=tmp_fnei-
+ & sccnei(i,imin)*ntmp*ndiff*2.0d0
+ scc=scc+sccnei(i,imin)
+
+c write(*,'(a,1x,2i8,f12.7,i8,3f12.7)')'NEI:',i,imin,tmp_n,
+c & fnei(i,imin),sccnei(i,imin),enei,scc
+ enddo
+
+ enei=-enei/scc*snorm_nei*nei_inc*wwnei
+ tmp_fnei=tmp_fnei/scc*snorm_nei*nei_inc*wwnei
+
+c if (abs(enei).lt.1.0d-20)then
+c enei=0.0d0
+c endif
+c if (abs(tmp_fnei).lt.1.0d-20) then
+c tmp_fnei=0.0d0
+c endif
+
+c force calculation
+ t1dx=t1dx*tmp_fnei
+ t1dy=t1dy*tmp_fnei
+ t1dz=t1dz*tmp_fnei
+
+ do j=ishiftca+1,ilastca
+ t2dx(j)=t2dx(j)*tmp_fnei
+ t2dy(j)=t2dy(j)*tmp_fnei
+ t2dz(j)=t2dz(j)*tmp_fnei
+ enddo
+
+ gdfan(1,n1atom)=gdfan(1,n1atom)+t1dx
+ gdfan(2,n1atom)=gdfan(2,n1atom)+t1dy
+ gdfan(3,n1atom)=gdfan(3,n1atom)+t1dz
+
+ do j=ishiftca+1,ilastca
+ gdfan(1,j)=gdfan(1,j)+t2dx(j)
+ gdfan(2,j)=gdfan(2,j)+t2dy(j)
+ gdfan(3,j)=gdfan(3,j)+t2dz(j)
+ enddo
+c energy calculation
+
+ enenei=enenei+enei
+
+ enddo
+
+ edfanei=enenei
+
+ return
+ end
+
+ subroutine edfab(edfabeta)
+
+ implicit real*8 (a-h,o-z)
+
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.DFA'
+
+ real*8 PAI
+ parameter(PAI=3.14159265358979323846D0)
+ parameter (maxca=800)
+C sheet variables
+ real*8 bx(maxres),by(maxres),bz(maxres)
+ real*8 vbet(maxres,maxres)
+ real*8 shetfx(maxres),shetfy(maxres),shetfz(maxres)
+ real*8 shefx(maxres,12),shefy(maxres,12),shefz(maxres,12)
+ real*8 vbeta,vbetp,vbetm
+ real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb,
+ & c00,s00,ulnex,dnex
+ real*8 dp45,dm45,w_beta
+
+ real*8 cph(maxca),cth(maxca)
+ real*8 atx(maxca),aty(maxca),atz(maxca)
+ real*8 atmx(maxca),atmy(maxca),atmz(maxca)
+ real*8 atmmx(maxca),atmmy(maxca),atmmz(maxca)
+ real*8 atm3x(maxca),atm3y(maxca),atm3z(maxca)
+ real*8 sth(maxca)
+ real*8 astx(maxca),asty(maxca),astz(maxca)
+ real*8 astmx(maxca),astmy(maxca),astmz(maxca)
+ real*8 astmmx(maxca),astmmy(maxca),astmmz(maxca)
+ real*8 astm3x(maxca),astm3y(maxca),astm3z(maxca)
+
+ real*8 atxnum(maxca),atynum(maxca),atznum(maxca),
+ & astxnum(maxca),astynum(maxca),astznum(maxca),
+ & atmxnum(maxca),atmynum(maxca),atmznum(maxca),
+ & astmxnum(maxca),astmynum(maxca),astmznum(maxca),
+ & atmmxnum(maxca),atmmynum(maxca),atmmznum(maxca),
+ & astmmxnum(maxca),astmmynum(maxca),astmmznum(maxca),
+ & atm3xnum(maxca),atm3ynum(maxca),atm3znum(maxca),
+ & astm3xnum(maxca),astm3ynum(maxca),astm3znum(maxca),
+ & cth_orig(maxca),sth_orig(maxca)
+
+ common /sheca/ bx,by,bz
+ common /shee/ vbeta,vbet,vbetp,vbetm
+ common /shetf/ shetfx,shetfy,shetfz
+ common /shef/ shefx, shefy, shefz
+ common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb,
+ & c00,s00,ulnex,dnex
+ common /sheconst/ dp45,dm45,w_beta
+
+ common /angvt/ atx,aty,atz,atmx,atmy,atmz,atmmx,atmmy,
+ $ atmmz,atm3x,atm3y,atm3z
+ common /angvt2/ astx,asty,astz,astmx,astmy,astmz,astmmx,astmmy,
+ $ astmmz,astm3x,astm3y,astm3z
+
+ common /coscos/ cph,cth
+ common /sinsin/ sth
+
+C End of sheet variables
+
+ integer i,j
+ double precision enebet
+
+ enebet=0.0d0
+c bx=0.0d0;by=0.0d0;bz=0.0d0
+c shetfx=0.0d0;shetfy=0.0d0;shetfz=0.0d0
+
+ gdfab=0.0d0
+
+ do i=ishiftca+1,ilastca
+ bx(i-ishiftca)=c(1,i)
+ by(i-ishiftca)=c(2,i)
+ bz(i-ishiftca)=c(3,i)
+ enddo
+
+c do i=1,ilastca-ishiftca
+c read(99,*) bx(i),by(i),bz(i)
+c enddo
+c close(99)
+
+ dca=0.25d0**2
+ dshe=0.3d0**2
+ ULHB=5.0D0
+ ULDHB=5.0D0
+ ULNEX=COS(60.0D0/180.0D0*PAI)
+
+ DLHB=1.0D0
+ DLDHB=1.0D0
+
+ DNEX=0.3D0**2
+
+ C00=COS((1.0D0+10.0D0/180.0D0)*PAI)
+ S00=SIN((1.0D0+10.0D0/180.0D0)*PAI)
+
+ W_BETA=0.5D0
+ DP45=W_BETA
+ DM45=W_BETA
+
+C END OF INITIALIZATION
+
+ nca=ilastca-ishiftca
+
+ call angvectors(nca)
+ call sheetforce(nca,wshet)
+
+c end of sheet energy and force
+
+ do j=1,nca
+ shetfx(j)=shetfx(j)*beta_inc
+ shetfy(j)=shetfy(j)*beta_inc
+ shetfz(j)=shetfz(j)*beta_inc
+c write(*,*)'SHETF:',shetfx(j),shetfy(j),shetfz(j)
+ enddo
+
+ vbeta=vbeta*beta_inc
+ enebet=vbeta
+ edfabeta=enebet
+
+ do j=1,nca
+ gdfab(1,j+ishiftca)=gdfab(1,j+ishiftca)-shetfx(j)
+ gdfab(2,j+ishiftca)=gdfab(2,j+ishiftca)-shetfy(j)
+ gdfab(3,j+ishiftca)=gdfab(3,j+ishiftca)-shetfz(j)
+ enddo
+
+#ifdef DEBUG1
+ do j=1,nca
+ write(*,'(5x,i5,10x,3f10.5)') j,bx(j),by(j),bz(j)
+ enddo
+
+
+ gdfab=0
+ dinc=0.001
+ do j=1,nca
+ cth_orig(j)=cth(j)
+ sth_orig(j)=sth(j)
+ enddo
+
+ do j=1,nca
+
+ bx(j)=bx(j)+dinc
+ call angvectors(nca)
+ bx(j)=bx(j)-2*dinc
+ call angvectors(nca)
+ atxnum(j)=0.5*(cth(j)-cth_orig(j))/dinc
+ astxnum(j)=0.5*(sth(j)-sth_orig(j))/dinc
+ if (j.gt.1) then
+ atmxnum(j)=0.5*(cth(j-1)-cth_orig(j-1))/dinc
+ astmxnum(j)=0.5*(sth(j-1)-sth_orig(j-1))/dinc
+ endif
+ if (j.gt.2) then
+ atmmxnum(j)=0.5*(cth(j-2)-cth_orig(j-2))/dinc
+ astmmxnum(j)=0.5*(sth(j-2)-sth_orig(j-2))/dinc
+ endif
+ if (j.gt.3) then
+ atm3xnum(j)=0.5*(cth(j-3)-cth_orig(j-3))/dinc
+ astm3xnum(j)=0.5*(sth(j-3)-sth_orig(j-3))/dinc
+ endif
+ bx(j)=bx(j)+dinc
+ by(j)=by(j)+dinc
+ call angvectors(nca)
+ by(j)=by(j)-2*dinc
+ call angvectors(nca)
+ by(j)=by(j)+dinc
+ atynum(j)=0.5*(cth(j)-cth_orig(j))/dinc
+ astynum(j)=0.5*(sth(j)-sth_orig(j))/dinc
+ if (j.gt.1) then
+ atmynum(j)=0.5*(cth(j-1)-cth_orig(j-1))/dinc
+ astmynum(j)=0.5*(sth(j-1)-sth_orig(j-1))/dinc
+ endif
+ if (j.gt.2) then
+ atmmynum(j)=0.5*(cth(j-2)-cth_orig(j-2))/dinc
+ astmmynum(j)=0.5*(sth(j-2)-sth_orig(j-2))/dinc
+ endif
+ if (j.gt.3) then
+ atm3ynum(j)=0.5*(cth(j-3)-cth_orig(j-3))/dinc
+ astm3ynum(j)=0.5*(sth(j-3)-sth_orig(j-3))/dinc
+ endif
+
+ bz(j)=bz(j)+dinc
+ call angvectors(nca)
+ bz(j)=bz(j)-2*dinc
+ call angvectors(nca)
+ bz(j)=bz(j)+dinc
+
+ atznum(j)=0.5*(cth(j)-cth_orig(j))/dinc
+ astznum(j)=0.5*(sth(j)-sth_orig(j))/dinc
+ if (j.gt.1) then
+ atmznum(j)=0.5*(cth(j-1)-cth_orig(j-1))/dinc
+ astmznum(j)=0.5*(sth(j-1)-sth_orig(j-1))/dinc
+ endif
+ if (j.gt.2) then
+ atmmznum(j)=0.5*(cth(j-2)-cth_orig(j-2))/dinc
+ astmmznum(j)=0.5*(sth(j-2)-sth_orig(j-2))/dinc
+ endif
+ if (j.gt.3) then
+ atm3znum(j)=0.5*(cth(j-3)-cth_orig(j-3))/dinc
+ astm3znum(j)=0.5*(sth(j-3)-sth_orig(j-3))/dinc
+ endif
+
+ enddo
+
+ do i=1,nca
+ write (*,'(2i5,a2,6f10.5)')
+ & i,1,"x",atxnum(i),atx(i),atxnum(i)/atx(i),
+ & astxnum(i),astx(i),astxnum(i)/astx(i),
+ & i,1,"y",atynum(i),aty(i),atynum(i)/aty(i),
+ & astynum(i),asty(i),astynum(i)/asty(i),
+ & i,1,"z",atznum(i),atz(i),atznum(i)/atz(i),
+ & astznum(i),astz(i),astznum(i)/astz(i),
+ & i,2,"x",atmxnum(i),atmx(i),atmxnum(i)/atmx(i),
+ & astmxnum(i),astmx(i),astmxnum(i)/astmx(i),
+ & i,2,"y",atmynum(i),atmy(i),atmynum(i)/atmy(i),
+ & astmynum(i),astmy(i),astmynum(i)/astmy(i),
+ & i,2,"z",atmznum(i),atmz(i),atmznum(i)/atmz(i),
+ & astmznum(i),astmz(i),astmznum(i)/astmz(i),
+ & i,3,"x",atmmxnum(i),atmmx(i),atmmxnum(i)/atmmx(i),
+ & astmmxnum(i),astmmx(i),astmmxnum(i)/astmmx(i),
+ & i,3,"y",atmmynum(i),atmmy(i),atmmynum(i)/atmmy(i),
+ & astmmynum(i),astmmy(i),astmmynum(i)/astmmy(i),
+ & i,3,"z",atmmznum(i),atmmz(i),atmmznum(i)/atmmz(i),
+ & astmmznum(i),astmmz(i),astmmznum(i)/astmmz(i),
+ & i,4,"x",atm3xnum(i),atm3x(i),atm3xnum(i)/atm3x(i),
+ & astm3xnum(i),astm3x(i),astm3xnum(i)/astm3x(i),
+ & i,4,"y",atm3ynum(i),atm3y(i),atm3ynum(i)/atm3y(i),
+ & astm3ynum(i),astm3y(i),astm3ynum(i)/astm3y(i),
+ & i,4,"z",atm3znum(i),atm3z(i),atm3znum(i)/atm3z(i),
+ & astm3znum(i),astm3z(i),astm3znum(i)/astm3z(i),
+ & i,0," ",cth_orig(i),sth_orig(i)
+ enddo
+
+
+ gdfab=0
+ dinc=0.001
+
+ do j=1,nca
+
+ bx(j)=bx(j)+dinc
+ call angvectors(nca)
+ call sheetforce(nca,wshet)
+ vbeta1=vbeta*beta_inc
+ bx(j)=bx(j)-2*dinc
+ call angvectors(nca)
+ call sheetforce(nca,wshet)
+ vbeta2=vbeta*beta_inc
+ gdfab(1,j)=(vbeta2-vbeta1)/dinc/2
+ bx(j)=bx(j)+dinc
+
+ by(j)=by(j)+dinc
+ call angvectors(nca)
+ call sheetforce(nca,wshet)
+ vbeta1=vbeta*beta_inc
+ by(j)=by(j)-2*dinc
+ call angvectors(nca)
+ call sheetforce(nca,wshet)
+ vbeta2=vbeta*beta_inc
+ gdfab(2,j)=(vbeta2-vbeta1)/dinc/2
+ by(j)=by(j)+dinc
+
+ bz(j)=bz(j)+dinc
+ call angvectors(nca)
+ call sheetforce(nca,wshet)
+ vbeta1=vbeta*beta_inc
+ bz(j)=bz(j)-2*dinc
+ call angvectors(nca)
+ call sheetforce(nca,wshet)
+ vbeta2=vbeta*beta_inc
+ gdfab(3,j)=(vbeta2-vbeta1)/dinc/2
+ bz(j)=bz(j)+dinc
+
+
+ enddo
+
+
+ call angvectors(nca)
+ call sheetforce(nca,wshet)
+ do j=1,nca
+ shetfx(j)=shetfx(j)*beta_inc
+ shetfy(j)=shetfy(j)*beta_inc
+ shetfz(j)=shetfz(j)*beta_inc
+ enddo
+
+
+ write(*,*) 'xyz analytical and numerical gradient'
+ do j=1,nca
+ write(*,'(5x,i5,10x,6f10.5)') j,-shetfx(j),-shetfy(j),-shetfz(j)
+ & ,(-gdfab(i,j),i=1,3)
+ enddo
+
+ do j=1,nca
+ write(*,'(5x,i5,10x,3f10.2)') j,shetfx(j)/gdfab(1,j),
+ & shetfy(j)/gdfab(2,j),
+ & shetfz(j)/gdfab(3,j)
+ enddo
+
+ stop
+#endif
+
+ return
+ end
+C-------------------------------------------------------------------------------
+ subroutine angvectors(nca)
+c implicit real*4(a-h,o-z)
+ implicit none
+ integer nca
+ integer maxca
+ parameter(maxca=800)
+ real*8 pai,zero
+ parameter(PAI=3.14159265358979323846D0,zero=0.0d0)
+
+ real*8 bx(maxca),by(maxca),bz(maxca)
+ real*8 dis(maxca,maxca)
+ real*8 apx(maxca),apy(maxca),apz(maxca)
+ real*8 apmx(maxca),apmy(maxca),apmz(maxca)
+ real*8 apmmx(maxca),apmmy(maxca),apmmz(maxca)
+ real*8 apm3x(maxca),apm3y(maxca),apm3z(maxca)
+ real*8 atx(maxca),aty(maxca),atz(maxca)
+ real*8 atmx(maxca),atmy(maxca),atmz(maxca)
+ real*8 atmmx(maxca),atmmy(maxca),atmmz(maxca)
+ real*8 atm3x(maxca),atm3y(maxca),atm3z(maxca)
+ real*8 astx(maxca),asty(maxca),astz(maxca)
+ real*8 astmx(maxca),astmy(maxca),astmz(maxca)
+ real*8 astmmx(maxca),astmmy(maxca),astmmz(maxca)
+ real*8 astm3x(maxca),astm3y(maxca),astm3z(maxca)
+ real*8 sth(maxca)
+ real*8 cph(maxca),cth(maxca)
+ real*8 ulcos(maxca)
+ real*8 p,c
+ integer i, ip, ipp, ip3, j
+ real*8 rx(maxca, maxca), ry(maxca, maxca), rz(maxca, maxca)
+ real*8 rix, riy, riz, ripx, ripy, ripz, rippx, rippy, rippz
+ real*8 gix, giy, giz, gipx, gipy, gipz, gippx, gippy, gippz
+ real*8 cix, ciy, ciz, cipx, cipy, cipz
+ real*8 gpcrp_x, gpcrp_y, gpcrp_z, d_gpcrp, gpcrp__g
+ real*8 d10, d11, d12, d13, d20, d21, d22, d23, d24
+ real*8 d30, d31, d32, d33, d34, d35, d40, d41, d42, d43
+ real*8 d_gcr, d_gcr3, d_gmcrim,d_gmcrim3,dgmmcrimm,d_gmmcrimm3
+ real*8 dg, dg3, dg30, dgm, dgm3, dgmm, dgmm3, dgp, dri
+ real*8 dri3, drim, drim3, drimm, drip, dripp, g3gmm, g3rim
+ real*8 g3x, g3y, g3z, d_gmmcrimm, g3rim_,gcr__gm
+ real*8 gcr_x,gcr_y,gcr_z,ggm,ggp,gmcrim__gmm
+ real*8 gmcrim_x,gmcrim_y,gmcrim_z,gmmcrimm__gmmm
+ real*8 gmmcrimm_x,gmmcrimm_y,gmmcrimm_z,gmmgm,gmmr
+ real*8 gmmx,gmmy,gmmz,gmrp,gmx,gmy,gmz,gpx,gpy,gpz
+ real*8 grpp,gx,gy,gz
+ real*8 rim3x,rim3y,rim3z,rimmx,rimmy,rimmz,rimx,rimy,rimz
+ real*8 sd10,sd11,sd20,sd21,sd22,sd30,sd31,sd32,sd40,sd41
+ integer inb,nmax,iselect
+
+ common /sheca/ bx,by,bz
+ common /difvec/ rx, ry, rz
+ common /ulang/ ulcos
+ common /phys1/ inb,nmax,iselect
+ common /phys4/ p,c
+ common /kyori2/ dis
+ common /angvp/ apx,apy,apz,apmx,apmy,apmz,apmmx,apmmy,
+ & apmmz,apm3x,apm3y,apm3z
+ common /angvt/ atx,aty,atz,atmx,atmy,atmz,atmmx,atmmy,
+ & atmmz,atm3x,atm3y,atm3z
+ common /coscos/ cph,cth
+ common /angvt2/ astx,asty,astz,astmx,astmy,astmz,astmmx,astmmy,
+ & astmmz,astm3x,astm3y,astm3z
+ common /sinsin/ sth
+C-------------------------------------------------------------------------------
+c write(*,*) 'inside angvectors'
+C initialize
+ p=0.1d0
+ c=1.0d0
+ inb=nca
+ cph=zero; cth=zero; sth=zero
+ apx=zero;apy=zero;apz=zero;apmx=zero;apmy=zero;apmz=zero
+ apmmx=zero;apmmy=zero;apmmz=zero;apm3x=zero;apm3y=zero;apm3z=zero
+ atx=zero;aty=zero;atz=zero;atmx=zero;atmy=zero;atmz=zero
+ atmmx=zero;atmmy=zero;atmmz=zero;atm3x=zero;atm3y=zero;atm3z=zero
+ astx=zero;asty=zero;astz=zero;astmx=zero;astmy=zero;astmz=zero
+ astmmx=zero;astmmy=zero;astmmz=zero;astm3x=zero;astm3y=zero
+ astm3z=zero
+C end of initialize
+C r[x,y,z] calc and distance calculation
+ rx=zero;ry=zero;rz=zero
+
+ do i=1,inb
+ do j=1,inb
+ rx(i,j)=bx(j)-bx(i)
+ ry(i,j)=by(j)-by(i)
+ rz(i,j)=bz(j)-bz(i)
+ dis(i,j)=sqrt(rx(i,j)**2+ry(i,j)**2+rz(i,j)**2)
+c write(*,*) 'rx(i,j):',i,j,rx(i,j),bx(j),bx(i)
+c write(*,*) 'ry(i,j):',i,j,ry(i,j),by(j),by(i)
+c write(*,*) 'rz(i,j):',i,j,rz(i,j),bz(j),bz(i)
+c write(*,*) 'dis(i,j):',i,j,dis(i,j)
+ enddo
+ enddo
+c end of r[x,y,z] calc
+C cos calc
+ do i=1,inb-2
+ ip=i+1
+ ipp=i+2
+
+ if(dis(i,ip).ge.1.0e-8.and.dis(ip,ipp).ge.1.0e-8) then
+ ulcos(i)=rx(i,ip)*rx(ip,ipp)+ry(i,ip)*ry(ip,ipp)
+ $ +rz(i,ip)*rz(ip,ipp)
+ ulcos(i)=ulcos(i)/(dis(i,ip)*dis(ip,ipp))
+ endif
+ enddo
+c end of virtual bond angle
+c write(*,*) 'inside angvectors1'
+crc do i=1,inb-3
+ do i=1,inb
+ ip=i+1
+ ipp=i+2
+ ip3=i+3
+ rix=bx(ip)-bx(i)
+ riy=by(ip)-by(i)
+ riz=bz(ip)-bz(i)
+ ripx=bx(ipp)-bx(ip)
+ ripy=by(ipp)-by(ip)
+ ripz=bz(ipp)-bz(ip)
+ rippx=bx(ip3)-bx(ipp)
+ rippy=by(ip3)-by(ipp)
+ rippz=bz(ip3)-bz(ipp)
+
+ gx=riy*ripz-riz*ripy
+ gy=riz*ripx-rix*ripz
+ gz=rix*ripy-riy*ripx
+ gpx=ripy*rippz-ripz*rippy
+ gpy=ripz*rippx-ripx*rippz
+ gpz=ripx*rippy-ripy*rippx
+ gpcrp_x=gpy*ripz-gpz*ripy
+ gpcrp_y=gpz*ripx-gpx*ripz
+ gpcrp_z=gpx*ripy-gpy*ripx
+ d_gpcrp=sqrt(gpcrp_x**2+gpcrp_y**2+gpcrp_z**2)
+ gpcrp__g=gx*gpy*ripz+gpx*ripy*gz+ripx*gpz*gy
+ & -gz*gpy*ripx-gpz*ripy*gx-ripz*gpx*gy
+
+ if(i.ge.2) then
+ rimx=bx(i)-bx(i-1)
+ rimy=by(i)-by(i-1)
+ rimz=bz(i)-bz(i-1)
+ gmx=rimy*riz-rimz*riy
+ gmy=rimz*rix-rimx*riz
+ gmz=rimx*riy-rimy*rix
+ dgm=sqrt(gmx**2+gmy**2+gmz**2)
+ dgm3=dgm**3
+ ggm=gmx*gx+gmy*gy+gmz*gz
+ gmrp=gmx*ripx+gmy*ripy+gmz*ripz
+ drim=dis(i-1,i)
+ drim3=drim**3
+ gcr_x=gy*riz-gz*riy
+ gcr_y=gz*rix-gx*riz
+ gcr_z=gx*riy-gy*rix
+ d_gcr=sqrt(gcr_x**2+gcr_y**2+gcr_z**2)
+ d_gcr3=d_gcr**3
+ gcr__gm=gmx*gy*riz+gx*riy*gmz+rix*gz*gmy
+ & -gmz*gy*rix-gz*riy*gmx-riz*gx*gmy
+ endif
+c write(*,*) 'inside angvectors2'
+ if(i.ge.3) then
+ rimmx=bx(i-1)-bx(i-2)
+ rimmy=by(i-1)-by(i-2)
+ rimmz=bz(i-1)-bz(i-2)
+ drimm=dis(i-2,i-1)
+ gmmx=rimmy*rimz-rimmz*rimy
+ gmmy=rimmz*rimx-rimmx*rimz
+ gmmz=rimmx*rimy-rimmy*rimx
+ dgmm=sqrt(gmmx**2+gmmy**2+gmmz**2)
+ dgmm3=dgmm**3
+ gmmgm=gmmx*gmx+gmmy*gmy+gmmz*gmz
+ gmmr=gmmx*rix+gmmy*riy+gmmz*riz
+ gmcrim_x=gmy*rimz-gmz*rimy
+ gmcrim_y=gmz*rimx-gmx*rimz
+ gmcrim_z=gmx*rimy-gmy*rimx
+ d_gmcrim=sqrt(gmcrim_x**2+gmcrim_y**2+gmcrim_z**2)
+ d_gmcrim3=d_gmcrim**3
+ gmcrim__gmm=gmmx*gmy*rimz+gmx*rimy*gmmz+rimx*gmz*gmmy
+ & -gmmz*gmy*rimx-gmz*rimy*gmmx-rimz*gmx*gmmy
+ endif
+
+ if(i.ge.4) then
+ rim3x=bx(i-2)-bx(i-3)
+ rim3y=by(i-2)-by(i-3)
+ rim3z=bz(i-2)-bz(i-3)
+ g3x=rim3y*rimmz-rim3z*rimmy
+ g3y=rim3z*rimmx-rim3x*rimmz
+ g3z=rim3x*rimmy-rim3y*rimmx
+ dg30=sqrt(g3x**2+g3y**2+g3z**2)
+ g3gmm=g3x*gmmx+g3y*gmmy+g3z*gmmz
+ g3rim_=g3x*rimx+g3y*rimy+g3z*rimz
+cc**********************************************************************
+ gmmcrimm_x=gmmy*rimmz-gmmz*rimmy
+ gmmcrimm_y=gmmz*rimmx-gmmx*rimmz
+ gmmcrimm_z=gmmx*rimmy-gmmy*rimmx
+ d_gmmcrimm=sqrt(gmmcrimm_x**2+gmmcrimm_y**2+gmmcrimm_z**2)
+ d_gmmcrimm3=d_gmmcrimm**3
+ gmmcrimm__gmmm=g3x*gmmy*rimmz+gmmx*rimmy*g3z+rimmx*gmmz*g3y
+ & -g3z*gmmy*rimmx-gmmz*rimmy*g3x-rimmz*gmmx*g3y
+ endif
+
+ dri=dis(i,i+1)
+ drip=dis(i+1,i+2)
+ dripp=dis(i+2,i+3)
+ dri3=dri**3
+ dg=sqrt(gx**2+gy**2+gz**2)
+ dgp=sqrt(gpx**2+gpy**2+gpz**2)
+ dg3=dg**3
+
+ ggp=gx*gpx+gy*gpy+gz*gpz
+ grpp=gx*rippx+gy*rippy+gz*rippz
+
+ if(dg.gt.0.0D0.and.dripp.gt.0.0D0.and.dgp.gt.0.0D0
+ & .and.d_gpcrp.gt.0.0D0) then
+ cph(i)=grpp/dg/dripp
+ cth(i)=ggp/dg/dgp
+ sth(i)=gpcrp__g/d_gpcrp/dg
+ else
+c
+ cph(i)=1.0D0
+ cth(i)=1.0D0
+ sth(i)=0.0D0
+ endif
+
+c write(*,*) 'inside angvectors3'
+
+ if(dgp.gt.0.0D0.and.dg3.gt.0.0D0
+ & .and.dripp.gt.0.0D0.and.d_gpcrp.gt.0.0D0) then
+ d10=1.0D0/(dg*dgp)
+ d11=ggp/(dg3*dgp)
+ d12=1.0D0/(dg*dripp)
+ d13=grpp/(dg3*dripp)
+ sd10=1.0D0/(d_gpcrp*dg)
+ sd11=gpcrp__g/(d_gpcrp*dg3)
+ else
+ d10=0.0D0
+ d11=0.0D0
+ d12=0.0D0
+ d13=0.0D0
+ sd10=0.0D0
+ sd11=0.0D0
+ endif
+
+ atx(i)=(ripz*gpy-ripy*gpz)*d10
+ & -(gy*ripz-gz*ripy)*d11
+ aty(i)=(ripx*gpz-ripz*gpx)*d10
+ & -(gz*ripx-gx*ripz)*d11
+ atz(i)=(ripy*gpx-ripx*gpy)*d10
+ & -(gx*ripy-gy*ripx)*d11
+ astx(i)=sd10*(-gpx*ripy**2+ripx*gpz*ripz
+ & +ripy*gpy*ripx-gpx*ripz**2)
+ & -sd11*(gy*ripz-gz*ripy)
+ asty(i)=sd10*(-gpy*ripz**2+gpx*ripy*ripx
+ & -gpy*ripx**2+gpz*ripy*ripz)
+ & -sd11*(-gx*ripz+gz*ripx)
+ astz(i)=sd10*(ripy*gpy*ripz-gpz*ripx**2
+ & -gpz*ripy**2+ripz*gpx*ripx)
+ & -sd11*(gx*ripy-gy*ripx)
+ apx(i)=(ripz*rippy-ripy*rippz)*d12
+ & -(gy*ripz-gz*ripy)*d13
+ apy(i)=(ripx*rippz-ripz*rippx)*d12
+ & -(gz*ripx-gx*ripz)*d13
+ apz(i)=(ripy*rippx-ripx*rippy)*d12
+ & -(gx*ripy-gy*ripx)*d13
+
+ if(i.ge.2) then
+ cix=bx(ip)-bx(i-1)
+ ciy=by(ip)-by(i-1)
+ ciz=bz(ip)-bz(i-1)
+ cipx=bx(ipp)-bx(i)
+ cipy=by(ipp)-by(i)
+ cipz=bz(ipp)-bz(i)
+ ripx=bx(ipp)-bx(ip)
+ ripy=by(ipp)-by(ip)
+ ripz=bz(ipp)-bz(ip)
+ if(dgm3.gt.0.0D0.and.dg3.gt.0.0D0.and.drip.gt.0.0D0
+ & .and.d_gcr3.gt.0.0D0) then
+ d20=1.0D0/(dg*dgm)
+ d21=ggm/(dgm3*dg)
+ d22=ggm/(dgm*dg3)
+ d23=1.0D0/(dgm*drip)
+ d24=gmrp/(dgm3*drip)
+ sd20=1.0D0/(d_gcr*dgm)
+ sd21=gcr__gm/(d_gcr3*dgm)
+ sd22=gcr__gm/(d_gcr*dgm3)
+ else
+ d20=0.0D0
+ d21=0.0D0
+ d22=0.0D0
+ d23=0.0D0
+ d24=0.0D0
+ sd20=0.0D0
+ sd21=0.0D0
+ sd22=0.0D0
+ endif
+ atmx(i)=(ciy*gz-ciz*gy-ripy*gmz+ripz*gmy)*d20
+ & -(ciy*gmz-ciz*gmy)*d21
+ & +(ripy*gz-ripz*gy)*d22
+ atmy(i)=(ciz*gx-cix*gz-ripz*gmx+ripx*gmz)*d20
+ & -(ciz*gmx-cix*gmz)*d21
+ & +(ripz*gx-ripx*gz)*d22
+ atmz(i)=(cix*gy-ciy*gx-ripx*gmy+ripy*gmx)*d20
+ & -(cix*gmy-ciy*gmx)*d21
+ & +(ripx*gy-ripy*gx)*d22
+cc**********************************************************************
+ astmx(i)=sd20*(gmx*ripz*riz+gx*riy*ciy-gz*gmy
+ & -rix*ripy*gmy-rix*gz*ciz-ciy*gy*rix-gmz*ripz*rix
+ & +gmz*gy+ripy*riy*gmx+riz*gx*ciz)
+ & -sd21*(gcr_x*(ripz*riz+ripy*riy)+gcr_y*(-ripy*rix-gz)
+ & +gcr_z*(-ripz*rix+gy))
+ & -sd22*(-gmy*ciz+gmz*ciy)
+
+ astmy(i)=sd20*(ciz*gy*riz-ripz*riy*gmz-gx*gmz-gx*riy*cix
+ & +rix*ripx*gmy+cix*gy*rix-ripx*riy*gmx+gz*gmx-gz*riy*ciz
+ & +riz*ripz*gmy)
+ & -sd21*(gcr_x*(-ripx*riy+gz)+gcr_y*(ripx*rix+ripz*riz)
+ & -gcr_z*(ripz*riy+gx))
+ & -sd22*(gmx*ciz-gmz*cix)
+
+ astmz(i)=sd20*(-ciy*gy*riz-gmx*ripx*riz-gmx*gy+ripy*riy*gmz
+ & +rix*gz*cix+gmz*ripx*rix+gz*riy*ciy+gx*gmy-riz*ripy*gmy
+ & -riz*gx*cix)
+ & -sd21*(gcr_x*(-ripx*riz-gy)+gcr_y*(-ripy*riz+gx)
+ & +gcr_z*(ripy*riy+ripx*rix))
+ & -sd22*(-gmx*ciy+gmy*cix)
+cc**********************************************************************
+ apmx(i)=(ciy*ripz-ripy*ciz)*d23
+ & -(ciy*gmz-ciz*gmy)*d24
+ apmy(i)=(ciz*ripx-ripz*cix)*d23
+ & -(ciz*gmx-cix*gmz)*d24
+ apmz(i)=(cix*ripy-ripx*ciy)*d23
+ & -(cix*gmy-ciy*gmx)*d24
+ endif
+
+ if(i.ge.3) then
+ if(dgm3.gt.0.0D0.and.dgmm3.gt.0.0D0.and.dri3.gt.0.0D0
+ & .and.d_gmcrim3.gt.0.0D0) then
+ d30=1.0D0/(dgm*dgmm)
+ d31=gmmgm/(dgm3*dgmm)
+ d32=gmmgm/(dgm*dgmm3)
+ d33=1.0D0/(dgmm*dri)
+ d34=gmmr/(dgmm3*dri)
+ d35=gmmr/(dgmm*dri3)
+ sd30=1.0D0/(d_gmcrim*dgmm)
+ sd31=gmcrim__gmm/(d_gmcrim3*dgmm)
+ sd32=gmcrim__gmm/(d_gmcrim*dgmm3)
+ else
+ d30=0.0D0
+ d31=0.0D0
+ d32=0.0D0
+ d33=0.0D0
+ d34=0.0D0
+ d35=0.0D0
+ sd30=0.0D0
+ sd31=0.0D0
+ sd32=0.0D0
+ endif
+
+c write(*,*) 'inside angvectors4'
+
+cc**********************************************************************
+ atmmx(i)=(ciy*gmmz-ciz*gmmy-rimmy*gmz+rimmz*gmy)*d30
+ & -(ciy*gmz-ciz*gmy)*d31
+ & -(gmmy*rimmz-gmmz*rimmy)*d32
+ atmmy(i)=(ciz*gmmx-cix*gmmz-rimmz*gmx+rimmx*gmz)*d30
+ & -(ciz*gmx-cix*gmz)*d31
+ & -(gmmz*rimmx-gmmx*rimmz)*d32
+ atmmz(i)=(cix*gmmy-ciy*gmmx-rimmx*gmy+rimmy*gmx)*d30
+ & -(cix*gmy-ciy*gmx)*d31
+ & -(gmmx*rimmy-gmmy*rimmx)*d32
+cc**********************************************************************
+ astmmx(i)=sd30*(-gmmx*ciz*rimz-gmx*rimy*rimmy
+ & +gmz*gmmy+rimx*ciy*gmmy+rimx*gmz*rimmz
+ & +rimmy*gmy*rimx+gmmz*ciz*rimx-gmmz*gmy
+ & -ciy*rimy*gmmx-rimz*gmx*rimmz)
+ & -sd31*(gmcrim_x*(-ciz*rimz-ciy*rimy)
+ & +gmcrim_y*(ciy*rimx+gmz)+gmcrim_z*(ciz*rimx-gmy))
+ & -sd32*(gmmy*rimmz-rimmy*gmmz)
+
+ astmmy(i)=sd30*(-rimmz*gmy*rimz+ciz*rimy*gmmz
+ & +gmx*gmmz+gmx*rimy*rimmx-rimx*cix*gmmy
+ & -rimmx*gmy*rimx+cix*rimy*gmmx-gmz*gmmx
+ & +gmz*rimy*rimmz-rimz*ciz*gmmy)
+ & -sd31*(gmcrim_x*(cix*rimy-gmz)
+ & +gmcrim_y*(-cix*rimx-ciz*rimz)+gmcrim_z*(ciz*rimy+gmx))
+ & -sd32*(-gmmx*rimmz+rimmx*gmmz)
+
+ astmmz(i)=sd30*(rimmy*gmy*rimz+gmmx*cix*rimz
+ & +gmmx*gmy-ciy*rimy*gmmz-rimx*gmz*rimmx
+ & -gmmz*cix*rimx-gmz*rimy*rimmy-gmx*gmmy
+ & +rimz*ciy*gmmy+rimz*gmx*rimmx)
+ & -sd31*(gmcrim_x*(cix*rimz+gmy)
+ & +gmcrim_y*(ciy*rimz-gmx)+gmcrim_z*(-ciy*rimy-cix*rimx))
+ & -sd32*(gmmx*rimmy-rimmx*gmmy)
+c**********************************************************************
+ apmmx(i)=(riy*rimmz-riz*rimmy-gmmx)*d33
+ & -(gmmy*rimmz-gmmz*rimmy)*d34
+ & +rix*d35
+ apmmy(i)=(riz*rimmx-rix*rimmz-gmmy)*d33
+ & -(gmmz*rimmx-gmmx*rimmz)*d34
+ & +riy*d35
+ apmmz(i)=(rix*rimmy-riy*rimmx-gmmz)*d33
+ & -(gmmx*rimmy-gmmy*rimmx)*d34
+ & +riz*d35
+ endif
+
+ if(i.ge.4) then
+ if(dg30.gt.0.0D0.and.dgmm3.gt.0.0D0
+ & .and.drim3.gt.0.0D0
+ & .and.d_gmmcrimm3.gt.0.0D0) then
+ d40=1.0D0/(dg30*dgmm)
+ d41=g3gmm/(dg30*dgmm3)
+ d42=1.0D0/(dg30*drim)
+ d43=g3rim_/(dg30*drim3)
+ sd40=1.0D0/(dg30*d_gmmcrimm)
+ sd41=gmmcrimm__gmmm/(d_gmmcrimm3*dg30)
+ else
+ d40=0.0D0
+ d41=0.0D0
+ d42=0.0D0
+ d43=0.0D0
+ sd40=0.0D0
+ sd41=0.0D0
+ endif
+ atm3x(i)=(g3y*rimmz-g3z*rimmy)*d40
+ & -(gmmy*rimmz-gmmz*rimmy)*d41
+ atm3y(i)=(g3z*rimmx-g3x*rimmz)*d40
+ & -(gmmz*rimmx-gmmx*rimmz)*d41
+ atm3z(i)=(g3x*rimmy-g3y*rimmx)*d40
+ & -(gmmx*rimmy-gmmy*rimmx)*d41
+cc**********************************************************************
+ astm3x(i)=sd40*(g3x*rimmz**2-rimmx*rimmy*g3y
+ & -g3z*rimmz*rimmx+rimmy**2*g3x)
+ & -sd41*(gmmcrimm_x*(rimmz**2+rimmy**2)
+ & -gmmcrimm_y*rimmy*rimmx-gmmcrimm_z*rimmz*rimmx)
+
+ astm3y(i)=sd40*(-rimmz*rimmy*g3z+rimmx**2*g3y
+ & -rimmx*rimmy*g3x+rimmz**2*g3y)
+ & -sd41*(-gmmcrimm_x*rimmx*rimmy
+ & +gmmcrimm_y*(rimmx**2+rimmz**2)-gmmcrimm_z*rimmz*rimmy)
+
+c & +gmmcrimm_y*(rimmx**2+rimmz**2)-gmmcrimm_z*rimmz*rimmx)
+
+ astm3z(i)=sd40*(-g3x*rimmx*rimmz+rimmy**2*g3z
+ & +g3z*rimmx**2-rimmz*rimmy*g3y)
+ & -sd41*(-gmmcrimm_x*rimmx*rimmz-gmmcrimm_y*rimmy*rimmz
+ & +gmmcrimm_z*(rimmy**2+rimmx**2))
+c**********************************************************************
+ apm3x(i)=g3x*d42-rimx*d43
+ apm3y(i)=g3y*d42-rimy*d43
+ apm3z(i)=g3z*d42-rimz*d43
+ endif
+ enddo
+c*******************************************************************************
+
+c write(*,*) 'inside angvectors5'
+
+c do i=inb-2,inb
+ do i=1,0
+ rimx=bx(i)-bx(i-1)
+ rimy=by(i)-by(i-1)
+ rimz=bz(i)-bz(i-1)
+ rimmx=bx(i-1)-bx(i-2)
+ rimmy=by(i-1)-by(i-2)
+ rimmz=bz(i-1)-bz(i-2)
+ rim3x=bx(i-2)-bx(i-3)
+ rim3y=by(i-2)-by(i-3)
+ rim3z=bz(i-2)-bz(i-3)
+ gmmx=rimmy*rimz-rimmz*rimy
+ gmmy=rimmz*rimx-rimmx*rimz
+ gmmz=rimmx*rimy-rimmy*rimx
+ g3x=rim3y*rimmz-rim3z*rimmy
+ g3y=rim3z*rimmx-rim3x*rimmz
+ g3z=rim3x*rimmy-rim3y*rimmx
+
+ dg30=sqrt(g3x**2+g3y**2+g3z**2)
+ g3gmm=g3x*gmmx+g3y*gmmy+g3z*gmmz
+ dgmm=sqrt(gmmx**2+gmmy**2+gmmz**2)
+ dgmm3=dgmm**3
+ drim=dis(i-1,i)
+ drimm=dis(i-2,i-1)
+ drim3=drim**3
+ g3rim_=g3x*rimx+g3y*rimy+g3z*rimz
+cc**********************************************************************
+ gmmcrimm_x=gmmy*rimmz-gmmz*rimmy
+ gmmcrimm_y=gmmz*rimmx-gmmx*rimmz
+ gmmcrimm_z=gmmx*rimmy-gmmy*rimmx
+ d_gmmcrimm=sqrt(gmmcrimm_x**2+gmmcrimm_y**2+gmmcrimm_z**2)
+ d_gmmcrimm3=d_gmmcrimm**3
+ gmmcrimm__gmmm=g3x*gmmy*rimmz+gmmx*rimmy*g3z+rimmx*gmmz*g3y
+ & -g3z*gmmy*rimmx-gmmz*rimmy*g3x-rimmz*gmmx*g3y
+
+ if(dg30.gt.0.0D0.and.dgmm3.gt.0.0D0
+ & .and.drim3.gt.0.0D0
+ & .and.d_gmmcrimm3.gt.0.0D0) then
+ d40=1.0D0/(dg30*dgmm)
+ d41=g3gmm/(dg30*dgmm3)
+ d42=1.0D0/(dg30*drim)
+ d43=g3rim_/(dg30*drim3)
+ sd40=1.0D0/(dg30*d_gmmcrimm)
+ sd41=gmmcrimm__gmmm/(d_gmmcrimm3*dg30)
+ else
+ d40=0.0D0
+ d41=0.0D0
+ d42=0.0D0
+ d43=0.0D0
+ sd40=0.0D0
+ sd41=0.0D0
+ endif
+ atm3x(i)=(g3y*rimmz-g3z*rimmy)*d40
+ & -(gmmy*rimmz-gmmz*rimmy)*d41
+ atm3y(i)=(g3z*rimmx-g3x*rimmz)*d40
+ & -(gmmz*rimmx-gmmx*rimmz)*d41
+ atm3z(i)=(g3x*rimmy-g3y*rimmx)*d40
+ & -(gmmx*rimmy-gmmy*rimmx)*d41
+cc**********************************************************************
+ astm3x(i)=sd40*(g3x*rimmz**2-rimmx*rimmy*g3y
+ & -g3z*rimmz*rimmx+rimmy**2*g3x)
+ & -sd41*(gmmcrimm_x*(rimmz**2+rimmy**2)
+ & -gmmcrimm_y*rimmy*rimmx-gmmcrimm_z*rimmz*rimmx)
+
+ astm3y(i)=sd40*(-rimmz*rimmy*g3z+rimmx**2*g3y
+ & -rimmx*rimmy*g3x+rimmz**2*g3y)
+ & -sd41*(-gmmcrimm_x*rimmx*rimmy
+ & +gmmcrimm_y*(rimmx**2+rimmz**2)-gmmcrimm_z*rimmz*rimmx)
+
+ astm3z(i)=sd40*(-g3x*rimmx*rimmz+rimmy**2*g3z
+ & +g3z*rimmx**2-rimmz*rimmy*g3y)
+ & -sd41*(-gmmcrimm_x*rimmx*rimmz-gmmcrimm_y*rimmy*rimmz
+ & +gmmcrimm_z*(rimmy**2+rimmx**2))
+cc**********************************************************************
+ apm3x(i)=g3x*d42-rimx*d43
+ apm3y(i)=g3y*d42-rimy*d43
+ apm3z(i)=g3z*d42-rimz*d43
+
+ if(i.le.inb-1) then
+ ip=i+1
+ rix=bx(ip)-bx(i)
+ riy=by(ip)-by(i)
+ riz=bz(ip)-bz(i)
+ cix=bx(ip)-bx(i-1)
+ ciy=by(ip)-by(i-1)
+ ciz=bz(ip)-bz(i-1)
+ gmx=rimy*riz-rimz*riy
+ gmy=rimz*rix-rimx*riz
+ gmz=rimx*riy-rimy*rix
+ dgm=sqrt(gmx**2+gmy**2+gmz**2)
+ dgm3=dgm**3
+ dri=dis(i,i+1)
+ dri3=dri**3
+ gmmgm=gmmx*gmx+gmmy*gmy+gmmz+gmz
+ gmmr=gmmx*rix+gmmy*riy+gmmz*riz
+ gmcrim_x=gmy*rimz-gmz*rimy
+ gmcrim_y=gmz*rimx-gmx*rimz
+ gmcrim_z=gmx*rimy-gmy*rimx
+ d_gmcrim=sqrt(gmcrim_x**2+gmcrim_y**2+gmcrim_z**2)
+ d_gmcrim3=d_gmcrim**3
+ gmcrim__gmm=gmmx*gmy*rimz+gmx*rimy*gmmz+rimx*gmz*gmmy
+ & -gmmz*gmy*rimx-gmz*rimy*gmmx-rimz*gmx*gmmy
+
+ if(dgm3.gt.0.0D0.and.
+ & dgmm3.gt.0.0D0.and.dri3.gt.0.0D0
+ & .and.d_gmcrim3.gt.0.0D0) then
+ d30=1.0D0/(dgm*dgmm)
+ d31=gmmgm/(dgm3*dgmm)
+ d32=gmmgm/(dgm*dgmm3)
+ d33=1.0D0/(dgmm*dri)
+ d34=gmmr/(dgmm3*dri)
+ d35=gmmr/(dgmm*dri3)
+ sd30=1.0D0/(d_gmcrim*dgmm)
+ sd31=gmcrim__gmm/(d_gmcrim3*dgmm)
+ sd32=gmcrim__gmm/(d_gmcrim*dgmm3)
+
+ else
+ d30=0.0D0
+ d31=0.0D0
+ d32=0.0D0
+ d33=0.0D0
+ d34=0.0D0
+ d35=0.0D0
+ sd30=0.0D0
+ sd31=0.0D0
+ sd32=0.0D0
+ endif
+cc**********************************************************************
+ atmmx(i)=(ciy*gmmz-ciz*gmmy-rimmy*gmz+rimmz*gmy)*d30
+ & -(ciy*gmz-ciz*gmy)*d31
+ & -(gmmy*rimmz-gmmz*rimmy)*d32
+ atmmy(i)=(ciz*gmmx-cix*gmmz-rimmz*gmx+rimmx*gmz)*d30
+ & -(ciz*gmx-cix*gmz)*d31
+ & -(gmmz*rimmx-gmmx*rimmz)*d32
+ atmmz(i)=(cix*gmmy-ciy*gmmx-rimmx*gmy+rimmy*gmx)*d30
+ & -(cix*gmy-ciy*gmx)*d31
+ & -(gmmx*rimmy-gmmy*rimmx)*d32
+cc**********************************************************************
+ astmmx(i)=sd30*(-gmmx*ciz*rimz-gmx*rimy*rimmy
+ & +gmz*gmmy+rimx*ciy*gmmy+rimx*gmz*rimmz
+ & +rimmy*gmy*rimx+gmmz*ciz*rimx-gmmz*gmy
+ & -ciy*rimy*gmmx-rimz*gmx*rimmz)
+ & -sd31*(gmcrim_x*(-ciz*rimz-ciy*rimy)
+ & +gmcrim_y*(ciy*rimx+gmz)+gmcrim_z*(ciz*rimx-gmy))
+ & -sd32*(gmmy*rimmz-rimmy*gmmz)
+
+ astmmy(i)=sd30*(-rimmz*gmy*rimz+ciz*rimy*gmmz
+ & +gmx*gmmz+gmx*rimy*rimmx-rimx*cix*gmmy
+ & -rimmx*gmy*rimx+cix*rimy*gmmx-gmz*gmmx
+ & +gmz*rimy*rimmz-rimz*ciz*gmmy)
+ & -sd31*(gmcrim_x*(cix*rimy-gmz)
+ & +gmcrim_y*(-cix*rimx-ciz*rimz)+gmcrim_z*(ciz*rimy+gmx))
+ & -sd32*(-gmmx*rimmz+rimmx*gmmz)
+
+ astmmz(i)=sd30*(rimmy*gmy*rimz+gmmx*cix*rimz
+ & +gmmx*gmy-ciy*rimy*gmmz-rimx*gmz*rimmx
+ & -gmmz*cix*rimx-gmz*rimy*rimmy-gmx*gmmy
+ & +rimz*ciy*gmmy+rimz*gmx*rimmx)
+ & -sd31*(gmcrim_x*(cix*rimz+gmy)
+ & +gmcrim_y*(ciy*rimz-gmx)+gmcrim_z*(-ciy*rimy-cix*rimx))
+ & -sd32*(gmmx*rimmy-rimmx*gmmy)
+cc**********************************************************************
+ apmmx(i)=(riy*rimmz-riz*rimmy-gmmx)*d33
+ & -(gmmy*rimmz-gmmz*rimmy)*d34
+ & +rix*d35
+ apmmy(i)=(riz*rimmx-rix*rimmz-gmmy)*d33
+ & -(gmmz*rimmx-gmmx*rimmz)*d34
+ & +riy*d35
+ apmmz(i)=(rix*rimmy-riy*rimmx-gmmz)*d33
+ & -(gmmx*rimmy-gmmy*rimmx)*d34
+ & +riz*d35
+ endif
+
+c write(*,*) 'inside angvectors6'
+
+ if(i.eq.inb-2) then
+ ipp=i+2
+ ripx=bx(ipp)-bx(ip)
+ ripy=by(ipp)-by(ip)
+ ripz=bz(ipp)-bz(ip)
+ cipx=bx(ipp)-bx(i)
+ cipy=by(ipp)-by(i)
+ cipz=bz(ipp)-bz(i)
+ gx=riy*ripz-riz*ripy
+ gy=riz*ripx-rix*ripz
+ gz=rix*ripy-riy*ripx
+ ggm=gmx*gx+gmy*gy+gmz*gz
+ gmrp=gmx*ripx+gmy*ripy+gmz*ripz
+ dg=sqrt(gx**2+gy**2+gz**2)
+ dg3=dg**3
+ drip=dis(i+1,i+2)
+ gcr_x=gy*riz-gz*riy
+ gcr_y=gz*rix-gx*riz
+ gcr_z=gx*riy-gy*rix
+ d_gcr=sqrt(gcr_x**2+gcr_y**2+gcr_z**2)
+ d_gcr3=d_gcr**3
+ gcr__gm=gmx*gy*riz+gx*riy*gmz+rix*gz*gmy
+ & -gmz*gy*rix-gz*riy*gmx-riz*gx*gmy
+ if(dgm3.gt.0.0D0.and.
+ & dg3.gt.0.0D0.and.drip.gt.0.0D0.and.d_gcr3.gt.0.0D0
+ & ) then
+ d20=1.0D0/(dg*dgm)
+ d21=ggm/(dgm3*dg)
+ d22=ggm/(dgm*dg3)
+ d23=1.0D0/(dgm*drip)
+ d24=gmrp/(dgm3*drip)
+ sd20=1.0D0/(d_gcr*dgm)
+ sd21=gcr__gm/(d_gcr3*dgm)
+ sd22=gcr__gm/(d_gcr*dgm3)
+ else
+ d20=0.0D0
+ d21=0.0D0
+ d22=0.0D0
+ d23=0.0D0
+ d24=0.0D0
+ sd20=0.0D0
+ sd21=0.0D0
+ sd22=0.0D0
+ endif
+ atmx(i)=(ciy*gz-ciz*gy-ripy*gmz+ripz*gmy)*d20
+ & -(ciy*gmz-ciz*gmy)*d21
+ & +(ripy*gz-ripz*gy)*d22
+ atmy(i)=(ciz*gx-cix*gz-ripz*gmx+ripx*gmz)*d20
+ & -(ciz*gmx-cix*gmz)*d21
+ & +(ripz*gx-ripx*gz)*d22
+ atmz(i)=(cix*gy-ciy*gx-ripx*gmy+ripy*gmx)*d20
+ & -(cix*gmy-ciy*gmx)*d21
+ & +(ripx*gy-ripy*gx)*d22
+cc**********************************************************************
+ astmx(i)=sd20*(gmx*ripz*riz+gx*riy*ciy-gz*gmy
+ & -rix*ripy*gmy-rix*gz*ciz-ciy*gy*rix-gmz*ripz*rix
+ & +gmz*gy+ripy*riy*gmx+riz*gx*ciz)
+ & -sd21*(gcr_x*(ripz*riz+ripy*riy)+gcr_y*(-ripy*rix-gz)
+ & +gcr_z*(-ripz*rix+gy))
+ & -sd22*(-gmy*ciz+gmz*ciy)
+
+ astmy(i)=sd20*(ciz*gy*riz-ripz*riy*gmz-gx*gmz-gx*riy*cix
+ & +rix*ripx*gmy+cix*gy*rix-ripx*riy*gmx+gz*gmx-gz*riy*ciz
+ & +riz*ripz*gmy)
+ & -sd21*(gcr_x*(-ripx*riy+gz)+gcr_y*(ripx*rix+ripz*riz)
+ & -gcr_z*(ripz*riy+gx))
+ & -sd22*(gmx*ciz-gmz*cix)
+
+ astmz(i)=sd20*(-ciy*gy*riz-gmx*ripx*riz-gmx*gy+ripy*riy*gmz
+ & +rix*gz*cix+gmz*ripx*rix+gz*riy*ciy+gx*gmy-riz*ripy*gmy
+ & -riz*gx*cix)
+ & -sd21*(gcr_x*(-ripx*riz-gy)+gcr_y*(-ripy*riz+gx)
+ & +gcr_z*(ripy*riy+ripx*rix))
+ & -sd22*(-gmx*ciy+gmy*cix)
+cc**********************************************************************
+c
+ apmx(i)=(ciy*ripz-ripy*ciz)*d23
+ & -(ciy*gmz-ciz*gmy)*d24
+ apmy(i)=(ciz*ripx-ripz*cix)*d23
+ & -(ciz*gmx-cix*gmz)*d24
+ apmz(i)=(cix*ripy-ripx*ciy)*d23
+ & -(cix*gmy-ciy*gmx)*d24
+
+ endif
+ enddo
+
+ return
+ end
+c END of angvectors
+c-------------------------------------------------------------------------------
+C---------------------------------------------------------------------------------
+ subroutine sheetforce(nca,wshet)
+ implicit none
+C JYLEE
+c this should be matched with dfa.fcm
+ integer maxca
+ parameter(maxca=800)
+cc**********************************************************************
+ integer nca
+ integer i,k
+ integer inb,nmax,iselect
+
+c real*8 dfaexp(15001)
+
+ real*8 vbeta,vbetp,vbetm
+ real*8 shefx(maxca,12)
+ real*8 shefy(maxca,12),shefz(maxca,12)
+ real*8 shetfx(maxca),shetfy(maxca),shetfz(maxca)
+ real*8 vbet(maxca,maxca)
+ real*8 wshet(maxca,maxca)
+ real*8 bx(maxca),by(maxca),bz(maxca)
+
+ common /sheca/ bx,by,bz
+ common /phys1/ inb,nmax,iselect
+ common /shef/ shefx,shefy,shefz
+ common /shee/ vbeta,vbet,vbetp,vbetm
+ common /shetf/ shetfx,shetfy,shetfz
+
+ inb=nca
+ do i=1,inb
+ shetfx(i)=0.0D0
+ shetfy(i)=0.0D0
+ shetfz(i)=0.0D0
+ enddo
+
+ do k=1,12
+ do i=1,inb
+ shefx(i,k)=0.0D0
+ shefy(i,k)=0.0D0
+ shefz(i,k)=0.0D0
+ enddo
+ enddo
+
+ call sheetene(nca,wshet)
+ call sheetforce1
+
+ 887 format(a,1x,i6,3x,f12.8)
+ 888 format(a,1x,i4,1x,i4,3x,f12.8)
+ 889 format(a,1x,i4,3x,f12.8)
+ !write(2,*) 'coord : '
+ do i=1,inb
+ !write(2,887) 'bx:',i,bx(i)
+ !write(2,887) 'by:',i,by(i)
+ !write(2,887) 'bz:',i,bz(i)
+ enddo
+ !write(2,*) 'After sheetforce1'
+ do i=1,inb
+ do k=1,12
+ !write(2,888) 'shefx :',i,k,shefx(i,k)
+ !write(2,888) 'shefy :',i,k,shefy(i,k)
+ !write(2,888) 'shefz :',i,k,shefz(i,k)
+ enddo
+ enddo
+
+ call sheetforce5
+
+ !write(2,*) 'After sheetforce5'
+ do i=1,inb
+ do k=1,12
+ !write(2,888) 'shefx :',i,k,shefx(i,k)
+ !write(2,888) 'shefy :',i,k,shefy(i,k)
+ !write(2,888) 'shefz :',i,k,shefz(i,k)
+ enddo
+ enddo
+
+ call sheetforce6
+
+ !write(2,*) 'After sheetforce6'
+ do i=1,inb
+ do k=1,12
+ !write(2,888) 'shefx :',i,k,shefx(i,k)
+ !write(2,888) 'shefy :',i,k,shefy(i,k)
+ !write(2,888) 'shefz :',i,k,shefz(i,k)
+ enddo
+ enddo
+
+ call sheetforce11
+
+ !write(2,*) 'After sheetforce11'
+ do i=1,inb
+ do k=1,12
+ !write(2,888) 'shefx :',i,k,shefx(i,k)
+ !write(2,888) 'shefy :',i,k,shefy(i,k)
+ !write(2,888) 'shefz :',i,k,shefz(i,k)
+ enddo
+ enddo
+
+ call sheetforce12
+
+ !write(2,*) 'After sheetforce12'
+ do i=1,inb
+ do k=1,12
+ !write(2,888) 'shefx :',i,k,shefx(i,k)
+ !write(2,888) 'shefy :',i,k,shefy(i,k)
+ !write(2,888) 'shefz :',i,k,shefz(i,k)
+ enddo
+ enddo
+
+ do i=1,inb
+ do k=1,12
+ shetfx(i)=shetfx(i)+shefx(i,k)
+ shetfy(i)=shetfy(i)+shefy(i,k)
+ shetfz(i)=shetfz(i)+shefz(i,k)
+ enddo
+ enddo
+ !write(2,*) 'Beta Finished'
+ do i=1,inb
+ !write(2,889) 'shetfx : ',i,shetfx(i)
+ !write(2,889) 'shetfy : ',i,shetfy(i)
+ !write(2,889) 'shetfz : ',i,shetfz(i)
+ enddo
+
+ return
+ end
+C end sheetforce
+c-------------------------------------------------------------------------------
+ subroutine sheetene(nca,wshet)
+ implicit none
+ integer maxca
+ parameter(maxca=800)
+ real*8 dfa_cutoff,dfa_cutoff_delta
+ parameter(dfa_cutoff=15.5d0)
+ parameter(dfa_cutoff_delta=0.5d0)
+cc******************************************************************************
+
+c real*8 dfaexp(15001)
+ real*8 dtmp1, dtmp2, dtmp3
+
+ real*8 vbet(maxca,maxca)
+ real*8 vbetap(maxca,maxca),vbetam(maxca,maxca)
+ real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca)
+ real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca)
+ real*8 pin1(maxca,maxca),pin2(maxca,maxca)
+ real*8 pin3(maxca,maxca),pin4(maxca,maxca)
+ real*8 pina1(maxca,maxca),pina2(maxca,maxca)
+ real*8 pina3(maxca,maxca),pina4(maxca,maxca)
+ real*8 cph(maxca),cth(maxca)
+ real*8 rx(maxca,maxca)
+ real*8 ry(maxca,maxca),rz(maxca,maxca)
+ real*8 bx(maxca),by(maxca),bz(maxca)
+ real*8 dis(maxca,maxca)
+ real*8 ulcos(maxca)
+cc**********************************************************************
+ real*8 astx(maxca),asty(maxca),astz(maxca)
+ real*8 astmx(maxca),astmy(maxca),astmz(maxca)
+ real*8 astmmx(maxca),astmmy(maxca),astmmz(maxca)
+ real*8 astm3x(maxca),astm3y(maxca),astm3z(maxca)
+ real*8 sth(maxca)
+ real*8 wshet(maxca,maxca)
+ real*8 dp45, dm45, w_beta
+ real*8 c00, s00, ulnex, dnex, dca,dlhb,ulhb,dshe,dldhb,uldhb
+ integer nca
+ integer i,ip,ipp,j,jp,jpp,inb,nmax,iselect
+ real*8 uum, uup
+ real*8 vbeta,vbetp,vbetm,y,y1,y2,yshe1,yshe2,yy1,yy2
+
+ real*8 shetfx(maxca),shetfy(maxca),shetfz(maxca)
+ common /shetf/ shetfx,shetfy,shetfz
+
+ common /sheca/ bx,by,bz
+ common /phys1/ inb,nmax,iselect
+ common /kyori2/ dis
+ common /difvec/ rx,ry,rz
+ common /coscos/ cph,cth
+ common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb,
+ & c00,s00,ulnex,dnex
+ common /sheconst/ dp45,dm45,w_beta
+ common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2
+ common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4
+ common /shee/ vbeta,vbet,vbetp,vbetm
+ common /ulang/ ulcos
+cc**********************************************************************
+ common /angvt2/ astx,asty,astz,astmx,astmy,astmz,astmmx,astmmy,
+ & astmmz,astm3x,astm3y,astm3z
+ common /sinsin/ sth
+
+ real*8 r_pair_mat(maxca,maxca)
+ real*8 e_gcont,fprim_gcont,de_gcont
+ci integer istrand(maxca,maxca)
+ci integer istrand_p(maxca,maxca),istrand_m(maxca,maxca)
+ci common /shetest/ istrand,istrand_p,istrand_m
+ common /beta_p/ r_pair_mat
+C-------------------------------------------------------------------------------
+ r_pair_mat = 0.0d0
+ do i=1,inb
+ do j=1,inb
+ r_pair_mat(i,j)=wshet(i,j)
+c write(*,*) 'r_pair_mat :',i,j,r_pair_mat(i,j)
+ enddo
+ enddo
+c stop
+c
+ vbeta=0.0D0
+ vbetp=0.0D0
+ vbetm=0.0D0
+
+ do i=1,inb-7
+ do j=i+4,inb-3
+
+ if (dis(i,j).lt.dfa_cutoff) then
+ call gcont(dis(i,j),dfa_cutoff-dfa_cutoff_delta,1.0D0,
+ & dfa_cutoff_delta,e_gcont,fprim_gcont)
+
+
+ ip=i+1
+ ipp=i+2
+ jp=j+1
+ jpp=j+2
+cc**********************************************************************
+ y1=(cth(i)*c00+sth(i)*s00-1.0D0)**2
+ & +(cth(j)*c00+sth(j)*s00-1.0D0)**2
+ y1=-0.5d0*y1/dca
+ y2=(ulcos(i)-ulnex)**2+(ulcos(ip)-ulnex)**2
+ & +(ulcos(j)-ulnex)**2+(ulcos(jp)-ulnex)**2
+ y2=-0.5d0*y2/dnex
+
+cdebug y2=0
+
+ y=y1+y2
+
+ci if(y.ge.-4) then
+ci istrand(i,j)=1
+ci else
+ci istrand(i,j)=0
+ci endif
+
+ci if(istrand(i,j).eq.1) then
+
+ yy1=-0.5d0*(dis(ip,jp)-ulhb)**2/dlhb
+ yy2=-0.5d0*(dis(ipp,jpp)-ulhb)**2/dlhb
+
+
+ pin1(i,j)=(rx(ip,jp)*rx(ip,ipp)+ry(ip,jp)*ry(ip,ipp)
+ $ +rz(ip,jp)*rz(ip,ipp))/(dis(ip,jp)*dis(ip,ipp))
+ pin2(i,j)=(rx(ip,jp)*rx(jp,jpp)+ry(ip,jp)*ry(jp,jpp)
+ $ +rz(ip,jp)*rz(jp,jpp))/(dis(ip,jp)*dis(jp,jpp))
+ pin3(i,j)=(rx(ipp,jpp)*rx(ip,ipp)+ry(ipp,jpp)*ry(ip,ipp)
+ $ +rz(ipp,jpp)*rz(ip,ipp))/(dis(ipp,jpp)*dis(ip,ipp))
+ pin4(i,j)=(rx(ipp,jpp)*rx(jp,jpp)+ry(ipp,jpp)*ry(jp,jpp)
+ $ +rz(ipp,jpp)*rz(jp,jpp))/(dis(ipp,jpp)*dis(jp,jpp))
+
+ yshe1=pin1(i,j)**2+pin2(i,j)**2
+ yshe1=-0.5d0*yshe1/dshe
+ yshe2=pin3(i,j)**2+pin4(i,j)**2
+ yshe2=-0.5d0*yshe2/dshe
+
+ci if((yshe1+yshe2).ge.-4) then
+ci istrand_p(i,j)=1
+ci else
+ci istrand_p(i,j)=0
+ci endif
+
+
+C write(*,*) 'rx(i,j):',i,j,rx(i,j),bx(j),bx(i)
+C write(*,*) 'ry(i,j):',i,j,ry(i,j),by(j),by(i)
+C write(*,*) 'rz(i,j):',i,j,rz(i,j),bz(j),bz(i)
+C write(*,*) 'dis(i,j):',i,j,dis(i,j)
+C write(*,*) 'rx(ip,jp):',ip,jp,bx(ip),bx(jp),rx(ip,jp)
+C write(*,*) 'rx(ip,ipp):',ip,ipp,bx(ip),bx(ipp),rx(ip,ipp)
+C write(*,*) 'pin1:',pin1(i,j)
+C write(*,*) 'pin2:',pin2(i,j)
+C write(*,*) 'pin3:',pin3(i,j)
+C write(*,*) 'pin4:',pin4(i,j)
+
+C write(*,*) 'y:',y
+C write(*,*) 'yy1:',yy1
+C write(*,*) 'yy2:',yy2
+C write(*,*) 'yshe1:',yshe1
+C write(*,*) 'yshe2:',yshe2
+c
+
+ci if (istrand_p(i,j).eq.1) then
+
+cd yy1=0
+cd yy2=0
+cd yshe1=0
+cd yshe2=0
+ dtmp1 = y+yy1+yshe1
+ dtmp2 = y+yy2+yshe2
+ dtmp3 = y+yy1+yy2+yshe1+yshe2
+
+C write(*,*)'1', i,j,dtmp1,dtmp2,dtmp3
+C write(*,*)'2', y,yy1,yy2
+C write(*,*)'3', yshe1,yshe2
+
+cc if (dtmp3.le.-35.0d0) then
+c vbetap(i,j)=-dp45*exp(dtmp3)
+cc vbetap(i,j)=0.0d0
+cc else
+c vbetap(i,j)=-dp45*dfaexp(idint(-dtmp3*1000)+1)
+ vbetap(i,j)=-dp45*exp(dtmp3)
+cc end if
+
+cc if (dtmp1.le.-35.0d0) then
+c vbetap1(i,j)=-r_pair_mat(i+1,j+1)*exp(dtmp1)
+cc vbetap1(i,j)=0.0d0
+cc else
+c vbetap1(i,j)=-r_pair_mat(i+1,j+1)
+c $ *dfaexp(idint(-dtmp1*1000)+1)
+ vbetap1(i,j)=-r_pair_mat(i+1,j+1)*exp(dtmp1)
+cc end if
+
+cc if (dtmp2.le.-35.0d0) then
+C vbetap2(i,j)=-r_pair_mat(i+2,j+2)*exp(dtmp2)
+cc vbetap2(i,j)=0.0d0
+cc else
+c vbetap2(i,j)=-r_pair_mat(i+2,j+2)
+c $ *dfaexp(idint(-dtmp2*1000)+1)
+ vbetap2(i,j)=-r_pair_mat(i+2,j+2)*exp(dtmp2)
+cc end if
+
+c vbetap(i,j)=-dp45*exp(y+yy1+yy2+yshe1+yshe2)
+c vbetap1(i,j)=-r_pair_mat(i+1,j+1)*exp(y+yy1+yshe1)
+c vbetap2(i,j)=-r_pair_mat(i+2,j+2)*exp(y+yy2+yshe2)
+
+! write(*,*) 'r_pair_mat>',i+1,j+1,r_pair_mat(i+1,j+1)
+! write(*,*) 'r_pair_mat>',i+2,j+2,r_pair_mat(i+2,j+2)
+
+ci elseif (istrand_p(i,j).eq.0)then
+ci vbetap(i,j)=0
+ci vbetap1(i,j)=0
+ci vbetap2(i,j)=0
+ci endif
+
+ yy1=-0.5d0*(dis(ip,jpp)-ulhb)**2/dlhb
+ yy2=-0.5d0*(dis(ipp,jp)-ulhb)**2/dlhb
+
+ pina1(i,j)=(rx(ip,jpp)*rx(ip,ipp)+ry(ip,jpp)*ry(ip,ipp)
+ $ +rz(ip,jpp)*rz(ip,ipp))/(dis(ip,jpp)*dis(ip,ipp))
+ pina2(i,j)=(rx(ip,jpp)*rx(jp,jpp)+ry(ip,jpp)*ry(jp,jpp)
+ $ +rz(ip,jpp)*rz(jp,jpp))/(dis(ip,jpp)*dis(jp,jpp))
+ pina3(i,j)=(rx(jp,ipp)*rx(ip,ipp)+ry(jp,ipp)*ry(ip,ipp)
+ $ +rz(jp,ipp)*rz(ip,ipp))/(dis(jp,ipp)*dis(ip,ipp))
+ pina4(i,j)=(rx(jp,ipp)*rx(jp,jpp)+ry(jp,ipp)*ry(jp,jpp)
+ $ +rz(jp,ipp)*rz(jp,jpp))/(dis(jp,ipp)*dis(jp,jpp))
+
+ yshe1=pina1(i,j)**2+pina2(i,j)**2
+ yshe1=-0.5d0*yshe1/dshe
+ yshe2=pina3(i,j)**2+pina4(i,j)**2
+ yshe2=-0.5d0*yshe2/dshe
+
+ci if((yshe1+yshe2).ge.-4) then
+ci istrand_m(i,j)=1
+ci else
+ci istrand_m(i,j)=0
+ci endif
+
+
+C write(*,*) 'pina1:',pina1(i,j)
+C write(*,*) 'pina2:',pina2(i,j)
+C write(*,*) 'pina3:',pina3(i,j)
+C write(*,*) 'pina4:',pina4(i,j)
+C write(*,*) 'yshe1:',yshe1
+C write(*,*) 'yshe2:',yshe2
+C write(*,*) 'dshe:',dshe
+
+ci if (istrand_m(i,j).eq.1) then
+
+cd yy1=0
+cd yy2=0
+cd yshe1=0
+cd yshe2=0
+
+ dtmp3=y+yy1+yy2+yshe1+yshe2
+ dtmp1=y+yy1+yshe1
+ dtmp2=y+yy2+yshe2
+
+cc if(dtmp3 .le. -35.0d0) then
+c vbetam(i,j)=-dm45*exp(dtmp3)
+cc vbetam(i,j)=0.0d0
+cc else
+c vbetam(i,j)=-dm45*dfaexp(idint(-dtmp3*1000)+1)
+ vbetam(i,j)=-dm45*exp(dtmp3)
+cc end if
+
+cc if(dtmp1 .le. -35.0d0) then
+c vbetam1(i,j)=-r_pair_mat(i+1,j+2)*exp(dtmp1)
+cc vbetam1(i,j)=0.0d0
+cc else
+c vbetam1(i,j)=-r_pair_mat(i+1,j+2)
+c $ *dfaexp(idint(-dtmp1*1000)+1)
+ vbetam1(i,j)=-r_pair_mat(i+1,j+2)*exp(dtmp1)
+cc end if
+
+cc if(dtmp2.le.-35.0d0) then
+c vbetam2(i,j)=-r_pair_mat(i+2,j+1)*exp(dtmp2)
+cc vbetam2(i,j)=0.0d0
+cc else
+c vbetam2(i,j)=-r_pair_mat(i+2,j+1)
+c $ *dfaexp(idint(-dtmp2*1000)+1)
+ vbetam2(i,j)=-r_pair_mat(i+2,j+1)*exp(dtmp2)
+cc end if
+
+ci elseif (istrand_m(i,j).eq.0)then
+ci vbetam(i,j)=0
+ci vbetam1(i,j)=0
+ci vbetam2(i,j)=0
+ci endif
+
+
+c vbetam(i,j)=-dm45*exp(y+yy1+yy2+yshe1+yshe2)
+c vbetam1(i,j)=-r_pair_mat(i+1,j+2)*exp(y+yy1+yshe1)
+c vbetam2(i,j)=-r_pair_mat(i+2,j+1)*exp(y+yy2+yshe2)
+
+! write(*,*) 'r_pair_mat>',i+1,j+2,r_pair_mat(i+1,j+2)
+! write(*,*) 'r_pair_mat>',i+2,j+1,r_pair_mat(i+2,j+1)
+
+ uup = vbetap(i,j)+vbetap1(i,j)+vbetap2(i,j)
+ uum = vbetam(i,j)+vbetam1(i,j)+vbetam2(i,j)
+
+c write(*,*) 'uup,uum:', uup, uum
+
+c uup=vbetap1(i,j)+vbetap2(i,j)
+c uum=vbetam1(i,j)+vbetam2(i,j)
+
+ vbet(i,j)=uup+uum
+ vbetp=vbetp+uup
+ vbetm=vbetm+uum
+ vbeta=vbeta+vbet(i,j)*e_gcont
+
+
+ if (dis(i,j) .ge. dfa_cutoff-2*dfa_cutoff_delta) then
+c gradient correction from gcont
+ de_gcont=vbet(i,j)*fprim_gcont/dis(i,j)
+ shetfx(i)=shetfx(i) + de_gcont*rx(i,j)
+ shetfy(i)=shetfy(i) + de_gcont*ry(i,j)
+ shetfz(i)=shetfz(i) + de_gcont*rz(i,j)
+
+ shetfx(j)=shetfx(j) - de_gcont*rx(i,j)
+ shetfy(j)=shetfy(j) - de_gcont*ry(i,j)
+ shetfz(j)=shetfz(j) - de_gcont*rz(i,j)
+
+c energy correction from gcont
+ vbet(i,j)=vbet(i,j)*e_gcont
+ vbetap(i,j)=vbetap(i,j)*e_gcont
+ vbetap1(i,j)=vbetap1(i,j)*e_gcont
+ vbetap2(i,j)=vbetap2(i,j)*e_gcont
+ vbetam(i,j)=vbetam(i,j)*e_gcont
+ vbetam1(i,j)=vbetam1(i,j)*e_gcont
+ vbetam2(i,j)=vbetam2(i,j)*e_gcont
+ endif
+
+
+ci elseif(istrand(i,j).eq.0)then
+ci vbet(i,j)=0
+ci endif
+
+c write(*,*) 'uup,uum:',uup,uum
+c write(*,*) 'vbetap(i,j):',vbetap(i,j)
+c write(*,*) 'vbetap1(i,j):',vbetap1(i,j)
+c write(*,*) 'vbetap2(i,j):',vbetap2(i,j)
+c write(*,*) 'vbetam(i,j):',vbetam(i,j)
+c write(*,*) 'vbetam1(i,j):',vbetam1(i,j)
+c write(*,*) 'vbetam2(i,j):',vbetam2(i,j)
+c write(*,*) 'uup:',uup
+c write(*,*) 'uum:',uum
+c write(*,*) 'vbetp:',vbetp
+c write(*,*) 'vbetm:',vbetm
+c write(*,*) 'vbet(i,j):',vbet(i,j)
+c stop
+
+ else
+ vbetap(i,j)=0
+ vbetap1(i,j)=0
+ vbetap2(i,j)=0
+ vbetam(i,j)=0
+ vbetam1(i,j)=0
+ vbetam2(i,j)=0
+ vbet(i,j)=0
+ endif
+ enddo
+ enddo
+
+! do i=1,inb-7
+! do j=i+4,inb-3
+! write(*,*) 'I,J:', i,j
+! write(*,*) 'vbetap(i,j):',vbetap(i,j)
+! write(*,*) 'vbetap1(i,j):',vbetap1(i,j)
+! write(*,*) 'vbetap2(i,j):',vbetap2(i,j)
+! write(*,*) 'vbetam(i,j):',vbetam(i,j)
+! write(*,*) 'vbetam1(i,j):',vbetam1(i,j)
+! write(*,*) 'vbetam2(i,j):',vbetam2(i,j)
+! write(*,*) 'vbet(i,j):',vbet(i,j)
+! enddo
+! enddo
+
+ return
+ end
+c-------------------------------------------------------------------------------
+ subroutine sheetforce1
+ implicit none
+ integer maxca
+ parameter(maxca=800)
+ real*8 dfa_cutoff,dfa_cutoff_delta
+ parameter(dfa_cutoff=15.5d0)
+ parameter(dfa_cutoff_delta=0.5d0)
+cc**********************************************************************
+ real*8 vbet(maxca,maxca)
+ real*8 vbetap(maxca,maxca),vbetam(maxca,maxca)
+ real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca)
+ real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca)
+ real*8 cph(maxca),cth(maxca)
+ real*8 rx(maxca,maxca)
+ real*8 ry(maxca,maxca),rz(maxca,maxca)
+ real*8 bx(maxca),by(maxca),bz(maxca)
+ real*8 dis(maxca,maxca)
+ real*8 shefx(maxca,12)
+ real*8 shefy(maxca,12),shefz(maxca,12)
+ real*8 atx(maxca),aty(maxca),atz(maxca)
+ real*8 atmx(maxca),atmy(maxca),atmz(maxca)
+ real*8 atmmx(maxca),atmmy(maxca),atmmz(maxca)
+ real*8 atm3x(maxca),atm3y(maxca),atm3z(maxca)
+ real*8 apx(maxca),apy(maxca),apz(maxca)
+ real*8 apmx(maxca),apmy(maxca),apmz(maxca)
+ real*8 apmmx(maxca),apmmy(maxca),apmmz(maxca)
+ real*8 apm3x(maxca),apm3y(maxca),apm3z(maxca)
+ real*8 ulcos(maxca)
+ real*8 astx(maxca),asty(maxca),astz(maxca)
+ real*8 astmx(maxca),astmy(maxca),astmz(maxca)
+ real*8 astmmx(maxca),astmmy(maxca),astmmz(maxca)
+ real*8 astm3x(maxca),astm3y(maxca),astm3z(maxca)
+ real*8 sth(maxca)
+ real*8 w_beta,dp45, dm45
+ real*8 vbeta, vbetp, vbetm
+ real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb,
+ $ c00,s00,ulnex,dnex
+ integer inb,nmax,iselect
+
+ common /phys1/ inb,nmax,iselect
+ common /kyori2/ dis
+ common /difvec/ rx,ry,rz
+ common /coscos/ cph,cth
+ common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb,
+ $ c00,s00,ulnex,dnex
+ common /sheconst/ dp45,dm45,w_beta
+ common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2
+ common /angvt/ atx,aty,atz,atmx,atmy,atmz,atmmx,atmmy,
+ $ atmmz,atm3x,atm3y,atm3z
+ common /angvp/ apx,apy,apz,apmx,apmy,apmz,apmmx,apmmy,
+ $ apmmz,apm3x,apm3y,apm3z
+ common /shef/ shefx,shefy,shefz
+ common /shee/ vbeta,vbet,vbetp,vbetm
+ common /ulang/ ulcos
+c c**********************************************************************
+ common /angvt2/ astx,asty,astz,astmx,astmy,astmz,astmmx,astmmy,
+ $ astmmz,astm3x,astm3y,astm3z
+ common /sinsin/ sth
+C--------------------------------------------------------------------------------
+c local variables
+ integer i,j,im3,imm,im,ip,ipp,jm,jmm,jm3,jp,jpp
+ real*8 c1,v1,cc1,dmm,dmm__,fx,fy,fz,c2,v2,dmm1
+ real*8 c3,v3,cc2,cc3,dmm3,dmm3__,c4,v4,c7,v7,cc7,c8,v8,cc8
+ real*8 c9,v9,cc9,dmm9,dmm9__,c10,v10,dmm2,dmm1__,dmm2_1,dmm2_2
+ real*8 dmm7,dmm8,dmm7__,dmm8_1,dmm8_2
+ real*8 e_gcont,fprim_gcont
+C--------------------------------------------------------------------------------
+ do i=4,inb-4
+ im3=i-3
+ imm=i-2
+ im=i-1
+ c1=(cth(im3)*c00+sth(im3)*s00-1)/dca
+ v1=0.0D0
+ do j=i+1,inb-3
+ v1=v1+vbet(im3,j)
+ enddo
+ cc1=(ulcos(imm)-ulnex)/dnex
+ dmm=cc1/(dis(imm,im)*dis(im,i))
+ dmm__=cc1*ulcos(imm)/dis(im,i)**2
+ fx=rx(imm,im)*dmm-rx(im,i)*dmm__
+ fy=ry(imm,im)*dmm-ry(im,i)*dmm__
+ fz=rz(imm,im)*dmm-rz(im,i)*dmm__
+cd fx=0
+cd fy=0
+cd fz=0
+ fx=fx+(atm3x(i)*c00+astm3x(i)*s00)*c1
+ fy=fy+(atm3y(i)*c00+astm3y(i)*s00)*c1
+ fz=fz+(atm3z(i)*c00+astm3z(i)*s00)*c1
+ shefx(i,1)=fx*v1
+ shefy(i,1)=fy*v1
+ shefz(i,1)=fz*v1
+ enddo
+
+ do i=3,inb-5
+ imm=i-2
+ im=i-1
+ ip=i+1
+ c2=(cth(imm)*c00+sth(imm)*s00-1)/dca
+ v2=0.0D0
+ do j=i+2,inb-3
+ v2=v2+vbet(imm,j)
+ enddo
+ cc1=(ulcos(imm)-ulnex)/dnex
+ cc2=(ulcos(im)-ulnex)/dnex
+ dmm1=cc1/(dis(imm,im)*dis(im,i))
+ dmm2=cc2/(dis(im,i)*dis(i,ip))
+ dmm1__=cc1*ulcos(imm)/dis(im,i)**2
+ dmm2_1=cc2*ulcos(im)/dis(im,i)**2
+ dmm2_2=cc2*ulcos(im)/dis(i,ip)**2
+cc**********************************************************************
+ fx=rx(imm,im)*dmm1-rx(im,i)*dmm1__+rx(i,ip)*dmm2-rx(im,i)*dmm2
+ $ -rx(im,i)*dmm2_1+rx(i,ip)*dmm2_2
+ fy=ry(imm,im)*dmm1-ry(im,i)*dmm1__+ry(i,ip)*dmm2-ry(im,i)*dmm2
+ $ -ry(im,i)*dmm2_1+ry(i,ip)*dmm2_2
+ fz=rz(imm,im)*dmm1-rz(im,i)*dmm1__+rz(i,ip)*dmm2-rz(im,i)*dmm2
+ $ -rz(im,i)*dmm2_1+rz(i,ip)*dmm2_2
+cd fx=0
+cd fy=0
+cd fz=0
+ fx=fx+(atmmx(i)*c00+astmmx(i)*s00)*c2
+ fy=fy+(atmmy(i)*c00+astmmy(i)*s00)*c2
+ fz=fz+(atmmz(i)*c00+astmmz(i)*s00)*c2
+ shefx(i,2)=fx*v2
+ shefy(i,2)=fy*v2
+ shefz(i,2)=fz*v2
+ enddo
+ do i=2,inb-6
+ im=i-1
+ ip=i+1
+ ipp=i+2
+ c3=(cth(im)*c00+sth(im)*s00-1)/dca
+ v3=0.0D0
+ do j=i+3,inb-3
+ v3=v3+vbet(im,j)
+ enddo
+ cc2=(ulcos(im)-ulnex)/dnex
+ cc3=(ulcos(i)-ulnex)/dnex
+ dmm2=cc2/(dis(im,i)*dis(i,ip))
+ dmm3=cc3/(dis(i,ip)*dis(ip,ipp))
+ dmm2_1=cc2*ulcos(im)/dis(im,i)**2
+ dmm2_2=cc2*ulcos(im)/dis(i,ip)**2
+ dmm3__=cc3*ulcos(i)/dis(i,ip)**2
+ fx=-rx(ip,ipp)*dmm3+rx(i,ip)*dmm2-rx(im,i)*dmm2
+ $ -rx(im,i)*dmm2_1+rx(i,ip)*dmm2_2+rx(i,ip)*dmm3__
+ fy=-ry(ip,ipp)*dmm3+ry(i,ip)*dmm2-ry(im,i)*dmm2
+ $ -ry(im,i)*dmm2_1+ry(i,ip)*dmm2_2+ry(i,ip)*dmm3__
+ fz=-rz(ip,ipp)*dmm3+rz(i,ip)*dmm2-rz(im,i)*dmm2
+ $ -rz(im,i)*dmm2_1+rz(i,ip)*dmm2_2+rz(i,ip)*dmm3__
+cd fx=0
+cd fy=0
+cd fz=0
+ fx=fx+(atmx(i)*c00+astmx(i)*s00)*c3
+ fy=fy+(atmy(i)*c00+astmy(i)*s00)*c3
+ fz=fz+(atmz(i)*c00+astmz(i)*s00)*c3
+ shefx(i,3)=fx*v3
+ shefy(i,3)=fy*v3
+ shefz(i,3)=fz*v3
+ enddo
+ do i=1,inb-7
+ ip=i+1
+ ipp=i+2
+ c4=(cth(i)*c00+sth(i)*s00-1)/dca
+ v4=0.0D0
+ do j=i+4,inb-3
+ v4=v4+vbet(i,j)
+ enddo
+ cc3=(ulcos(i)-ulnex)/dnex
+ dmm3=cc3/(dis(i,ip)*dis(ip,ipp))
+ dmm3__=cc3*ulcos(i)/dis(i,ip)**2
+ fx=-rx(ip,ipp)*dmm3+rx(i,ip)*dmm3__
+ fy=-ry(ip,ipp)*dmm3+ry(i,ip)*dmm3__
+ fz=-rz(ip,ipp)*dmm3+rz(i,ip)*dmm3__
+cd fx=0
+cd fy=0
+cd fz=0
+ fx=fx+(atx(i)*c00+astx(i)*s00)*c4
+ fy=fy+(aty(i)*c00+asty(i)*s00)*c4
+ fz=fz+(atz(i)*c00+astz(i)*s00)*c4
+ shefx(i,4)=fx*v4
+ shefy(i,4)=fy*v4
+ shefz(i,4)=fz*v4
+ enddo
+ do j=8,inb
+ jm3=j-3
+ jmm=j-2
+ jm=j-1
+ c7=(cth(jm3)*c00+sth(jm3)*s00-1)/dca
+ v7=0.0D0
+ do i=1,j-7
+ v7=v7+vbet(i,jm3)
+ enddo
+ cc7=(ulcos(jmm)-ulnex)/dnex
+ dmm=cc7/(dis(jmm,jm)*dis(jm,j))
+ dmm__=cc7*ulcos(jmm)/dis(jm,j)**2
+ fx=rx(jmm,jm)*dmm-rx(jm,j)*dmm__
+ fy=ry(jmm,jm)*dmm-ry(jm,j)*dmm__
+ fz=rz(jmm,jm)*dmm-rz(jm,j)*dmm__
+cd fx=0
+cd fy=0
+cd fz=0
+ fx=fx+(atm3x(j)*c00+astm3x(j)*s00)*c7
+ fy=fy+(atm3y(j)*c00+astm3y(j)*s00)*c7
+ fz=fz+(atm3z(j)*c00+astm3z(j)*s00)*c7
+ shefx(j,7)=fx*v7
+ shefy(j,7)=fy*v7
+ shefz(j,7)=fz*v7
+ enddo
+ do j=7,inb-1
+ jm=j-1
+ jmm=j-2
+ jp=j+1
+ c8=(cth(jmm)*c00+sth(jmm)*s00-1)/dca
+ v8=0.0D0
+ do i=1,j-6
+ v8=v8+vbet(i,jmm)
+ enddo
+ cc7=(ulcos(jmm)-ulnex)/dnex
+ cc8=(ulcos(jm)-ulnex)/dnex
+ dmm7=cc7/(dis(jmm,jm)*dis(jm,j))
+ dmm8=cc8/(dis(jm,j)*dis(j,jp))
+ dmm7__=cc7*ulcos(jmm)/dis(jm,j)**2
+ dmm8_1=cc8*ulcos(jm)/dis(jm,j)**2
+ dmm8_2=cc8*ulcos(jm)/dis(j,jp)**2
+ fx=rx(jmm,jm)*dmm7+rx(j,jp)*dmm8-rx(jm,j)*dmm8
+ $ -rx(jm,j)*dmm7__-rx(jm,j)*dmm8_1+rx(j,jp)*dmm8_2
+ fy=ry(jmm,jm)*dmm7+ry(j,jp)*dmm8-ry(jm,j)*dmm8
+ $ -ry(jm,j)*dmm7__-ry(jm,j)*dmm8_1+ry(j,jp)*dmm8_2
+ fz=rz(jmm,jm)*dmm7+rz(j,jp)*dmm8-rz(jm,j)*dmm8
+ $ -rz(jm,j)*dmm7__-rz(jm,j)*dmm8_1+rz(j,jp)*dmm8_2
+cd fx=0
+cd fy=0
+cd fz=0
+ fx=fx+(atmmx(j)*c00+astmmx(j)*s00)*c8
+ fy=fy+(atmmy(j)*c00+astmmy(j)*s00)*c8
+ fz=fz+(atmmz(j)*c00+astmmz(j)*s00)*c8
+ shefx(j,8)=fx*v8
+ shefy(j,8)=fy*v8
+ shefz(j,8)=fz*v8
+ enddo
+
+ do j=6,inb-2
+ jm=j-1
+ jp=j+1
+ jpp=j+2
+ c9=(cth(jm)*c00+sth(jm)*s00-1)/dca
+ v9=0.0D0
+ do i=1,j-5
+ v9=v9+vbet(i,jm)
+ enddo
+ cc8=(ulcos(jm)-ulnex)/dnex
+ cc9=(ulcos(j)-ulnex)/dnex
+ dmm8=cc8/(dis(jm,j)*dis(j,jp))
+ dmm9=cc9/(dis(j,jp)*dis(jp,jpp))
+ dmm8_1=cc8*ulcos(jm)/dis(jm,j)**2
+ dmm8_2=cc8*ulcos(jm)/dis(j,jp)**2
+ dmm9__=cc9*ulcos(j)/dis(j,jp)**2
+ fx=-rx(jp,jpp)*dmm9+rx(j,jp)*dmm8-rx(jm,j)*dmm8
+ $ -rx(jm,j)*dmm8_1+rx(j,jp)*dmm8_2+rx(j,jp)*dmm9__
+ fy=-ry(jp,jpp)*dmm9+ry(j,jp)*dmm8-ry(jm,j)*dmm8
+ $ -ry(jm,j)*dmm8_1+ry(j,jp)*dmm8_2+ry(j,jp)*dmm9__
+ fz=-rz(jp,jpp)*dmm9+rz(j,jp)*dmm8-rz(jm,j)*dmm8
+ $ -rz(jm,j)*dmm8_1+rz(j,jp)*dmm8_2+rz(j,jp)*dmm9__
+cd fx=0
+cd fy=0
+cd fz=0
+ fx=fx+(atmx(j)*c00+astmx(j)*s00)*c9
+ fy=fy+(atmy(j)*c00+astmy(j)*s00)*c9
+ fz=fz+(atmz(j)*c00+astmz(j)*s00)*c9
+ shefx(j,9)=fx*v9
+ shefy(j,9)=fy*v9
+ shefz(j,9)=fz*v9
+ enddo
+
+ do j=5,inb-3
+ jp=j+1
+ jpp=j+2
+ c10=(cth(j)*c00+sth(j)*s00-1)/dca
+ v10=0.0D0
+ do i=1,j-4
+ v10=v10+vbet(i,j)
+ enddo
+ cc9=(ulcos(j)-ulnex)/dnex
+ dmm9=cc9/(dis(j,jp)*dis(jp,jpp))
+ dmm9__=cc9*ulcos(j)/dis(j,jp)**2
+ fx=-rx(jp,jpp)*dmm9+rx(j,jp)*dmm9__
+ fy=-ry(jp,jpp)*dmm9+ry(j,jp)*dmm9__
+ fz=-rz(jp,jpp)*dmm9+rz(j,jp)*dmm9__
+cd fx=0
+cd fy=0
+cd fz=0
+ fx=fx+(atx(j)*c00+astx(j)*s00)*c10
+ fy=fy+(aty(j)*c00+asty(j)*s00)*c10
+ fz=fz+(atz(j)*c00+astz(j)*s00)*c10
+ shefx(j,10)=fx*v10
+ shefy(j,10)=fy*v10
+ shefz(j,10)=fz*v10
+ enddo
+
+ return
+ end
+c----------------------------------------------------------------------------
+ subroutine sheetforce5
+ implicit none
+ integer maxca
+ parameter(maxca=800)
+ real*8 dfa_cutoff,dfa_cutoff_delta
+ parameter(dfa_cutoff=15.5d0)
+ parameter(dfa_cutoff_delta=0.5d0)
+cc**********************************************************************
+ real*8 vbetap(maxca,maxca),vbetam(maxca,maxca)
+ real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca)
+ real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca)
+ real*8 pin1(maxca,maxca),pin2(maxca,maxca)
+ real*8 pin3(maxca,maxca),pin4(maxca,maxca)
+ real*8 pina1(maxca,maxca),pina2(maxca,maxca)
+ real*8 pina3(maxca,maxca),pina4(maxca,maxca)
+ real*8 rx(maxca,maxca)
+ real*8 ry(maxca,maxca),rz(maxca,maxca)
+ real*8 bx(maxca),by(maxca),bz(maxca)
+ real*8 dis(maxca,maxca)
+ real*8 shefx(maxca,12),shefy(maxca,12)
+ real*8 shefz(maxca,12)
+ real*8 dp45,dm45,w_beta
+ real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb,
+ $ c00,s00,ulnex,dnex
+ integer inb,nmax,iselect
+cc**********************************************************************
+ common /phys1/ inb,nmax,iselect
+ common /kyori2/ dis
+ common /difvec/ rx,ry,rz
+ common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb,
+ $ c00,s00,ulnex,dnex
+ common /sheconst/ dp45,dm45,w_beta
+ common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2
+ common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4
+ common /shef/ shefx,shefy,shefz
+ci integer istrand(maxca,maxca)
+ci integer istrand_p(maxca,maxca),istrand_m(maxca,maxca)
+ci common /shetest/ istrand,istrand_p,istrand_m
+c********************************************************************************
+c local variables
+ integer i,imm,im,jp,jpp,j
+ real*8 yy1,y1x,y1y,y1z,y11x,y11y,y11z,yy33,yyy3,yy3,y3x,y3y,y3z
+ real*8 yy44,yyy4a,yyy4b,yy4,y4x,y4y,y4z,yy55,yyy5,yy5,y5x,y5y,y5z
+ real*8 sx,sy,sz,sx1,sy1,sz1,sx2,sy2,sz2,y6x,y6y,y6z
+ real*8 y66x,y66y,y66z,yy6,yyy4,yyy5a,yyy5b
+ real*8 yy88,yyy8a,yyy8b,yy8,y8x,y8y,y8z,yy99,yyy9,yy9,y9x,y9y,y9z
+ real*8 yy1010,yyy10,yy10,y10x,y10y,y10z,yyy8,yyy9a,yyy9b
+ real*8 e_gcont,fprim_gcont
+c********************************************************************************
+ do i=3,inb-5
+ imm=i-2
+ im=i-1
+ do j=i+2,inb-3
+
+ if (dis(imm,j).lt.dfa_cutoff) then
+ call gcont(dis(imm,j),dfa_cutoff-dfa_cutoff_delta,1.0D0,
+ & dfa_cutoff_delta,e_gcont,fprim_gcont)
+
+ jp=j+1
+ jpp=j+2
+
+ci if(istrand(imm,j).eq.1
+ci & .and.(istrand_p(imm,j)+istrand_m(imm,j)).ge.1) then
+
+
+ yy1=-(dis(i,jpp)-ulhb)/dlhb
+ y1x=rx(jpp,i)/dis(i,jpp)
+ y1y=ry(jpp,i)/dis(i,jpp)
+ y1z=rz(jpp,i)/dis(i,jpp)
+ y11x=yy1*y1x
+ y11y=yy1*y1y
+ y11z=yy1*y1z
+
+ yy33=1.0D0/(dis(im,jp)*dis(im,i))
+ yyy3=pin1(imm,j)/(dis(im,i)**2)
+ yy3=-pin1(imm,j)/dshe
+ y3x=(yy33*rx(im,jp)-yyy3*rx(im,i))*yy3
+ y3y=(yy33*ry(im,jp)-yyy3*ry(im,i))*yy3
+ y3z=(yy33*rz(im,jp)-yyy3*rz(im,i))*yy3
+
+ yy44=1.0D0/(dis(i,jpp)*dis(im,i))
+ yyy4a=pin3(imm,j)/(dis(i,jpp)**2)
+ yyy4b=pin3(imm,j)/(dis(im,i)**2)
+ yy4=-pin3(imm,j)/dshe
+ y4x=(yy44*(rx(i,jpp)-rx(im,i))+yyy4a*rx(i,jpp)
+ $ -yyy4b*rx(im,i))*yy4
+ y4y=(yy44*(ry(i,jpp)-ry(im,i))+yyy4a*ry(i,jpp)
+ $ -yyy4b*ry(im,i))*yy4
+ y4z=(yy44*(rz(i,jpp)-rz(im,i))+yyy4a*rz(i,jpp)
+ $ -yyy4b*rz(im,i))*yy4
+
+
+ yy55=1.0D0/(dis(i,jpp)*dis(jp,jpp))
+ yyy5=pin4(imm,j)/(dis(i,jpp)**2)
+ yy5=-pin4(imm,j)/dshe
+ y5x=(-yy55*rx(jp,jpp)+yyy5*rx(i,jpp))*yy5
+ y5y=(-yy55*ry(jp,jpp)+yyy5*ry(i,jpp))*yy5
+ y5z=(-yy55*rz(jp,jpp)+yyy5*rz(i,jpp))*yy5
+
+ sx=y11x+y3x+y4x+y5x
+ sy=y11y+y3y+y4y+y5y
+ sz=y11z+y3z+y4z+y5z
+
+ sx1=y3x
+ sy1=y3y
+ sz1=y3z
+ sx2=y11x+y4x+y5x
+ sy2=y11y+y4y+y5y
+ sz2=y11z+y4z+y5z
+
+ shefx(i,5)=shefx(i,5)-sx*vbetap(imm,j)
+ $ -sx1*vbetap1(imm,j)-sx2*vbetap2(imm,j)
+ shefy(i,5)=shefy(i,5)-sy*vbetap(imm,j)
+ $ -sy1*vbetap1(imm,j)-sy2*vbetap2(imm,j)
+ shefz(i,5)=shefz(i,5)-sz*vbetap(imm,j)
+ $ -sz1*vbetap1(imm,j)-sz2*vbetap2(imm,j)
+
+! shefx(i,5)=shefx(i,5)
+! $ -sx1*vbetap1(imm,j)-sx2*vbetap2(imm,j)
+! shefy(i,5)=shefy(i,5)
+! $ -sy1*vbetap1(imm,j)-sy2*vbetap2(imm,j)
+! shefz(i,5)=shefz(i,5)
+! $ -sz1*vbetap1(imm,j)-sz2*vbetap2(imm,j)
+
+ yy6=-(dis(i,jp)-uldhb)/dldhb
+ y6x=rx(jp,i)/dis(i,jp)
+ y6y=ry(jp,i)/dis(i,jp)
+ y6z=rz(jp,i)/dis(i,jp)
+ y66x=yy6*y6x
+ y66y=yy6*y6y
+ y66z=yy6*y6z
+
+ yy88=1.0D0/(dis(im,jpp)*dis(im,i))
+ yyy8=pina1(imm,j)/(dis(im,i)**2)
+ yy8=-pina1(imm,j)/dshe
+ y8x=(yy88*rx(im,jpp)-yyy8*rx(im,i))*yy8
+ y8y=(yy88*ry(im,jpp)-yyy8*ry(im,i))*yy8
+ y8z=(yy88*rz(im,jpp)-yyy8*rz(im,i))*yy8
+
+ yy99=1.0D0/(dis(jp,i)*dis(im,i))
+ yyy9a=pina3(imm,j)/(dis(jp,i)**2)
+ yyy9b=pina3(imm,j)/(dis(im,i)**2)
+ yy9=-pina3(imm,j)/dshe
+ y9x=(yy99*(rx(jp,i)+rx(im,i))-yyy9a*rx(jp,i)
+ $ -yyy9b*rx(im,i))*yy9
+ y9y=(yy99*(ry(jp,i)+ry(im,i))-yyy9a*ry(jp,i)
+ $ -yyy9b*ry(im,i))*yy9
+ y9z=(yy99*(rz(jp,i)+rz(im,i))-yyy9a*rz(jp,i)
+ $ -yyy9b*rz(im,i))*yy9
+
+ yy1010=1.0D0/(dis(jp,i)*dis(jp,jpp))
+ yyy10=pina4(imm,j)/(dis(jp,i)**2)
+ yy10=-pina4(imm,j)/dshe
+ y10x=(yy1010*rx(jp,jpp)-yyy10*rx(jp,i))*yy10
+ y10y=(yy1010*ry(jp,jpp)-yyy10*ry(jp,i))*yy10
+ y10z=(yy1010*rz(jp,jpp)-yyy10*rz(jp,i))*yy10
+
+ sx=y66x+y8x+y9x+y10x
+ sy=y66y+y8y+y9y+y10y
+ sz=y66z+y8z+y9z+y10z
+
+ sx1=y8x
+ sy1=y8y
+ sz1=y8z
+ sx2=y66x+y9x+y10x
+ sy2=y66y+y9y+y10y
+ sz2=y66z+y9z+y10z
+
+ shefx(i,5)=shefx(i,5)-sx*vbetam(imm,j)
+ $ -sx1*vbetam1(imm,j)-sx2*vbetam2(imm,j)
+ shefy(i,5)=shefy(i,5)-sy*vbetam(imm,j)
+ $ -sy1*vbetam1(imm,j)-sy2*vbetam2(imm,j)
+ shefz(i,5)=shefz(i,5)-sz*vbetam(imm,j)
+ $ -sz1*vbetam1(imm,j)-sz2*vbetam2(imm,j)
+
+! shefx(i,5)=shefx(i,5)
+! $ -sx1*vbetam1(imm,j)-sx2*vbetam2(imm,j)
+! shefy(i,5)=shefy(i,5)
+! $ -sy1*vbetam1(imm,j)-sy2*vbetam2(imm,j)
+! shefz(i,5)=shefz(i,5)
+! $ -sz1*vbetam1(imm,j)-sz2*vbetam2(imm,j)
+
+ endif
+ci endif
+
+ enddo
+ enddo
+
+ return
+ end
+c--------------------------------------------------------------------------c
+ subroutine sheetforce6
+ implicit none
+ integer maxca
+ parameter(maxca=800)
+ real*8 dfa_cutoff,dfa_cutoff_delta
+ parameter(dfa_cutoff=15.5d0)
+ parameter(dfa_cutoff_delta=0.5d0)
+cc**********************************************************************
+ real*8 vbetap(maxca,maxca),vbetam(maxca,maxca)
+ real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca)
+ real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca)
+ real*8 pin1(maxca,maxca),pin2(maxca,maxca)
+ real*8 pin3(maxca,maxca),pin4(maxca,maxca)
+ real*8 pina1(maxca,maxca),pina2(maxca,maxca)
+ real*8 pina3(maxca,maxca),pina4(maxca,maxca)
+ real*8 rx(maxca,maxca)
+ real*8 ry(maxca,maxca),rz(maxca,maxca)
+ real*8 bx(maxca),by(maxca),bz(maxca)
+ real*8 dis(maxca,maxca)
+ real*8 shefx(maxca,12),shefy(maxca,12)
+ real*8 shefz(maxca,12)
+ real*8 dp45,dm45,w_beta
+ real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb,
+ $ c00,s00,ulnex,dnex
+ integer inb,nmax,iselect
+cc**********************************************************************
+ common /phys1/ inb,nmax,iselect
+ common /kyori2/ dis
+ common /difvec/ rx,ry,rz
+ common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb,
+ $ c00,s00,ulnex,dnex
+ common /sheconst/ dp45,dm45,w_beta
+ common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2
+ common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4
+ common /shef/ shefx,shefy,shefz
+ci integer istrand(maxca,maxca)
+ci integer istrand_p(maxca,maxca),istrand_m(maxca,maxca)
+ci common /shetest/ istrand,istrand_p,istrand_m
+cc**********************************************************************
+C local variables
+ integer i,imm,im,jp,jpp,j,ip
+ real*8 yy1,y1x,y1y,y1z,y11x,y11y,y11z,yy33,yyy3,yy3,y3x,y3y,y3z
+ real*8 yy44,yyy4a,yyy4b,yy4,y4x,y4y,y4z,yy55,yyy5,yy5,y5x,y5y,y5z
+ real*8 sx,sy,sz,sx1,sy1,sz1,sx2,sy2,sz2,y6x,y6y,y6z,y66x,y66y
+ real*8 yy88,yyy8a,yyy8b,yy8,y8x,y8y,y8z,yy99,yyy9,yy9,y9x,y9y,y9z
+ real*8 yy1010,yyy10,yy10,y10x,y10y,y10z,yyy8,yyy9a,yyy9b,yyy4
+ real*8 yyy3a,yyy3b,y66z,yy6,yyy5a,yyy5b
+ real*8 e_gcont,fprim_gcont
+C********************************************************************************
+ do i=2,inb-6
+ ip=i+1
+ im=i-1
+ do j=i+3,inb-3
+
+ if (dis(im,j).lt.dfa_cutoff) then
+ call gcont(dis(im,j),dfa_cutoff-dfa_cutoff_delta,1.0D0,
+ & dfa_cutoff_delta,e_gcont,fprim_gcont)
+
+ jp=j+1
+ jpp=j+2
+
+ci if(istrand(im,j).eq.1
+ci & .and.(istrand_p(im,j)+istrand_m(im,j)).ge.1) then
+
+
+ yy1=-(dis(i,jp)-ulhb)/dlhb
+ y1x=rx(jp,i)/dis(i,jp)
+ y1y=ry(jp,i)/dis(i,jp)
+ y1z=rz(jp,i)/dis(i,jp)
+ y11x=yy1*y1x
+ y11y=yy1*y1y
+ y11z=yy1*y1z
+
+ yy33=1.0D0/(dis(i,jp)*dis(i,ip))
+ yyy3a=pin1(im,j)/(dis(i,jp)**2)
+ yyy3b=pin1(im,j)/(dis(i,ip)**2)
+ yy3=-pin1(im,j)/dshe
+ y3x=(-yy33*(rx(i,ip)+rx(i,jp))+yyy3a*rx(i,jp)
+ $ +yyy3b*rx(i,ip))*yy3
+ y3y=(-yy33*(ry(i,ip)+ry(i,jp))+yyy3a*ry(i,jp)
+ $ +yyy3b*ry(i,ip))*yy3
+ y3z=(-yy33*(rz(i,ip)+rz(i,jp))+yyy3a*rz(i,jp)
+ $ +yyy3b*rz(i,ip))*yy3
+
+ yy44=1.0D0/(dis(i,jp)*dis(jp,jpp))
+ yyy4=pin2(im,j)/(dis(i,jp)**2)
+ yy4=-pin2(im,j)/dshe
+ y4x=(-yy44*rx(jp,jpp)+yyy4*rx(i,jp))*yy4
+ y4y=(-yy44*ry(jp,jpp)+yyy4*ry(i,jp))*yy4
+ y4z=(-yy44*rz(jp,jpp)+yyy4*rz(i,jp))*yy4
+
+ yy55=1.0D0/(dis(ip,jpp)*dis(i,ip))
+ yyy5=pin3(im,j)/(dis(i,ip)**2)
+ yy5=-pin3(im,j)/dshe
+ y5x=(-yy55*rx(ip,jpp)+yyy5*rx(i,ip))*yy5
+ y5y=(-yy55*ry(ip,jpp)+yyy5*ry(i,ip))*yy5
+ y5z=(-yy55*rz(ip,jpp)+yyy5*rz(i,ip))*yy5
+
+ sx=y11x+y3x+y4x+y5x
+ sy=y11y+y3y+y4y+y5y
+ sz=y11z+y3z+y4z+y5z
+
+ sx1=y11x+y3x+y4x
+ sy1=y11y+y3y+y4y
+ sz1=y11z+y3z+y4z
+ sx2=y5x
+ sy2=y5y
+ sz2=y5z
+
+ shefx(i,6)=shefx(i,6)-sx*vbetap(im,j)
+ $ -sx1*vbetap1(im,j)-sx2*vbetap2(im,j)
+ shefy(i,6)=shefy(i,6)-sy*vbetap(im,j)
+ $ -sy1*vbetap1(im,j)-sy2*vbetap2(im,j)
+ shefz(i,6)=shefz(i,6)-sz*vbetap(im,j)
+ $ -sz1*vbetap1(im,j)-sz2*vbetap2(im,j)
+! shefx(i,6)=shefx(i,6)
+! $ -sx1*vbetap1(im,j)-sx2*vbetap2(im,j)
+! shefy(i,6)=shefy(i,6)
+! $ -sy1*vbetap1(im,j)-sy2*vbetap2(im,j)
+! shefz(i,6)=shefz(i,6)
+! $ -sz1*vbetap1(im,j)-sz2*vbetap2(im,j)
+
+ yy6=-(dis(jpp,i)-uldhb)/dldhb
+ y6x=rx(jpp,i)/dis(jpp,i)
+ y6y=ry(jpp,i)/dis(jpp,i)
+ y6z=rz(jpp,i)/dis(jpp,i)
+ y66x=yy6*y6x
+ y66y=yy6*y6y
+ y66z=yy6*y6z
+
+ yy88=1.0D0/(dis(i,jpp)*dis(i,ip))
+ yyy8a=pina1(im,j)/(dis(i,jpp)**2)
+ yyy8b=pina1(im,j)/(dis(i,ip)**2)
+ yy8=-pina1(im,j)/dshe
+ y8x=(-yy88*(rx(i,jpp)+rx(i,ip))+yyy8a*rx(i,jpp)
+ $ +yyy8b*rx(i,ip))*yy8
+ y8y=(-yy88*(ry(i,jpp)+ry(i,ip))+yyy8a*ry(i,jpp)
+ $ +yyy8b*ry(i,ip))*yy8
+ y8z=(-yy88*(rz(i,jpp)+rz(i,ip))+yyy8a*rz(i,jpp)
+ $ +yyy8b*rz(i,ip))*yy8
+
+ yy99=1.0D0/(dis(i,jpp)*dis(jp,jpp))
+ yyy9=pina2(im,j)/(dis(i,jpp)**2)
+ yy9=-pina2(im,j)/dshe
+ y9x=(-yy99*rx(jp,jpp)+yyy9*rx(i,jpp))*yy9
+ y9y=(-yy99*ry(jp,jpp)+yyy9*ry(i,jpp))*yy9
+ y9z=(-yy99*rz(jp,jpp)+yyy9*rz(i,jpp))*yy9
+
+ yy1010=1.0D0/(dis(jp,ip)*dis(i,ip))
+ yyy10=pina3(im,j)/(dis(i,ip)**2)
+ yy10=-pina3(im,j)/dshe
+ y10x=(-yy1010*rx(jp,ip)+yyy10*rx(i,ip))*yy10
+ y10y=(-yy1010*ry(jp,ip)+yyy10*ry(i,ip))*yy10
+ y10z=(-yy1010*rz(jp,ip)+yyy10*rz(i,ip))*yy10
+
+ sx=y66x+y8x+y9x+y10x
+ sy=y66y+y8y+y9y+y10y
+ sz=y66z+y8z+y9z+y10z
+
+ sx1=y66x+y8x+y9x
+ sy1=y66y+y8y+y9y
+ sz1=y66z+y8z+y9z
+ sx2=y10x
+ sy2=y10y
+ sz2=y10z
+
+ shefx(i,6)=shefx(i,6)-sx*vbetam(im,j)
+ $ -sx1*vbetam1(im,j)-sx2*vbetam2(im,j)
+ shefy(i,6)=shefy(i,6)-sy*vbetam(im,j)
+ $ -sy1*vbetam1(im,j)-sy2*vbetam2(im,j)
+ shefz(i,6)=shefz(i,6)-sz*vbetam(im,j)
+ $ -sz1*vbetam1(im,j)-sz2*vbetam2(im,j)
+
+! shefx(i,6)=shefx(i,6)
+! $ -sx1*vbetam1(im,j)-sx2*vbetam2(im,j)
+! shefy(i,6)=shefy(i,6)
+! $ -sy1*vbetam1(im,j)-sy2*vbetam2(im,j)
+! shefz(i,6)=shefz(i,6)
+! $ -sz1*vbetam1(im,j)-sz2*vbetam2(im,j)
+
+ endif
+ci endif
+
+ enddo
+ enddo
+
+ return
+ end
+c-----------------------------------------------------------------------
+ subroutine sheetforce11
+ implicit none
+ integer maxca
+ parameter(maxca=800)
+ real*8 dfa_cutoff,dfa_cutoff_delta
+ parameter(dfa_cutoff=15.5d0)
+ parameter(dfa_cutoff_delta=0.5d0)
+cc**********************************************************************
+ real*8 vbetap(maxca,maxca),vbetam(maxca,maxca)
+ real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca)
+ real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca)
+ real*8 pin1(maxca,maxca),pin2(maxca,maxca)
+ real*8 pin3(maxca,maxca),pin4(maxca,maxca)
+ real*8 pina1(maxca,maxca),pina2(maxca,maxca)
+ real*8 pina3(maxca,maxca),pina4(maxca,maxca)
+ real*8 rx(maxca,maxca)
+ real*8 ry(maxca,maxca),rz(maxca,maxca)
+ real*8 bx(maxca),by(maxca),bz(maxca)
+ real*8 dis(maxca,maxca)
+ real*8 shefx(maxca,12),shefy(maxca,12)
+ real*8 shefz(maxca,12)
+ real*8 dp45,dm45,w_beta
+ real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb,
+ $ c00,s00,ulnex,dnex
+ integer inb,nmax,iselect
+cc**********************************************************************
+ common /phys1/ inb,nmax,iselect
+ common /kyori2/ dis
+ common /difvec/ rx,ry,rz
+ common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb,
+ $ c00,s00,ulnex,dnex
+ common /sheconst/ dp45,dm45,w_beta
+ common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2
+ common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4
+ common /shef/ shefx,shefy,shefz
+ci integer istrand(maxca,maxca)
+ci integer istrand_p(maxca,maxca),istrand_m(maxca,maxca)
+ci common /shetest/ istrand,istrand_p,istrand_m
+C********************************************************************************
+C local variables
+ integer j,jm,jmm,ip,i,ipp
+ real*8 yy1,y1x,y1y,y1z,y11x,y11y,y11z,yy33,yyy3,yy3,y3x,y3y,y3z
+ real*8 yy44,yyy4a,yyy4b,yy4,y4x,y4y,y4z,yy55,yyy5,yy5,y5x,y5y
+ real*8 sx,sy,sz,sx1,sy1,sz1,sx2,sy2,sz2,y6x,y6y,y6z,y66x,y66y
+ real*8 yy88,yyy8a,yyy8b,yy8,y8x,y8y,y8z,yy99,yyy9,yy9,y9x,y9y
+ real*8 yy1010,yyy10,yy10,y10x,y10y,y10z,yyy4,yyy5a,yyy5b,yy6
+ real*8 yyy9a,yyy9b,y5z,y66z,y9z,yyy8
+ real*8 e_gcont,fprim_gcont
+C********************************************************************************
+
+ do j=7,inb-1
+ jm=j-1
+ jmm=j-2
+ do i=1,j-6
+
+ if (dis(i,jmm).lt.dfa_cutoff) then
+ call gcont(dis(i,jmm),dfa_cutoff-dfa_cutoff_delta,1.0D0,
+ & dfa_cutoff_delta,e_gcont,fprim_gcont)
+
+ ip=i+1
+ ipp=i+2
+
+ci if(istrand(i,jmm).eq.1
+ci & .and.(istrand_p(i,jmm)+istrand_m(i,jmm)).ge.1) then
+
+
+ yy1=-(dis(ipp,j)-ulhb)/dlhb
+ y1x=rx(ipp,j)/dis(ipp,j)
+ y1y=ry(ipp,j)/dis(ipp,j)
+ y1z=rz(ipp,j)/dis(ipp,j)
+ y11x=yy1*y1x
+ y11y=yy1*y1y
+ y11z=yy1*y1z
+
+ yy33=1.0D0/(dis(ip,jm)*dis(jm,j))
+ yyy3=pin2(i,jmm)/(dis(jm,j)**2)
+ yy3=-pin2(i,jmm)/dshe
+ y3x=(yy33*rx(ip,jm)-yyy3*rx(jm,j))*yy3
+ y3y=(yy33*ry(ip,jm)-yyy3*ry(jm,j))*yy3
+ y3z=(yy33*rz(ip,jm)-yyy3*rz(jm,j))*yy3
+
+ yy44=1.0D0/(dis(ipp,j)*dis(ip,ipp))
+ yyy4=pin3(i,jmm)/(dis(ipp,j)**2)
+ yy4=-pin3(i,jmm)/dshe
+ y4x=(yy44*rx(ip,ipp)-yyy4*rx(ipp,j))*yy4
+ y4y=(yy44*ry(ip,ipp)-yyy4*ry(ipp,j))*yy4
+ y4z=(yy44*rz(ip,ipp)-yyy4*rz(ipp,j))*yy4
+
+ yy55=1.0D0/(dis(ipp,j)*dis(jm,j))
+ yyy5a=pin4(i,jmm)/(dis(ipp,j)**2)
+ yyy5b=pin4(i,jmm)/(dis(jm,j)**2)
+ yy5=-pin4(i,jmm)/dshe
+ y5x=(yy55*(rx(jm,j)+rx(ipp,j))-yyy5a*rx(ipp,j)
+ $ -yyy5b*rx(jm,j))*yy5
+ y5y=(yy55*(ry(jm,j)+ry(ipp,j))-yyy5a*ry(ipp,j)
+ $ -yyy5b*ry(jm,j))*yy5
+ y5z=(yy55*(rz(jm,j)+rz(ipp,j))-yyy5a*rz(ipp,j)
+ $ -yyy5b*rz(jm,j))*yy5
+
+ sx=y11x+y3x+y4x+y5x
+ sy=y11y+y3y+y4y+y5y
+ sz=y11z+y3z+y4z+y5z
+
+ sx1=y3x
+ sy1=y3y
+ sz1=y3z
+ sx2=y11x+y4x+y5x
+ sy2=y11y+y4y+y5y
+ sz2=y11z+y4z+y5z
+
+ shefx(j,11)=shefx(j,11)-sx*vbetap(i,jmm)
+ $ -sx1*vbetap1(i,jmm)-sx2*vbetap2(i,jmm)
+ shefy(j,11)=shefy(j,11)-sy*vbetap(i,jmm)
+ $ -sy1*vbetap1(i,jmm)-sy2*vbetap2(i,jmm)
+ shefz(j,11)=shefz(j,11)-sz*vbetap(i,jmm)
+ $ -sz1*vbetap1(i,jmm)-sz2*vbetap2(i,jmm)
+
+! shefx(j,11)=shefx(j,11)
+! $ -sx1*vbetap1(i,jmm)-sx2*vbetap2(i,jmm)
+! shefy(j,11)=shefy(j,11)
+! $ -sy1*vbetap1(i,jmm)-sy2*vbetap2(i,jmm)
+! shefz(j,11)=shefz(j,11)
+! $ -sz1*vbetap1(i,jmm)-sz2*vbetap2(i,jmm)
+
+ yy6=-(dis(ip,j)-uldhb)/dldhb
+ y6x=rx(ip,j)/dis(ip,j)
+ y6y=ry(ip,j)/dis(ip,j)
+ y6z=rz(ip,j)/dis(ip,j)
+ y66x=yy6*y6x
+ y66y=yy6*y6y
+ y66z=yy6*y6z
+
+ yy88=1.0D0/(dis(ip,j)*dis(ip,ipp))
+ yyy8=pina1(i,jmm)/(dis(ip,j)**2)
+ yy8=-pina1(i,jmm)/dshe
+ y8x=(yy88*rx(ip,ipp)-yyy8*rx(ip,j))*yy8
+ y8y=(yy88*ry(ip,ipp)-yyy8*ry(ip,j))*yy8
+ y8z=(yy88*rz(ip,ipp)-yyy8*rz(ip,j))*yy8
+
+ yy99=1.0D0/(dis(ip,j)*dis(jm,j))
+ yyy9a=pina2(i,jmm)/(dis(ip,j)**2)
+ yyy9b=pina2(i,jmm)/(dis(jm,j)**2)
+ yy9=-pina2(i,jmm)/dshe
+ y9x=(yy99*(rx(jm,j)+rx(ip,j))-yyy9a*rx(ip,j)
+ $ -yyy9b*rx(jm,j))*yy9
+ y9y=(yy99*(ry(jm,j)+ry(ip,j))-yyy9a*ry(ip,j)
+ $ -yyy9b*ry(jm,j))*yy9
+ y9z=(yy99*(rz(jm,j)+rz(ip,j))-yyy9a*rz(ip,j)
+ $ -yyy9b*rz(jm,j))*yy9
+
+ yy1010=1.0D0/(dis(jm,ipp)*dis(jm,j))
+ yyy10=pina4(i,jmm)/(dis(jm,j)**2)
+ yy10=-pina4(i,jmm)/dshe
+ y10x=(yy1010*rx(jm,ipp)-yyy10*rx(jm,j))*yy10
+ y10y=(yy1010*ry(jm,ipp)-yyy10*ry(jm,j))*yy10
+ y10z=(yy1010*rz(jm,ipp)-yyy10*rz(jm,j))*yy10
+
+ sx=y66x+y8x+y9x+y10x
+ sy=y66y+y8y+y9y+y10y
+ sz=y66z+y8z+y9z+y10z
+
+ sx1=y66x+y8x+y9x
+ sy1=y66y+y8y+y9y
+ sz1=y66z+y8z+y9z
+ sx2=y10x
+ sy2=y10y
+ sz2=y10z
+
+ shefx(j,11)=shefx(j,11)-sx*vbetam(i,jmm)
+ $ -sx1*vbetam1(i,jmm)-sx2*vbetam2(i,jmm)
+ shefy(j,11)=shefy(j,11)-sy*vbetam(i,jmm)
+ $ -sy1*vbetam1(i,jmm)-sy2*vbetam2(i,jmm)
+ shefz(j,11)=shefz(j,11)-sz*vbetam(i,jmm)
+ $ -sz1*vbetam1(i,jmm)-sz2*vbetam2(i,jmm)
+
+! shefx(j,11)=shefx(j,11)
+! $ -sx1*vbetam1(i,jmm)-sx2*vbetam2(i,jmm)
+! shefy(j,11)=shefy(j,11)
+! $ -sy1*vbetam1(i,jmm)-sy2*vbetam2(i,jmm)
+! shefz(j,11)=shefz(j,11)
+! $ -sz1*vbetam1(i,jmm)-sz2*vbetam2(i,jmm)
+
+ endif
+ci endif
+
+ enddo
+ enddo
+
+ return
+ end
+c-----------------------------------------------------------------------
+ subroutine sheetforce12
+ implicit none
+ integer maxca
+ parameter(maxca=800)
+ real*8 dfa_cutoff,dfa_cutoff_delta
+ parameter(dfa_cutoff=15.5d0)
+ parameter(dfa_cutoff_delta=0.5d0)
+cc**********************************************************************
+ real*8 vbetap(maxca,maxca),vbetam(maxca,maxca)
+ real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca)
+ real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca)
+ real*8 pin1(maxca,maxca),pin2(maxca,maxca)
+ real*8 pin3(maxca,maxca),pin4(maxca,maxca)
+ real*8 pina1(maxca,maxca),pina2(maxca,maxca)
+ real*8 pina3(maxca,maxca),pina4(maxca,maxca)
+ real*8 rx(maxca,maxca)
+ real*8 ry(maxca,maxca),rz(maxca,maxca)
+ real*8 bx(maxca),by(maxca),bz(maxca)
+ real*8 dis(maxca,maxca)
+ real*8 shefx(maxca,12),shefy(maxca,12)
+ real*8 shefz(maxca,12)
+ real*8 dp45,dm45,w_beta
+ real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb,
+ $ c00,s00,ulnex,dnex
+ integer inb,nmax,iselect
+cc**********************************************************************
+ common /phys1/ inb,nmax,iselect
+ common /kyori2/ dis
+ common /difvec/ rx,ry,rz
+ common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb,
+ $ c00,s00,ulnex,dnex
+ common /sheconst/ dp45,dm45,w_beta
+ common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2
+ common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4
+ common /shef/ shefx,shefy,shefz
+ci integer istrand(maxca,maxca)
+ci integer istrand_p(maxca,maxca),istrand_m(maxca,maxca)
+ci common /shetest/ istrand,istrand_p,istrand_m
+cc**********************************************************************
+C local variables
+ integer j,jm,jmm,ip,i,ipp,jp
+ real*8 yy1,y1x,y1y,y1z,y11x,y11y,y11z,yy33,yyy3,yy3,y3x,y3y,y3z
+ real*8 yy44,yyy4a,yyy4b,yy4,y4x,y4y,y4z,yy55,yyy5,yy5,y5x,y5y,y5z
+ real*8 sx,sy,sz,sx1,sy1,sz1,sx2,sy2,sz2,y6x,y6y,y6z,y66x,y66y,y66z
+ real*8 yy88,yyy8a,yyy8b,yy8,y8x,y8y,y8z,yy99,yyy9,yy9,y9x,y9y,y9z
+ real*8 yy1010,yyy10,yy10,y10x,y10y,y10z,yyy10a,yyy10b,yy6,yyy8
+ real*8 e_gcont,fprim_gcont
+!c*************************************************************************c
+ do j=6,inb-2
+ jp=j+1
+ jm=j-1
+ do i=1,j-5
+
+ if (dis(i,jm).lt.dfa_cutoff) then
+ call gcont(dis(i,jm),dfa_cutoff-dfa_cutoff_delta,1.0D0,
+ & dfa_cutoff_delta,e_gcont,fprim_gcont)
+
+ ip=i+1
+ ipp=i+2
+
+ci if(istrand(i,jm).eq.1
+ci & .and.(istrand_p(i,jm)+istrand_m(i,jm)).ge.1) then
+
+
+ yy1=-(dis(ip,j)-ulhb)/dlhb
+ y1x=rx(ip,j)/dis(ip,j)
+ y1y=ry(ip,j)/dis(ip,j)
+ y1z=rz(ip,j)/dis(ip,j)
+ y11x=y1x*yy1
+ y11y=y1y*yy1
+ y11z=y1z*yy1
+
+ yy33=1.0D0/(dis(ip,j)*dis(ip,ipp))
+ yyy3=pin1(i,jm)/(dis(ip,j)**2)
+ yy3=-pin1(i,jm)/dshe
+ y3x=(yy33*rx(ip,ipp)-yyy3*rx(ip,j))*yy3
+ y3y=(yy33*ry(ip,ipp)-yyy3*ry(ip,j))*yy3
+ y3z=(yy33*rz(ip,ipp)-yyy3*rz(ip,j))*yy3
+ yy44=1.0D0/(dis(ip,j)*dis(j,jp))
+
+ yyy4a=pin2(i,jm)/(dis(ip,j)**2)
+ yyy4b=pin2(i,jm)/(dis(j,jp)**2)
+ yy4=-pin2(i,jm)/dshe
+ y4x=(yy44*(rx(j,jp)-rx(ip,j))-yyy4a*rx(ip,j)
+ $ +yyy4b*rx(j,jp))*yy4
+ y4y=(yy44*(ry(j,jp)-ry(ip,j))-yyy4a*ry(ip,j)
+ $ +yyy4b*ry(j,jp))*yy4
+ y4z=(yy44*(rz(j,jp)-rz(ip,j))-yyy4a*rz(ip,j)
+ $ +yyy4b*rz(j,jp))*yy4
+
+ yy55=1.0D0/(dis(ipp,jp)*dis(j,jp))
+ yyy5=pin4(i,jm)/(dis(j,jp)**2)
+ yy5=-pin4(i,jm)/dshe
+ y5x=(-yy55*rx(ipp,jp)+yyy5*rx(j,jp))*yy5
+ y5y=(-yy55*ry(ipp,jp)+yyy5*ry(j,jp))*yy5
+ y5z=(-yy55*rz(ipp,jp)+yyy5*rz(j,jp))*yy5
+
+ sx=y11x+y3x+y4x+y5x
+ sy=y11y+y3y+y4y+y5y
+ sz=y11z+y3z+y4z+y5z
+
+ sx1=y11x+y3x+y4x
+ sy1=y11y+y3y+y4y
+ sz1=y11z+y3z+y4z
+ sx2=y5x
+ sy2=y5y
+ sz2=y5z
+
+ shefx(j,12)=shefx(j,12)-sx*vbetap(i,jm)
+ $ -sx1*vbetap1(i,jm)-sx2*vbetap2(i,jm)
+ shefy(j,12)=shefy(j,12)-sy*vbetap(i,jm)
+ $ -sy1*vbetap1(i,jm)-sy2*vbetap2(i,jm)
+ shefz(j,12)=shefz(j,12)-sz*vbetap(i,jm)
+ $ -sz1*vbetap1(i,jm)-sz2*vbetap2(i,jm)
+
+! shefx(j,12)=shefx(j,12)
+! $ -sx1*vbetap1(i,jm)-sx2*vbetap2(i,jm)
+! shefy(j,12)=shefy(j,12)
+! $ -sy1*vbetap1(i,jm)-sy2*vbetap2(i,jm)
+! shefz(j,12)=shefz(j,12)
+! $ -sz1*vbetap1(i,jm)-sz2*vbetap2(i,jm)
+
+ yy6=-(dis(ipp,j)-uldhb)/dldhb
+ y6x=rx(ipp,j)/dis(ipp,j)
+ y6y=ry(ipp,j)/dis(ipp,j)
+ y6z=rz(ipp,j)/dis(ipp,j)
+ y66x=yy6*y6x
+ y66y=yy6*y6y
+ y66z=yy6*y6z
+
+ yy88=1.0D0/(dis(ip,jp)*dis(j,jp))
+ yyy8=pina2(i,jm)/(dis(j,jp)**2)
+ yy8=-pina2(i,jm)/dshe
+ y8x=(-yy88*rx(ip,jp)+yyy8*rx(j,jp))*yy8
+ y8y=(-yy88*ry(ip,jp)+yyy8*ry(j,jp))*yy8
+ y8z=(-yy88*rz(ip,jp)+yyy8*rz(j,jp))*yy8
+
+ yy99=1.0D0/(dis(j,ipp)*dis(ip,ipp))
+ yyy9=pina3(i,jm)/(dis(j,ipp)**2)
+ yy9=-pina3(i,jm)/dshe
+ y9x=(-yy99*rx(ip,ipp)+yyy9*rx(j,ipp))*yy9
+ y9y=(-yy99*ry(ip,ipp)+yyy9*ry(j,ipp))*yy9
+ y9z=(-yy99*rz(ip,ipp)+yyy9*rz(j,ipp))*yy9
+
+ yy1010=1.0D0/(dis(j,ipp)*dis(j,jp))
+ yyy10a=pina4(i,jm)/(dis(j,ipp)**2)
+ yyy10b=pina4(i,jm)/(dis(j,jp)**2)
+ yy10=-pina4(i,jm)/dshe
+ y10x=(-yy1010*(rx(j,ipp)+rx(j,jp))+yyy10a*rx(j,ipp)
+ $ +yyy10b*rx(j,jp))*yy10
+ y10y=(-yy1010*(ry(j,ipp)+ry(j,jp))+yyy10a*ry(j,ipp)
+ $ +yyy10b*ry(j,jp))*yy10
+ y10z=(-yy1010*(rz(j,ipp)+rz(j,jp))+yyy10a*rz(j,ipp)
+ $ +yyy10b*rz(j,jp))*yy10
+
+ sx=y66x+y8x+y9x+y10x
+ sy=y66y+y8y+y9y+y10y
+ sz=y66z+y8z+y9z+y10z
+
+ sx1=y8x
+ sy1=y8y
+ sz1=y8z
+ sx2=y66x+y9x+y10x
+ sy2=y66y+y9y+y10y
+ sz2=y66z+y9z+y10z
+
+ shefx(j,12)=shefx(j,12)-sx*vbetam(i,jm)
+ $ -sx1*vbetam1(i,jm)-sx2*vbetam2(i,jm)
+ shefy(j,12)=shefy(j,12)-sy*vbetam(i,jm)
+ $ -sy1*vbetam1(i,jm)-sy2*vbetam2(i,jm)
+ shefz(j,12)=shefz(j,12)-sz*vbetam(i,jm)
+ $ -sz1*vbetam1(i,jm)-sz2*vbetam2(i,jm)
+
+ endif
+
+ci endif
+
+ ENDDO
+ ENDDO
+
+ RETURN
+ END
+C===============================================================================
--- /dev/null
+ subroutine elecont(lprint,ncont,icont,ist,ien,ipermmin)
+ 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 iperm,ipermmin,ii,jj
+ 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, rij,zj_temp,xj_temp,yj_temp,
+ & sscale,sscagrad,dist_temp,xj_safe,yj_safe,zj_safe,dist_init
+ 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),xshift,yshift,zshift,isubchap
+ 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
+ ii=iperm(i,ipermmin)
+ xi=c(1,ii)
+ yi=c(2,ii)
+ zi=c(3,ii)
+ dxi=c(1,ii+1)-c(1,ii)
+ dyi=c(2,ii+1)-c(2,ii)
+ dzi=c(3,ii+1)-c(3,ii)
+ xmedi=xi+0.5*dxi
+ ymedi=yi+0.5*dyi
+ zmedi=zi+0.5*dzi
+ xmedi=mod(xmedi,boxxsize)
+ if (xmedi.lt.0) xmedi=xmedi+boxxsize
+ ymedi=mod(ymedi,boxysize)
+ if (ymedi.lt.0) ymedi=ymedi+boxysize
+ zmedi=mod(zmedi,boxzsize)
+ if (zmedi.lt.0) zmedi=zmedi+boxzsize
+ do 4 j=i+2,ien-1
+ jj=iperm(j,ipermmin)
+ 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
+ & .or.iteli.eq.0 .or.itelj.eq.0) goto 4
+ aaa=appc(iteli,itelj)
+ bbb=bppc(iteli,itelj)
+ ael6i=ael6c(iteli,itelj)
+ ael3i=ael3c(iteli,itelj)
+ dxj=c(1,jj+1)-c(1,jj)
+ dyj=c(2,jj+1)-c(2,jj)
+ dzj=c(3,jj+1)-c(3,jj)
+ xj=c(1,jj)+0.5*dxj
+ yj=c(2,jj)+0.5*dyj
+ zj=c(3,jj)+0.5*dzj
+ xj=mod(xj,boxxsize)
+ if (xj.lt.0) xj=xj+boxxsize
+ yj=mod(yj,boxysize)
+ if (yj.lt.0) yj=yj+boxysize
+ zj=mod(zj,boxzsize)
+ if (zj.lt.0) zj=zj+boxzsize
+ dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
+ xj_safe=xj
+ yj_safe=yj
+ zj_safe=zj
+ isubchap=0
+ do xshift=-1,1
+ do yshift=-1,1
+ do zshift=-1,1
+ xj=xj_safe+xshift*boxxsize
+ yj=yj_safe+yshift*boxysize
+ zj=zj_safe+zshift*boxzsize
+ dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
+ if(dist_temp.lt.dist_init) then
+ dist_init=dist_temp
+ xj_temp=xj
+ yj_temp=yj
+ zj_temp=zj
+ isubchap=1
+ endif
+ enddo
+ enddo
+ enddo
+ if (isubchap.eq.1) then
+ xj=xj_temp-xmedi
+ yj=yj_temp-ymedi
+ zj=zj_temp-zmedi
+ else
+ xj=xj_safe-xmedi
+ yj=yj_safe-ymedi
+ zj=zj_safe-zmedi
+ endif
+ rij=xj*xj+yj*yj+zj*zj
+ sss=sscale(sqrt(rij))
+ sssgrad=sscagrad(sqrt(rij))
+ rrmij=1.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*sss
+ 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
--- /dev/null
+ 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
+c double precision tole /1.0d-1/
+ integer i,itj,ii,iii,j,k,l,licz,ipermin
+ integer ir,ib,ipar,iparm
+ integer iscor,islice,scount_buff(0:99)
+ real*4 csingle(3,maxres2)
+ double precision energ
+ double precision temp
+ 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
+c write (iout,*) "enecalc: nparmset ",nparmset
+c write (iout,*) "enecalc: tormode ",tor_mode
+#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
+ write (iout,*) "indstart(me1),indend(me1)"
+ &,indstart(me1),indend(me1)
+ 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
+ anatemp= 1.0d0/(beta_h(ib,ipar)*1.987D-3)
+ q(nQ+1,iii+1)=rmsnat(iii+1,ipermin)
+ 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,*) "tuz przed energia"
+ call etotal(energia(0),fT)
+C write (iout,*) "tuz za energia"
+#ifdef DEBUG
+ write (iout,*) "Conformation",i
+c write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres),
+c & ((c(l,k+nres),l=1,3),k=nnt,nct)
+ call enerprint(energia(0),fT)
+c write (iout,'(2i5,21f8.2)') i,iparm,(energia(k),k=1,21)
+c write (iout,*) "ftors(1)",ftors(1)
+c call briefout(i,energia(0))
+c temp=1.0d0/(beta_h(ib,ipar)*1.987D-3)
+c write (iout,*) "temp", temp
+c call pdbout(i,temp,energia(0),energia(0),0.0d0,0.0d0)
+#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)-energia(27)).gt.tole) then
+ & 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)+energia(27),eini," point",
+ & " the value read in: ",energia(0),eini," point",
+ & iii+1,indstart(me1)+iii," T",
+ & 1.0d0/(1.987D-3*beta_h(ib,ipar))
+ write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres),
+ & ((c(l,k+nres),l=1,3),k=nnt,nct)
+c call intout
+ call pdbout(indstart(me1)+iii,
+ & 1.0d0/(1.987D-3*beta_h(ib,ipar)),energia(0),eini,0.0d0,0.0d0)
+ call enerprint(energia(0),fT)
+ 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
+C write (iout,*) "Czy tu dochodze"
+ potE(iii+1,iparm)=energia(0)
+ do k=1,n_ene
+ 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
+c call enerprint(energia(0),fT)
+#endif
+#ifdef DEBUG
+ 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)
+ call pdbout(ii+1,beta_h(ib,ipar),efree,energia(0),0.0d0,rmsdev)
+#endif
+ endif
+
+ enddo ! iparm
+
+ iii=iii+1
+ if (q(1,iii).le.0.0d0 .and. indpdb.gt.0)
+ & q(1,iii)=qwolynes(0,0,ipermin)
+ 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_buff(me)=iii
+ write (iout,*) "Me",me," scount_buff",scount_buff(me)
+ call flush(iout)
+c Master gathers updated numbers of conformations written by all procs.
+c call MPI_AllGather(MPI_IN_PLACE,1,MPI_DATATYPE_NULL,scount(0),1,
+c & MPI_INTEGER, WHAM_COMM, IERROR)
+ call MPI_AllGather( scount_buff(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"
+ include "COMMON.CONTACTS1"
+ 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, scount_buff(0:99)
+ integer isecstr(maxres)
+ write (licz2,'(bz,i2.2)') islice
+ call opentmp(islice,ientout,bprotfile_temp)
+ write (iout,*) "bprotfile_temp ",bprotfile_temp
+ 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
+c write (iout,*) "Calling conf_compar",i
+c call flush(iout)
+ anatemp= 1.0d0/(beta_h(ib,iparm)*1.987D-3)
+ if (indpdb.gt.0) then
+ call conf_compar(i,.false.,.true.)
+c else
+c call elecont(.false.,ncont,icont,nnt,nct)
+c call secondary2(.false.,.false.,ncont,icont,isecstr)
+ endif
+c write (iout,*) "Exit conf_compar",i
+c call flush(iout)
+ 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
+ if (dyn_ss) then
+ call xdrfint(ixdrf, idssb(j)+nres, iret)
+ call xdrfint(ixdrf, jdssb(j)+nres, iret)
+ else
+ call xdrfint_(ixdrf, ihpb(j), iret)
+ call xdrfint_(ixdrf, jhpb(j), iret)
+ endif
+ enddo
+ call xdrffloat_(ixdrf,real(eini),iret)
+ call xdrffloat_(ixdrf,real(efree),iret)
+ 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
+ if (dyn_ss) then
+ call xdrfint(ixdrf, idssb(j)+nres, iret)
+ call xdrfint(ixdrf, jdssb(j)+nres, iret)
+ else
+ call xdrfint(ixdrf, ihpb(j), iret)
+ call xdrfint(ixdrf, jhpb(j), iret)
+ endif
+ enddo
+ call xdrffloat(ixdrf,real(eini),iret)
+ call xdrffloat(ixdrf,real(efree),iret)
+ 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
+c if (.not.check_conf) then
+c conf_check=.true.
+c return
+c endif
+ call int_from_cart1(.false.)
+ do j=nnt+1,nct
+ if (itype(j-1).ne.ntyp1 .and. itype(j).ne.ntyp1 .and.
+ & (vbld(j).lt.2.0d0 .or. vbld(j).gt.6.5d0)) 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.itype(j).ne.ntyp1 .and.
+ & (vbld(nres+j)-dsc(iabs(itj))).gt.2.0d0) then
+ if (iprint.gt.0)
+ & write (iout,*) "Bad CA-SC bond length",j," ",vbld(nres+j),
+ & restyp(itj),itj,dsc(iabs(itj))," 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
--- /dev/null
+ 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)
+ include 'COMMON.FFIELD'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.CHAIN'
+ include 'COMMON.SHIELD'
+ include 'COMMON.CONTROL'
+ include 'COMMON.TORCNSTR'
+ double precision fact(6)
+c write(iout, '(a,i2)')'Calling etotal ipot=',ipot
+c call flush(iout)
+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,evdw_t)
+cd print '(a)','Exit ELJ'
+ goto 106
+C Lennard-Jones-Kihara potential (shifted).
+ 102 call eljk(evdw,evdw_t)
+ goto 106
+C Berne-Pechukas potential (dilated LJ, angular dependence).
+ 103 call ebp(evdw,evdw_t)
+ goto 106
+C Gay-Berne potential (shifted LJ, angular dependence).
+ 104 call egb(evdw,evdw_t)
+ goto 106
+C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
+ 105 call egbv(evdw,evdw_t)
+C write(iout,*) 'po elektostatyce'
+C
+C Calculate electrostatic (H-bonding) energy of the main chain.
+C
+ 106 continue
+ call vec_and_deriv
+ if (shield_mode.eq.1) then
+ call set_shield_fac
+ else if (shield_mode.eq.2) then
+ call set_shield_fac2
+ endif
+ call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
+C write(iout,*) 'po eelec'
+
+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
+C print *,'Bend energy finished.'
+ if (wang.gt.0d0) then
+ if (tor_mode.eq.0) then
+ call ebend(ebe)
+ else
+C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
+C energy function
+ call ebend_kcc(ebe)
+ endif
+ else
+ ebe=0.0d0
+ endif
+ ethetacnstr=0.0d0
+ if (with_theta_constr) call etheta_constr(ethetacnstr)
+c call ebend(ebe,ethetacnstr)
+cd print *,'Bend energy finished.'
+C
+C Calculate the SC local energy.
+C
+ call esc(escloc)
+C print *,'SCLOC energy finished.'
+C
+C Calculate the virtual-bond torsional energy.
+C
+ if (wtor.gt.0.0d0) then
+ if (tor_mode.eq.0) then
+ call etor(etors,fact(1))
+ else
+C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
+C energy function
+ call etor_kcc(etors,fact(1))
+ endif
+ else
+ etors=0.0d0
+ endif
+ edihcnstr=0.0d0
+ if (ndih_constr.gt.0) call etor_constr(edihcnstr)
+c print *,"Processor",myrank," computed Utor"
+C
+C 6/23/01 Calculate double-torsional energy
+C
+ if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
+ call etor_d(etors_d,fact(2))
+ else
+ etors_d=0
+ endif
+c print *,"Processor",myrank," computed Utord"
+C
+ call eback_sc_corr(esccor)
+
+ if (wliptran.gt.0) then
+ call Eliptransfer(eliptran)
+ endif
+
+C
+C 12/1/95 Multi-body terms
+C
+ n_corr=0
+ n_corr1=0
+ if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
+ & .or. wturn6.gt.0.0d0) then
+c write(iout,*)"calling multibody_eello"
+ call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
+c write (iout,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
+c write (iout,*) ecorr,ecorr5,ecorr6,eturn6
+ else
+ ecorr=0.0d0
+ ecorr5=0.0d0
+ ecorr6=0.0d0
+ eturn6=0.0d0
+ endif
+ if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
+c write (iout,*) "Calling multibody_hbond"
+ call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
+ endif
+c write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
+ if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
+ call e_saxs(Esaxs_constr)
+c write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
+ else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
+ call e_saxsC(Esaxs_constr)
+c write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
+ else
+ Esaxs_constr = 0.0d0
+ endif
+
+c write(iout,*) "TEST_ENE1 constr_homology=",constr_homology
+ if (constr_homology.ge.1) then
+ call e_modeller(ehomology_constr)
+ else
+ ehomology_constr=0.0d0
+ endif
+
+c write(iout,*) "TEST_ENE1 ehomology_constr=",ehomology_constr
+#ifdef DFA
+C BARTEK for dfa test!
+ if (wdfa_dist.gt.0) call edfad(edfadis)
+c write(iout,*)'edfad is finished!', wdfa_dist,edfadis
+ if (wdfa_tor.gt.0) call edfat(edfator)
+c write(iout,*)'edfat is finished!', wdfa_tor,edfator
+ if (wdfa_nei.gt.0) call edfan(edfanei)
+c write(iout,*)'edfan is finished!', wdfa_nei,edfanei
+ if (wdfa_beta.gt.0) call edfab(edfabet)
+c write(iout,*)'edfab is finished!', wdfa_beta,edfabet
+#endif
+
+c write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
+#ifdef SPLITELE
+ if (shield_mode.gt.0) then
+ etot=fact(1)*wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
+ & +welec*fact(1)*ees
+ & +fact(1)*wvdwpp*evdw1
+ & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
+ & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
+ & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
+ & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
+ & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
+ & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr+wsaxs*esaxs_constr
+ & +wliptran*eliptran*esaxs_constr
+ & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
+ & +wdfa_beta*edfabet
+ else
+ etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
+ & +wvdwpp*evdw1
+ & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
+ & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
+ & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
+ & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
+ & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
+ & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
+ & +wliptran*eliptran+wsaxs*esaxs_constr
+ & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
+ & +wdfa_beta*edfabet
+ endif
+#else
+ if (shield_mode.gt.0) then
+ etot=fact(1)wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
+ & +welec*fact(1)*(ees+evdw1)
+ & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
+ & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
+ & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
+ & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
+ & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
+ & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
+ & +wliptran*eliptran+wsaxs*esaxs_constr
+ & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
+ & +wdfa_beta*edfabet
+ 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+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
+ & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
+ & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
+ & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
+ & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
+ & +wliptran*eliptran+wsaxs*esaxs_constr
+ & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
+ & +wdfa_beta*edfabet
+ endif
+#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
+ energia(22)=eliptran
+ energia(24)=ethetacnstr
+ energia(26)=esaxs_constr
+ energia(27)=ehomology_constr
+ energia(28)=edfadis
+ energia(29)=edfator
+ energia(30)=edfanei
+ energia(31)=edfabet
+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
+#ifdef DEBUG
+ call enerprint(energia,fact)
+#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
+ if (shield_mode.eq.0) then
+ gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
+ & welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
+ & wbond*gradb(j,i)+
+ & wstrain*ghpbc(j,i)+
+ & wcorr*fact(3)*gradcorr(j,i)+
+ & wel_loc*fact(2)*gel_loc(j,i)+
+ & wturn3*fact(2)*gcorr3_turn(j,i)+
+ & wturn4*fact(3)*gcorr4_turn(j,i)+
+ & wcorr5*fact(4)*gradcorr5(j,i)+
+ & wcorr6*fact(5)*gradcorr6(j,i)+
+ & wturn6*fact(5)*gcorr6_turn(j,i)+
+ & wsccor*fact(2)*gsccorc(j,i)+
+ & wliptran*gliptranc(j,i)+
+ & wdfa_dist*gdfad(j,i)+
+ & wdfa_tor*gdfat(j,i)+
+ & wdfa_nei*gdfan(j,i)+
+ & wdfa_beta*gdfab(j,i)
+ gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
+ & wbond*gradbx(j,i)+
+ & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
+ & wsccor*fact(2)*gsccorx(j,i)
+ & +wliptran*gliptranx(j,i)
+ else
+ gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)
+ & +fact(1)*wscp*gvdwc_scp(j,i)+
+ & welec*fact(1)*gelc(j,i)+fact(1)*wvdwpp*gvdwpp(j,i)+
+ & wbond*gradb(j,i)+
+ & wstrain*ghpbc(j,i)+
+ & wcorr*fact(3)*gradcorr(j,i)+
+ & wel_loc*fact(2)*gel_loc(j,i)+
+ & wturn3*fact(2)*gcorr3_turn(j,i)+
+ & wturn4*fact(3)*gcorr4_turn(j,i)+
+ & wcorr5*fact(4)*gradcorr5(j,i)+
+ & wcorr6*fact(5)*gradcorr6(j,i)+
+ & wturn6*fact(5)*gcorr6_turn(j,i)+
+ & wsccor*fact(2)*gsccorc(j,i)
+ & +wliptran*gliptranc(j,i)
+ & +welec*gshieldc(j,i)
+ & +welec*gshieldc_loc(j,i)
+ & +wcorr*gshieldc_ec(j,i)
+ & +wcorr*gshieldc_loc_ec(j,i)
+ & +wturn3*gshieldc_t3(j,i)
+ & +wturn3*gshieldc_loc_t3(j,i)
+ & +wturn4*gshieldc_t4(j,i)
+ & +wturn4*gshieldc_loc_t4(j,i)
+ & +wel_loc*gshieldc_ll(j,i)
+ & +wel_loc*gshieldc_loc_ll(j,i)+
+ & wdfa_dist*gdfad(j,i)+
+ & wdfa_tor*gdfat(j,i)+
+ & wdfa_nei*gdfan(j,i)+
+ & wdfa_beta*gdfab(j,i)
+ gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)
+ & +fact(1)*wscp*gradx_scp(j,i)+
+ & wbond*gradbx(j,i)+
+ & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
+ & wsccor*fact(2)*gsccorx(j,i)
+ & +wliptran*gliptranx(j,i)
+ & +welec*gshieldx(j,i)
+ & +wcorr*gshieldx_ec(j,i)
+ & +wturn3*gshieldx_t3(j,i)
+ & +wturn4*gshieldx_t4(j,i)
+ & +wel_loc*gshieldx_ll(j,i)
+ endif
+ enddo
+#else
+ do i=1,nct
+ do j=1,3
+ if (shield_mode.eq.0) then
+ gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
+ & welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
+ & wbond*gradb(j,i)+
+ & wcorr*fact(3)*gradcorr(j,i)+
+ & wel_loc*fact(2)*gel_loc(j,i)+
+ & wturn3*fact(2)*gcorr3_turn(j,i)+
+ & wturn4*fact(3)*gcorr4_turn(j,i)+
+ & wcorr5*fact(4)*gradcorr5(j,i)+
+ & wcorr6*fact(5)*gradcorr6(j,i)+
+ & wturn6*fact(5)*gcorr6_turn(j,i)+
+ & wsccor*fact(2)*gsccorc(j,i)
+ & +wliptran*gliptranc(j,i)+
+ & wdfa_dist*gdfad(j,i)+
+ & wdfa_tor*gdfat(j,i)+
+ & wdfa_nei*gdfan(j,i)+
+ & wdfa_beta*gdfab(j,i)
+
+ gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
+ & wbond*gradbx(j,i)+
+ & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
+ & wsccor*fact(1)*gsccorx(j,i)
+ & +wliptran*gliptranx(j,i)
+ else
+ gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)+
+ & fact(1)*wscp*gvdwc_scp(j,i)+
+ & welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
+ & wbond*gradb(j,i)+
+ & wcorr*fact(3)*gradcorr(j,i)+
+ & wel_loc*fact(2)*gel_loc(j,i)+
+ & wturn3*fact(2)*gcorr3_turn(j,i)+
+ & wturn4*fact(3)*gcorr4_turn(j,i)+
+ & wcorr5*fact(4)*gradcorr5(j,i)+
+ & wcorr6*fact(5)*gradcorr6(j,i)+
+ & wturn6*fact(5)*gcorr6_turn(j,i)+
+ & wsccor*fact(2)*gsccorc(j,i)
+ & +wliptran*gliptranc(j,i)
+ & +welec*gshieldc(j,i)
+ & +welec*gshieldc_loc(j,i)
+ & +wcorr*gshieldc_ec(j,i)
+ & +wcorr*gshieldc_loc_ec(j,i)
+ & +wturn3*gshieldc_t3(j,i)
+ & +wturn3*gshieldc_loc_t3(j,i)
+ & +wturn4*gshieldc_t4(j,i)
+ & +wturn4*gshieldc_loc_t4(j,i)
+ & +wel_loc*gshieldc_ll(j,i)
+ & +wel_loc*gshieldc_loc_ll(j,i)+
+ & wdfa_dist*gdfad(j,i)+
+ & wdfa_tor*gdfat(j,i)+
+ & wdfa_nei*gdfan(j,i)+
+ & wdfa_beta*gdfab(j,i)
+ gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+
+ & fact(1)*wscp*gradx_scp(j,i)+
+ & wbond*gradbx(j,i)+
+ & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
+ & wsccor*fact(1)*gsccorx(j,i)
+ & +wliptran*gliptranx(j,i)
+ & +welec*gshieldx(j,i)
+ & +wcorr*gshieldx_ec(j,i)
+ & +wturn3*gshieldx_t3(j,i)
+ & +wturn4*gshieldx_t4(j,i)
+ & +wel_loc*gshieldx_ll(j,i)
+
+ endif
+ enddo
+#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)
+c & +wsccor*fact(1)*gsccor_loc(i)
+c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA
+ enddo
+ endif
+ if (dyn_ss) call dyn_set_nss
+ return
+ end
+C------------------------------------------------------------------------
+ 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'
+ include 'COMMON.CONTROL'
+ 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)
+ ethetacnstr=energia(24)
+ eliptran=energia(22)
+ esaxs=energia(26)
+ ehomology_constr=energia(27)
+C Bartek
+ edfadis = energia(28)
+ edfator = energia(29)
+ edfanei = energia(30)
+ edfabet = energia(31)
+#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,
+ & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
+ & etube,wtube,esaxs,wsaxs,ehomology_constr,
+ & edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
+ & edfabet,wdfa_beta,
+ & etot
+ 10 format (/'Virtual-chain energies:'//
+ & 'EVDW= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
+ & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
+ & 'EES= ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
+ & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
+ & 'ESTR= ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
+ & 'EBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
+ & 'ESC= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
+ & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
+ & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
+ & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6,
+ & ' (SS bridges & dist. cnstr.)'/
+ & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
+ & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
+ & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
+ & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
+ & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
+ & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
+ & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
+ & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
+ & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
+ & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
+ & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
+ & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
+ & 'ELT= ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
+ & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/
+ & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
+ & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
+ & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
+ & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
+ & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
+ & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
+ & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta 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*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,
+ & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
+ & etube,wtube,esaxs,wsaxs,ehomology_constr,
+ & edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
+ & edfabet,wdfa_beta,
+ & etot
+ 10 format (/'Virtual-chain energies:'//
+ & 'EVDW= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
+ & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
+ & 'EES= ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
+ & 'ESTR= ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
+ & 'EBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
+ & 'ESC= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
+ & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
+ & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
+ & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6,
+ & ' (SS bridges & dist. restr.)'/
+ & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
+ & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
+ & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
+ & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
+ & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
+ & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
+ & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
+ & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
+ & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
+ & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
+ & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
+ & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
+ & 'ELT= ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
+ & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/
+ & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
+ & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
+ & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
+ & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
+ & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
+ & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
+ & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta 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
+c ROZNICA z cluster
+ do i=1,210
+ do j=1,2
+ eneps_temp(j,i)=0.0d0
+ enddo
+ enddo
+cROZNICA
+
+ evdw=0.0D0
+ evdw_t=0.0d0
+ do i=iatsc_s,iatsc_e
+ itypi=iabs(itype(i))
+ if (itypi.eq.ntyp1) cycle
+ itypi1=iabs(itype(i+1))
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+C 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=iabs(itype(j))
+ if (itypj.eq.ntyp1) cycle
+ xj=c(1,nres+j)-xi
+ yj=c(2,nres+j)-yi
+ zj=c(3,nres+j)-zi
+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
+ e2=fac*bb
+ evdwij=e1+e2
+ ij=icant(itypi,itypj)
+c ROZNICA z cluster
+ eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
+ eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
+c
+
+cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
+cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
+cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
+cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
+cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
+cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
+ if (bb.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<sigma).
+C
+ if (fcont.gt.0.0D0) then
+C If the SC-SC distance if close to sigma, apply spline.
+cAdam call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
+cAdam & fcont1,fprimcont1)
+cAdam fcont1=1.0d0-fcont1
+cAdam if (fcont1.gt.0.0d0) then
+cAdam fprimcont=fprimcont*fcont1+fcont*fprimcont1
+cAdam fcont=fcont*fcont1
+cAdam endif
+C Uncomment following 4 lines to have the geometric average of the epsilon0's
+cga eps0ij=1.0d0/dsqrt(eps0ij)
+cga do k=1,3
+cga gg(k)=gg(k)*eps0ij
+cga enddo
+cga eps0ij=-evdwij*eps0ij
+C Uncomment for AL's type of SC correlation interactions.
+cadam eps0ij=-evdwij
+ num_conti=num_conti+1
+ jcont(num_conti,i)=j
+ facont(num_conti,i)=fcont*eps0ij
+ fprimcont=eps0ij*fprimcont/rij
+ fcont=expon*fcont
+cAdam gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
+cAdam gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
+cAdam gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
+C Uncomment following 3 lines for Skolnick's type of SC correlation.
+ gacont(1,num_conti,i)=-fprimcont*xj
+ gacont(2,num_conti,i)=-fprimcont*yj
+ gacont(3,num_conti,i)=-fprimcont*zj
+cd write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
+cd write (iout,'(2i3,3f10.5)')
+cd & i,j,(gacont(kk,num_conti,i),kk=1,3)
+ endif
+ endif
+ enddo ! j
+ enddo ! iint
+C Change 12/1/95
+ num_cont(i)=num_conti
+ enddo ! i
+ if (calc_grad) then
+ do i=1,nct
+ do j=1,3
+ gvdwc(j,i)=expon*gvdwc(j,i)
+ gvdwx(j,i)=expon*gvdwx(j,i)
+ enddo
+ enddo
+ endif
+C******************************************************************************
+C
+C N O T E !!!
+C
+C To save time, the factor of EXPON has been extracted from ALL components
+C of GVDWC and GRADX. Remember to multiply them by this factor before further
+C use!
+C
+C******************************************************************************
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine eljk(evdw,evdw_t)
+C
+C This subroutine calculates the interaction energy of nonbonded side chains
+C assuming the LJK potential of interaction.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'DIMENSIONS.ZSCOPT'
+ include "DIMENSIONS.COMPAR"
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.ENEPS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ dimension gg(3)
+ logical scheck
+ integer icant
+ external icant
+c print *,'Entering ELJK 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=iabs(itype(i))
+ if (itypi.eq.ntyp1) cycle
+ itypi1=iabs(itype(i+1))
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+C
+C Calculate SC interaction energy.
+C
+ do iint=1,nint_gr(i)
+ do j=istart(i,iint),iend(i,iint)
+ itypj=iabs(itype(j))
+ if (itypj.eq.ntyp1) cycle
+ xj=c(1,nres+j)-xi
+ yj=c(2,nres+j)-yi
+ zj=c(3,nres+j)-zi
+ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
+ fac_augm=rrij**expon
+ e_augm=augm(itypi,itypj)*fac_augm
+ r_inv_ij=dsqrt(rrij)
+ rij=1.0D0/r_inv_ij
+ r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
+ fac=r_shift_inv**expon
+ e1=fac*fac*aa
+ e2=fac*bb
+ evdwij=e_augm+e1+e2
+ ij=icant(itypi,itypj)
+ eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
+ & /dabs(eps(itypi,itypj))
+ eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
+cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
+cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
+cd write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
+cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
+cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
+cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
+cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
+ if (bb.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=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
+ 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
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+ if (calc_grad) then
+ do i=1,nct
+ do j=1,3
+ gvdwc(j,i)=expon*gvdwc(j,i)
+ gvdwx(j,i)=expon*gvdwx(j,i)
+ enddo
+ enddo
+ endif
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine ebp(evdw,evdw_t)
+C
+C This subroutine calculates the interaction energy of nonbonded side chains
+C assuming the Berne-Pechukas potential of interaction.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'DIMENSIONS.ZSCOPT'
+ include "DIMENSIONS.COMPAR"
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.NAMES'
+ include 'COMMON.INTERACT'
+ include 'COMMON.ENEPS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CALC'
+ common /srutu/ icall
+c double precision rrsave(maxdim)
+ logical lprn
+ integer icant
+ external icant
+ do i=1,210
+ do j=1,2
+ eneps_temp(j,i)=0.0d0
+ enddo
+ enddo
+ evdw=0.0D0
+ evdw_t=0.0d0
+c print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
+c if (icall.eq.0) then
+c lprn=.true.
+c else
+ lprn=.false.
+c endif
+ ind=0
+ do i=iatsc_s,iatsc_e
+ itypi=iabs(itype(i))
+ if (itypi.eq.ntyp1) cycle
+ itypi1=iabs(itype(i+1))
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+ dxi=dc_norm(1,nres+i)
+ dyi=dc_norm(2,nres+i)
+ dzi=dc_norm(3,nres+i)
+ dsci_inv=vbld_inv(i+nres)
+C
+C Calculate SC interaction energy.
+C
+ do iint=1,nint_gr(i)
+ do j=istart(i,iint),iend(i,iint)
+ ind=ind+1
+ itypj=iabs(itype(j))
+ if (itypj.eq.ntyp1) cycle
+ dscj_inv=vbld_inv(j+nres)
+ chi1=chi(itypi,itypj)
+ chi2=chi(itypj,itypi)
+ chi12=chi1*chi2
+ chip1=chip(itypi)
+ chip2=chip(itypj)
+ chip12=chip1*chip2
+ alf1=alp(itypi)
+ alf2=alp(itypj)
+ alf12=0.5D0*(alf1+alf2)
+C For diagnostics only!!!
+c chi1=0.0D0
+c chi2=0.0D0
+c chi12=0.0D0
+c chip1=0.0D0
+c chip2=0.0D0
+c chip12=0.0D0
+c alf1=0.0D0
+c alf2=0.0D0
+c alf12=0.0D0
+ xj=c(1,nres+j)-xi
+ yj=c(2,nres+j)-yi
+ zj=c(3,nres+j)-zi
+ 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)
+cd if (icall.eq.0) then
+cd rrsave(ind)=rrij
+cd else
+cd rrij=rrsave(ind)
+cd endif
+ rij=dsqrt(rrij)
+C Calculate the angle-dependent terms of energy & contributions to derivatives.
+ call sc_angular
+C Calculate whole angle-dependent part of epsilon and contributions
+C to its derivatives
+ fac=(rrij*sigsq)**expon2
+ e1=fac*fac*aa
+ e2=fac*bb
+ evdwij=eps1*eps2rt*eps3rt*(e1+e2)
+ eps2der=evdwij*eps3rt
+ eps3der=evdwij*eps2rt
+ evdwij=evdwij*eps2rt*eps3rt
+ ij=icant(itypi,itypj)
+ aux=eps1*eps2rt**2*eps3rt**2
+ eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
+ & /dabs(eps(itypi,itypj))
+ eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
+ if (bb.gt.0.0d0) then
+ evdw=evdw+evdwij
+ else
+ evdw_t=evdw_t+evdwij
+ endif
+ if (calc_grad) then
+ if (lprn) then
+ sigm=dabs(aa/bb)**(1.0D0/6.0D0)
+ epsi=bb**2/aa
+ write (iout,'(2(a3,i3,2x),15(0pf7.3))')
+ & restyp(itypi),i,restyp(itypj),j,
+ & epsi,sigm,chi1,chi2,chip1,chip2,
+ & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
+ & om1,om2,om12,1.0D0/dsqrt(rrij),
+ & evdwij
+ endif
+C Calculate gradient components.
+ e1=e1*eps1*eps2rt**2*eps3rt**2
+ fac=-expon*(e1+evdwij)
+ sigder=fac/sigsq
+ fac=rrij*fac
+C Calculate radial part of the gradient
+ gg(1)=xj*fac
+ gg(2)=yj*fac
+ gg(3)=zj*fac
+C Calculate the angular part of the gradient and sum add the contributions
+C to the appropriate components of the Cartesian gradient.
+ call sc_grad
+ endif
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+c stop
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine egb(evdw,evdw_t)
+C
+C This subroutine calculates the interaction energy of nonbonded side chains
+C assuming the Gay-Berne potential of interaction.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'DIMENSIONS.ZSCOPT'
+ include "DIMENSIONS.COMPAR"
+ include 'COMMON.CONTROL'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.NAMES'
+ include 'COMMON.INTERACT'
+ include 'COMMON.ENEPS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CALC'
+ include 'COMMON.SBRIDGE'
+ logical lprn
+ common /srutu/icall
+ integer icant,xshift,yshift,zshift
+ external icant
+ do i=1,210
+ do j=1,2
+ eneps_temp(j,i)=0.0d0
+ enddo
+ enddo
+c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
+ evdw=0.0D0
+ evdw_t=0.0d0
+ lprn=.false.
+c if (icall.gt.0) lprn=.true.
+ ind=0
+ do i=iatsc_s,iatsc_e
+ itypi=iabs(itype(i))
+ if (itypi.eq.ntyp1) cycle
+ itypi1=iabs(itype(i+1))
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+C returning the ith atom to box
+ xi=mod(xi,boxxsize)
+ if (xi.lt.0) xi=xi+boxxsize
+ yi=mod(yi,boxysize)
+ if (yi.lt.0) yi=yi+boxysize
+ zi=mod(zi,boxzsize)
+ if (zi.lt.0) zi=zi+boxzsize
+ if ((zi.gt.bordlipbot)
+ &.and.(zi.lt.bordliptop)) then
+C the energy transfer exist
+ if (zi.lt.buflipbot) then
+C what fraction I am in
+ fracinbuf=1.0d0-
+ & ((zi-bordlipbot)/lipbufthick)
+C lipbufthick is thickenes of lipid buffore
+ sslipi=sscalelip(fracinbuf)
+ ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
+ elseif (zi.gt.bufliptop) then
+ fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
+ sslipi=sscalelip(fracinbuf)
+ ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
+ else
+ sslipi=1.0d0
+ ssgradlipi=0.0
+ endif
+ else
+ sslipi=0.0d0
+ ssgradlipi=0.0
+ endif
+
+ dxi=dc_norm(1,nres+i)
+ dyi=dc_norm(2,nres+i)
+ dzi=dc_norm(3,nres+i)
+ dsci_inv=vbld_inv(i+nres)
+C
+C Calculate SC interaction energy.
+C
+ do iint=1,nint_gr(i)
+ do j=istart(i,iint),iend(i,iint)
+ IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
+ call dyn_ssbond_ene(i,j,evdwij)
+ evdw=evdw+evdwij
+C write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
+C & 'evdw',i,j,evdwij,' ss',evdw,evdw_t
+C triple bond artifac removal
+ do k=j+1,iend(i,iint)
+C search over all next residues
+ if (dyn_ss_mask(k)) then
+C check if they are cysteins
+C write(iout,*) 'k=',k
+ call triple_ssbond_ene(i,j,k,evdwij)
+C call the energy function that removes the artifical triple disulfide
+C bond the soubroutine is located in ssMD.F
+ evdw=evdw+evdwij
+C write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
+C & 'evdw',i,j,evdwij,'tss',evdw,evdw_t
+ endif!dyn_ss_mask(k)
+ enddo! k
+ ELSE
+ ind=ind+1
+ itypj=iabs(itype(j))
+ if (itypj.eq.ntyp1) cycle
+ dscj_inv=vbld_inv(j+nres)
+ sig0ij=sigma(itypi,itypj)
+ chi1=chi(itypi,itypj)
+ chi2=chi(itypj,itypi)
+ chi12=chi1*chi2
+ chip1=chip(itypi)
+ chip2=chip(itypj)
+ chip12=chip1*chip2
+ alf1=alp(itypi)
+ alf2=alp(itypj)
+ alf12=0.5D0*(alf1+alf2)
+C For diagnostics only!!!
+c chi1=0.0D0
+c chi2=0.0D0
+c chi12=0.0D0
+c chip1=0.0D0
+c chip2=0.0D0
+c chip12=0.0D0
+c alf1=0.0D0
+c alf2=0.0D0
+c alf12=0.0D0
+ xj=c(1,nres+j)
+ yj=c(2,nres+j)
+ zj=c(3,nres+j)
+C returning jth atom to box
+ xj=mod(xj,boxxsize)
+ if (xj.lt.0) xj=xj+boxxsize
+ yj=mod(yj,boxysize)
+ if (yj.lt.0) yj=yj+boxysize
+ zj=mod(zj,boxzsize)
+ if (zj.lt.0) zj=zj+boxzsize
+ if ((zj.gt.bordlipbot)
+ &.and.(zj.lt.bordliptop)) then
+C the energy transfer exist
+ if (zj.lt.buflipbot) then
+C what fraction I am in
+ fracinbuf=1.0d0-
+ & ((zj-bordlipbot)/lipbufthick)
+C lipbufthick is thickenes of lipid buffore
+ sslipj=sscalelip(fracinbuf)
+ ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
+ elseif (zj.gt.bufliptop) then
+ fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
+ sslipj=sscalelip(fracinbuf)
+ ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
+ else
+ sslipj=1.0d0
+ ssgradlipj=0.0
+ endif
+ else
+ sslipj=0.0d0
+ ssgradlipj=0.0
+ endif
+ aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
+ & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
+ bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
+ & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
+C if (aa.ne.aa_aq(itypi,itypj)) then
+
+C write(iout,*) "tu,", i,j,aa_aq(itypi,itypj)-aa,
+C & bb_aq(itypi,itypj)-bb,
+C & sslipi,sslipj
+C endif
+
+C write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
+C checking the distance
+ dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
+ xj_safe=xj
+ yj_safe=yj
+ zj_safe=zj
+ subchap=0
+C finding the closest
+ do xshift=-1,1
+ do yshift=-1,1
+ do zshift=-1,1
+ xj=xj_safe+xshift*boxxsize
+ yj=yj_safe+yshift*boxysize
+ zj=zj_safe+zshift*boxzsize
+ dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
+ if(dist_temp.lt.dist_init) then
+ dist_init=dist_temp
+ xj_temp=xj
+ yj_temp=yj
+ zj_temp=zj
+ subchap=1
+ endif
+ enddo
+ enddo
+ enddo
+ if (subchap.eq.1) then
+ xj=xj_temp-xi
+ yj=yj_temp-yi
+ zj=zj_temp-zi
+ else
+ xj=xj_safe-xi
+ yj=yj_safe-yi
+ zj=zj_safe-zi
+ endif
+
+ dxj=dc_norm(1,nres+j)
+ dyj=dc_norm(2,nres+j)
+ dzj=dc_norm(3,nres+j)
+c write (iout,*) i,j,xj,yj,zj
+ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
+ rij=dsqrt(rrij)
+ sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
+ sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
+ if (sss.le.0.0) cycle
+C Calculate angle-dependent terms of energy and contributions to their
+C derivatives.
+
+ call sc_angular
+ sigsq=1.0D0/sigsq
+ sig=sig0ij*dsqrt(sigsq)
+ rij_shift=1.0D0/rij-sig+sig0ij
+C I hate to put IF's in the loops, but here don't have another choice!!!!
+ if (rij_shift.le.0.0D0) then
+ evdw=1.0D20
+ return
+ endif
+ sigder=-sig*sigsq
+c---------------------------------------------------------------
+ rij_shift=1.0D0/rij_shift
+ fac=rij_shift**expon
+ e1=fac*fac*aa
+ e2=fac*bb
+ evdwij=eps1*eps2rt*eps3rt*(e1+e2)
+ eps2der=evdwij*eps3rt
+ eps3der=evdwij*eps2rt
+ evdwij=evdwij*eps2rt*eps3rt
+ if (bb.gt.0) then
+ evdw=evdw+evdwij*sss
+ else
+ evdw_t=evdw_t+evdwij*sss
+ endif
+ ij=icant(itypi,itypj)
+ aux=eps1*eps2rt**2*eps3rt**2
+ eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
+ & /dabs(eps(itypi,itypj))
+ eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
+c write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
+c & " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
+c & aux*e2/eps(itypi,itypj)
+c if (lprn) then
+ sigm=dabs(aa/bb)**(1.0D0/6.0D0)
+ epsi=bb**2/aa
+c#define DEBUG
+#ifdef DEBUG
+ write (iout,'(2(a3,i3,2x),17(0pf7.3))')
+ & restyp(itypi),i,restyp(itypj),j,
+ & epsi,sigm,chi1,chi2,chip1,chip2,
+ & eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
+ & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
+ & evdwij
+ write (iout,*) "partial sum", evdw, evdw_t
+#endif
+c#undef DEBUG
+c endif
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
+ & 'evdw',i,j,evdwij
+ if (calc_grad) then
+C Calculate gradient components.
+ e1=e1*eps1*eps2rt**2*eps3rt**2
+ fac=-expon*(e1+evdwij)*rij_shift
+ sigder=fac*sigder
+ fac=rij*fac
+ fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
+C Calculate the radial part of the gradient
+ gg(1)=xj*fac
+ gg(2)=yj*fac
+ gg(3)=zj*fac
+C Calculate angular part of the gradient.
+ call sc_grad
+ endif
+C write(iout,*) "partial sum", evdw, evdw_t
+ ENDIF ! dyn_ss
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine egbv(evdw,evdw_t)
+C
+C This subroutine calculates the interaction energy of nonbonded side chains
+C assuming the Gay-Berne-Vorobjev potential of interaction.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'DIMENSIONS.ZSCOPT'
+ include "DIMENSIONS.COMPAR"
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.NAMES'
+ include 'COMMON.INTERACT'
+ include 'COMMON.ENEPS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CALC'
+ common /srutu/ icall
+ logical lprn
+ integer icant
+ external icant
+ do i=1,210
+ do j=1,2
+ eneps_temp(j,i)=0.0d0
+ enddo
+ enddo
+ evdw=0.0D0
+ evdw_t=0.0d0
+c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
+ evdw=0.0D0
+ lprn=.false.
+c if (icall.gt.0) lprn=.true.
+ ind=0
+ do i=iatsc_s,iatsc_e
+ itypi=iabs(itype(i))
+ if (itypi.eq.ntyp1) cycle
+ itypi1=iabs(itype(i+1))
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+ dxi=dc_norm(1,nres+i)
+ dyi=dc_norm(2,nres+i)
+ dzi=dc_norm(3,nres+i)
+ dsci_inv=vbld_inv(i+nres)
+C
+C Calculate SC interaction energy.
+C
+ do iint=1,nint_gr(i)
+ do j=istart(i,iint),iend(i,iint)
+ ind=ind+1
+ itypj=iabs(itype(j))
+ if (itypj.eq.ntyp1) cycle
+ dscj_inv=vbld_inv(j+nres)
+ sig0ij=sigma(itypi,itypj)
+ r0ij=r0(itypi,itypj)
+ chi1=chi(itypi,itypj)
+ chi2=chi(itypj,itypi)
+ chi12=chi1*chi2
+ chip1=chip(itypi)
+ chip2=chip(itypj)
+ chip12=chip1*chip2
+ alf1=alp(itypi)
+ alf2=alp(itypj)
+ alf12=0.5D0*(alf1+alf2)
+C For diagnostics only!!!
+c chi1=0.0D0
+c chi2=0.0D0
+c chi12=0.0D0
+c chip1=0.0D0
+c chip2=0.0D0
+c chip12=0.0D0
+c alf1=0.0D0
+c alf2=0.0D0
+c alf12=0.0D0
+ xj=c(1,nres+j)-xi
+ yj=c(2,nres+j)-yi
+ zj=c(3,nres+j)-zi
+ 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)
+C Calculate angle-dependent terms of energy and contributions to their
+C derivatives.
+ call sc_angular
+ sigsq=1.0D0/sigsq
+ sig=sig0ij*dsqrt(sigsq)
+ rij_shift=1.0D0/rij-sig+r0ij
+C I hate to put IF's in the loops, but here don't have another choice!!!!
+ if (rij_shift.le.0.0D0) then
+ evdw=1.0D20
+ return
+ endif
+ sigder=-sig*sigsq
+c---------------------------------------------------------------
+ rij_shift=1.0D0/rij_shift
+ fac=rij_shift**expon
+ e1=fac*fac*aa
+ e2=fac*bb
+ evdwij=eps1*eps2rt*eps3rt*(e1+e2)
+ eps2der=evdwij*eps3rt
+ eps3der=evdwij*eps2rt
+ fac_augm=rrij**expon
+ e_augm=augm(itypi,itypj)*fac_augm
+ evdwij=evdwij*eps2rt*eps3rt
+ if (bb.gt.0.0d0) then
+ evdw=evdw+evdwij+e_augm
+ else
+ evdw_t=evdw_t+evdwij+e_augm
+ endif
+ ij=icant(itypi,itypj)
+ aux=eps1*eps2rt**2*eps3rt**2
+ eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
+ & /dabs(eps(itypi,itypj))
+ eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
+c eneps_temp(ij)=eneps_temp(ij)
+c & +(evdwij+e_augm)/eps(itypi,itypj)
+c if (lprn) then
+c sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
+c epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
+c write (iout,'(2(a3,i3,2x),17(0pf7.3))')
+c & restyp(itypi),i,restyp(itypj),j,
+c & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
+c & chi1,chi2,chip1,chip2,
+c & eps1,eps2rt**2,eps3rt**2,
+c & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
+c & evdwij+e_augm
+c endif
+ if (calc_grad) then
+C Calculate gradient components.
+ e1=e1*eps1*eps2rt**2*eps3rt**2
+ fac=-expon*(e1+evdwij)*rij_shift
+ sigder=fac*sigder
+ fac=rij*fac-2*expon*rrij*e_augm
+C Calculate the radial part of the gradient
+ gg(1)=xj*fac
+ gg(2)=yj*fac
+ gg(3)=zj*fac
+C Calculate angular part of the gradient.
+ call sc_grad
+ endif
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+ return
+ end
+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'
+ 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 Calculate eps1(om12) and its derivative in 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) 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
+ 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 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
+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
+ eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*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)
+c write (iout,*) "i",i," dc_norm",dc_norm(:,i),dc_norm(:,i-1),
+c & " uz",uz(:,i)
+ 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 ! calc_grad
+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 set_matrices
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include "mpif.h"
+ integer IERR
+ integer status(MPI_STATUS_SIZE)
+#endif
+ 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
+c write(iout,*) 'SET_MATRICES nphi=',nphi,nres
+ do i=3,nres+1
+ if (i.gt. nnt+2 .and. i.lt.nct+2) then
+ iti = itype2loc(itype(i-2))
+ else
+ iti=nloctyp
+ endif
+c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
+ if (i.gt. nnt+1 .and. i.lt.nct+1) then
+ iti1 = itype2loc(itype(i-1))
+ else
+ iti1=nloctyp
+ endif
+#ifdef NEWCORR
+ cost1=dcos(theta(i-1))
+ sint1=dsin(theta(i-1))
+ sint1sq=sint1*sint1
+ sint1cub=sint1sq*sint1
+ sint1cost1=2*sint1*cost1
+#ifdef DEBUG
+ write (iout,*) "bnew1",i,iti
+ write (iout,*) (bnew1(k,1,iti),k=1,3)
+ write (iout,*) (bnew1(k,2,iti),k=1,3)
+ write (iout,*) "bnew2",i,iti
+ write (iout,*) (bnew2(k,1,iti),k=1,3)
+ write (iout,*) (bnew2(k,2,iti),k=1,3)
+#endif
+ do k=1,2
+ b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
+ b1(k,i-2)=sint1*b1k
+ gtb1(k,i-2)=cost1*b1k-sint1sq*
+ & (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
+ b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
+ b2(k,i-2)=sint1*b2k
+ if (calc_grad) gtb2(k,i-2)=cost1*b2k-sint1sq*
+ & (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
+ enddo
+ do k=1,2
+ aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
+ cc(1,k,i-2)=sint1sq*aux
+ if (calc_grad) gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
+ & (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
+ aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
+ dd(1,k,i-2)=sint1sq*aux
+ if (calc_grad) gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
+ & (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
+ enddo
+ cc(2,1,i-2)=cc(1,2,i-2)
+ cc(2,2,i-2)=-cc(1,1,i-2)
+ gtcc(2,1,i-2)=gtcc(1,2,i-2)
+ gtcc(2,2,i-2)=-gtcc(1,1,i-2)
+ dd(2,1,i-2)=dd(1,2,i-2)
+ dd(2,2,i-2)=-dd(1,1,i-2)
+ gtdd(2,1,i-2)=gtdd(1,2,i-2)
+ gtdd(2,2,i-2)=-gtdd(1,1,i-2)
+ do k=1,2
+ do l=1,2
+ aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
+ EE(l,k,i-2)=sint1sq*aux
+ if (calc_grad)
+ & gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
+ enddo
+ enddo
+ EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
+ EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
+ EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
+ EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
+ if (calc_grad) then
+ gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
+ gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
+ gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
+ endif
+c b1tilde(1,i-2)=b1(1,i-2)
+c b1tilde(2,i-2)=-b1(2,i-2)
+c b2tilde(1,i-2)=b2(1,i-2)
+c b2tilde(2,i-2)=-b2(2,i-2)
+#ifdef DEBUG
+ write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
+ write(iout,*) 'b1=',(b1(k,i-2),k=1,2)
+ write(iout,*) 'b2=',(b2(k,i-2),k=1,2)
+ write (iout,*) 'theta=', theta(i-1)
+#endif
+#else
+c if (i.gt. nnt+2 .and. i.lt.nct+2) then
+c iti = itype2loc(itype(i-2))
+c else
+c iti=nloctyp
+c endif
+c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
+c if (i.gt. nnt+1 .and. i.lt.nct+1) then
+c iti1 = itype2loc(itype(i-1))
+c else
+c iti1=nloctyp
+c endif
+ b1(1,i-2)=b(3,iti)
+ b1(2,i-2)=b(5,iti)
+ b2(1,i-2)=b(2,iti)
+ b2(2,i-2)=b(4,iti)
+ do k=1,2
+ do l=1,2
+ CC(k,l,i-2)=ccold(k,l,iti)
+ DD(k,l,i-2)=ddold(k,l,iti)
+ EE(k,l,i-2)=eeold(k,l,iti)
+ enddo
+ enddo
+#endif
+ b1tilde(1,i-2)= b1(1,i-2)
+ b1tilde(2,i-2)=-b1(2,i-2)
+ b2tilde(1,i-2)= b2(1,i-2)
+ b2tilde(2,i-2)=-b2(2,i-2)
+c
+ Ctilde(1,1,i-2)= CC(1,1,i-2)
+ Ctilde(1,2,i-2)= CC(1,2,i-2)
+ Ctilde(2,1,i-2)=-CC(2,1,i-2)
+ Ctilde(2,2,i-2)=-CC(2,2,i-2)
+c
+ Dtilde(1,1,i-2)= DD(1,1,i-2)
+ Dtilde(1,2,i-2)= DD(1,2,i-2)
+ Dtilde(2,1,i-2)=-DD(2,1,i-2)
+ Dtilde(2,2,i-2)=-DD(2,2,i-2)
+#ifdef DEBUG
+ write(iout,*) "i",i," iti",iti
+ write(iout,*) 'b1=',(b1(k,i-2),k=1,2)
+ write(iout,*) 'b2=',(b2(k,i-2),k=1,2)
+#endif
+ enddo
+ 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
+c if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
+ if (i.gt. nnt+2 .and. i.lt.nct+2) then
+ iti = itype2loc(itype(i-2))
+ else
+ iti=nloctyp
+ endif
+c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
+ if (i.gt. nnt+1 .and. i.lt.nct+1) then
+ iti1 = itype2loc(itype(i-1))
+ else
+ iti1=nloctyp
+ 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)
+c if (i .gt. iatel_s+2) then
+ if (i .gt. nnt+2) then
+ call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
+#ifdef NEWCORR
+ call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
+c write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
+#endif
+c write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
+c & EE(1,2,iti),EE(2,2,i)
+ call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
+ call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
+c write(iout,*) "Macierz EUG",
+c & eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
+c & eug(2,2,i-2)
+ if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
+ & then
+ call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
+ call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
+ call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
+ call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
+ call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
+ endif
+ 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,i-2),Ub2der(1,i-2))
+ call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
+ do k=1,2
+ muder(k,i-2)=Ub2der(k,i-2)
+ enddo
+c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
+ if (i.gt. nnt+1 .and. i.lt.nct+1) then
+ if (itype(i-1).le.ntyp) then
+ iti1 = itype2loc(itype(i-1))
+ else
+ iti1=nloctyp
+ endif
+ else
+ iti1=nloctyp
+ endif
+ do k=1,2
+ mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
+ enddo
+#ifdef MUOUT
+ write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
+ & rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
+ & -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
+ & dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
+ & +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
+ & ((ee(l,k,i-2),l=1,2),k=1,2)
+#endif
+cd write (iout,*) 'mu1',mu1(:,i-2)
+cd write (iout,*) 'mu2',mu2(:,i-2)
+ if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
+ & then
+ if (calc_grad) then
+ call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
+ call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
+ call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
+ call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
+ call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
+ endif
+C Vectors and matrices dependent on a single virtual-bond dihedral.
+ call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
+ call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
+ call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
+ call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
+ call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
+ if (calc_grad) then
+ call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
+ call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
+ call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
+ call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
+ endif
+ endif
+ enddo
+C Matrices dependent on two consecutive virtual-bond dihedrals.
+C The order of matrices is from left to right.
+ if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
+ &then
+ do i=2,nres-1
+ call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
+ if (calc_grad) then
+ 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))
+ endif
+ call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
+ call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
+ if (calc_grad) then
+ 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))
+ endif
+ enddo
+ endif
+ 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)
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ 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'
+ include 'COMMON.TIME1'
+ include 'COMMON.SPLITELE'
+ 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),gmuij(4)
+ common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
+ & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
+ & num_conti,j1,j2
+c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
+#ifdef MOMENT
+ double precision scal_el /1.0d0/
+#else
+ double precision scal_el /0.5d0/
+#endif
+C 12/13/98
+C 13-go grudnia roku pamietnego...
+ double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
+ & 0.0d0,1.0d0,0.0d0,
+ & 0.0d0,0.0d0,1.0d0/
+cd write(iout,*) 'In EELEC'
+cd do i=1,nloctyp
+cd write(iout,*) 'Type',i
+cd write(iout,*) 'B1',B1(:,i)
+cd write(iout,*) 'B2',B2(:,i)
+cd write(iout,*) 'CC',CC(:,:,i)
+cd write(iout,*) 'DD',DD(:,:,i)
+cd write(iout,*) 'EE',EE(:,:,i)
+cd enddo
+cd call check_vecgrad
+cd stop
+ if (icheckgrad.eq.1) then
+ do i=1,nres-1
+ fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
+ do k=1,3
+ dc_norm(k,i)=dc(k,i)*fac
+ enddo
+c write (iout,*) 'i',i,' fac',fac
+ enddo
+ endif
+ if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
+ & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
+ & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
+c call vec_and_deriv
+#ifdef TIMING
+ time01=MPI_Wtime()
+#endif
+ call set_matrices
+#ifdef TIMING
+ time_mat=time_mat+MPI_Wtime()-time01
+#endif
+ endif
+cd do i=1,nres-1
+cd write (iout,*) 'i=',i
+cd do k=1,3
+cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
+cd enddo
+cd do k=1,3
+cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
+cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
+cd enddo
+cd enddo
+ t_eelecij=0.0d0
+ ees=0.0D0
+ evdw1=0.0D0
+ eel_loc=0.0d0
+ eello_turn3=0.0d0
+ eello_turn4=0.0d0
+ ind=0
+ do i=1,nres
+ num_cont_hb(i)=0
+ enddo
+cd print '(a)','Enter EELEC'
+cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
+ do i=1,nres
+ gel_loc_loc(i)=0.0d0
+ gcorr_loc(i)=0.0d0
+ enddo
+c
+c
+c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
+C
+C Loop over i,i+2 and i,i+3 pairs of the peptide groups
+C
+C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
+ do i=iturn3_start,iturn3_end
+c if (i.le.1) cycle
+C write(iout,*) "tu jest i",i
+ if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
+C changes suggested by Ana to avoid out of bounds
+C Adam: Unnecessary: handled by iturn3_end and iturn3_start
+c & .or.((i+4).gt.nres)
+c & .or.((i-1).le.0)
+C end of changes by Ana
+C dobra zmiana wycofana
+ & .or. itype(i+2).eq.ntyp1
+ & .or. itype(i+3).eq.ntyp1) cycle
+C Adam: Instructions below will switch off existing interactions
+c if(i.gt.1)then
+c if(itype(i-1).eq.ntyp1)cycle
+c end if
+c if(i.LT.nres-3)then
+c if (itype(i+4).eq.ntyp1) cycle
+c end if
+ 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
+ xmedi=mod(xmedi,boxxsize)
+ if (xmedi.lt.0) xmedi=xmedi+boxxsize
+ ymedi=mod(ymedi,boxysize)
+ if (ymedi.lt.0) ymedi=ymedi+boxysize
+ zmedi=mod(zmedi,boxzsize)
+ if (zmedi.lt.0) zmedi=zmedi+boxzsize
+ num_conti=0
+ call eelecij(i,i+2,ees,evdw1,eel_loc)
+ if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
+ num_cont_hb(i)=num_conti
+ enddo
+ do i=iturn4_start,iturn4_end
+ if (i.lt.1) cycle
+ if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
+C changes suggested by Ana to avoid out of bounds
+c & .or.((i+5).gt.nres)
+c & .or.((i-1).le.0)
+C end of changes suggested by Ana
+ & .or. itype(i+3).eq.ntyp1
+ & .or. itype(i+4).eq.ntyp1
+c & .or. itype(i+5).eq.ntyp1
+c & .or. itype(i).eq.ntyp1
+c & .or. itype(i-1).eq.ntyp1
+ & ) cycle
+ dxi=dc(1,i)
+ dyi=dc(2,i)
+ dzi=dc(3,i)
+ dx_normi=dc_norm(1,i)
+ dy_normi=dc_norm(2,i)
+ dz_normi=dc_norm(3,i)
+ xmedi=c(1,i)+0.5d0*dxi
+ ymedi=c(2,i)+0.5d0*dyi
+ zmedi=c(3,i)+0.5d0*dzi
+C Return atom into box, boxxsize is size of box in x dimension
+c 194 continue
+c if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
+c if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
+C Condition for being inside the proper box
+c if ((xmedi.gt.((0.5d0)*boxxsize)).or.
+c & (xmedi.lt.((-0.5d0)*boxxsize))) then
+c go to 194
+c endif
+c 195 continue
+c if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
+c if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
+C Condition for being inside the proper box
+c if ((ymedi.gt.((0.5d0)*boxysize)).or.
+c & (ymedi.lt.((-0.5d0)*boxysize))) then
+c go to 195
+c endif
+c 196 continue
+c if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
+c if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
+C Condition for being inside the proper box
+c if ((zmedi.gt.((0.5d0)*boxzsize)).or.
+c & (zmedi.lt.((-0.5d0)*boxzsize))) then
+c go to 196
+c endif
+ xmedi=mod(xmedi,boxxsize)
+ if (xmedi.lt.0) xmedi=xmedi+boxxsize
+ ymedi=mod(ymedi,boxysize)
+ if (ymedi.lt.0) ymedi=ymedi+boxysize
+ zmedi=mod(zmedi,boxzsize)
+ if (zmedi.lt.0) zmedi=zmedi+boxzsize
+
+ num_conti=num_cont_hb(i)
+c write(iout,*) "JESTEM W PETLI"
+ call eelecij(i,i+3,ees,evdw1,eel_loc)
+ if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
+ & call eturn4(i,eello_turn4)
+ num_cont_hb(i)=num_conti
+ enddo ! i
+C Loop over all neighbouring boxes
+C do xshift=-1,1
+C do yshift=-1,1
+C do zshift=-1,1
+c
+c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
+c
+CTU KURWA
+ do i=iatel_s,iatel_e
+C do i=75,75
+c if (i.le.1) cycle
+ if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
+C changes suggested by Ana to avoid out of bounds
+c & .or.((i+2).gt.nres)
+c & .or.((i-1).le.0)
+C end of changes by Ana
+c & .or. itype(i+2).eq.ntyp1
+c & .or. itype(i-1).eq.ntyp1
+ & ) cycle
+ 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
+ xmedi=mod(xmedi,boxxsize)
+ if (xmedi.lt.0) xmedi=xmedi+boxxsize
+ ymedi=mod(ymedi,boxysize)
+ if (ymedi.lt.0) ymedi=ymedi+boxysize
+ zmedi=mod(zmedi,boxzsize)
+ if (zmedi.lt.0) zmedi=zmedi+boxzsize
+C xmedi=xmedi+xshift*boxxsize
+C ymedi=ymedi+yshift*boxysize
+C zmedi=zmedi+zshift*boxzsize
+
+C Return tom into box, boxxsize is size of box in x dimension
+c 164 continue
+c if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
+c if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
+C Condition for being inside the proper box
+c if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
+c & (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
+c go to 164
+c endif
+c 165 continue
+c if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
+c if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
+C Condition for being inside the proper box
+c if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
+c & (ymedi.lt.((yshift-0.5d0)*boxysize))) then
+c go to 165
+c endif
+c 166 continue
+c if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
+c if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
+cC Condition for being inside the proper box
+c if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
+c & (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
+c go to 166
+c endif
+
+c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
+ num_conti=num_cont_hb(i)
+C I TU KURWA
+ do j=ielstart(i),ielend(i)
+C do j=16,17
+C write (iout,*) i,j
+C if (j.le.1) cycle
+ if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
+C changes suggested by Ana to avoid out of bounds
+c & .or.((j+2).gt.nres)
+c & .or.((j-1).le.0)
+C end of changes by Ana
+c & .or.itype(j+2).eq.ntyp1
+c & .or.itype(j-1).eq.ntyp1
+ &) cycle
+ call eelecij(i,j,ees,evdw1,eel_loc)
+ enddo ! j
+ num_cont_hb(i)=num_conti
+ enddo ! i
+C enddo ! zshift
+C enddo ! yshift
+C enddo ! xshift
+
+c write (iout,*) "Number of loop steps in EELEC:",ind
+cd do i=1,nres
+cd write (iout,'(i3,3f10.5,5x,3f10.5)')
+cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
+cd enddo
+c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
+ccc eel_loc=eel_loc+eello_turn3
+cd print *,"Processor",fg_rank," t_eelecij",t_eelecij
+ return
+ end
+C-------------------------------------------------------------------------------
+ subroutine eelecij(i,j,ees,evdw1,eel_loc)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'DIMENSIONS.ZSCOPT'
+#ifdef MPI
+ include "mpif.h"
+#endif
+ include 'COMMON.CONTROL'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.TORSION'
+ include 'COMMON.VECTORS'
+ include 'COMMON.FFIELD'
+ include 'COMMON.TIME1'
+ include 'COMMON.SPLITELE'
+ include 'COMMON.SHIELD'
+ dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
+ & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
+ double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
+ & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
+ & gmuij2(4),gmuji2(4)
+ common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
+ & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
+ & num_conti,j1,j2
+c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
+#ifdef MOMENT
+ double precision scal_el /1.0d0/
+#else
+ double precision scal_el /0.5d0/
+#endif
+C 12/13/98
+C 13-go grudnia roku pamietnego...
+ double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
+ & 0.0d0,1.0d0,0.0d0,
+ & 0.0d0,0.0d0,1.0d0/
+ integer xshift,yshift,zshift
+c time00=MPI_Wtime()
+cd write (iout,*) "eelecij",i,j
+c ind=ind+1
+ iteli=itel(i)
+ itelj=itel(j)
+ if (j.eq.i+2 .and. itelj.eq.2) iteli=2
+ aaa=app(iteli,itelj)
+ bbb=bpp(iteli,itelj)
+ ael6i=ael6(iteli,itelj)
+ ael3i=ael3(iteli,itelj)
+ dxj=dc(1,j)
+ dyj=dc(2,j)
+ dzj=dc(3,j)
+ dx_normj=dc_norm(1,j)
+ dy_normj=dc_norm(2,j)
+ dz_normj=dc_norm(3,j)
+C xj=c(1,j)+0.5D0*dxj-xmedi
+C yj=c(2,j)+0.5D0*dyj-ymedi
+C zj=c(3,j)+0.5D0*dzj-zmedi
+ xj=c(1,j)+0.5D0*dxj
+ yj=c(2,j)+0.5D0*dyj
+ zj=c(3,j)+0.5D0*dzj
+ xj=mod(xj,boxxsize)
+ if (xj.lt.0) xj=xj+boxxsize
+ yj=mod(yj,boxysize)
+ if (yj.lt.0) yj=yj+boxysize
+ zj=mod(zj,boxzsize)
+ if (zj.lt.0) zj=zj+boxzsize
+ if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
+ dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
+ xj_safe=xj
+ yj_safe=yj
+ zj_safe=zj
+ isubchap=0
+ do xshift=-1,1
+ do yshift=-1,1
+ do zshift=-1,1
+ xj=xj_safe+xshift*boxxsize
+ yj=yj_safe+yshift*boxysize
+ zj=zj_safe+zshift*boxzsize
+ dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
+ if(dist_temp.lt.dist_init) then
+ dist_init=dist_temp
+ xj_temp=xj
+ yj_temp=yj
+ zj_temp=zj
+ isubchap=1
+ endif
+ enddo
+ enddo
+ enddo
+ if (isubchap.eq.1) then
+ xj=xj_temp-xmedi
+ yj=yj_temp-ymedi
+ zj=zj_temp-zmedi
+ else
+ xj=xj_safe-xmedi
+ yj=yj_safe-ymedi
+ zj=zj_safe-zmedi
+ endif
+C if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
+c 174 continue
+c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
+c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
+C Condition for being inside the proper box
+c if ((xj.gt.((0.5d0)*boxxsize)).or.
+c & (xj.lt.((-0.5d0)*boxxsize))) then
+c go to 174
+c endif
+c 175 continue
+c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
+c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
+C Condition for being inside the proper box
+c if ((yj.gt.((0.5d0)*boxysize)).or.
+c & (yj.lt.((-0.5d0)*boxysize))) then
+c go to 175
+c endif
+c 176 continue
+c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
+c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
+C Condition for being inside the proper box
+c if ((zj.gt.((0.5d0)*boxzsize)).or.
+c & (zj.lt.((-0.5d0)*boxzsize))) then
+c go to 176
+c endif
+C endif !endPBC condintion
+C xj=xj-xmedi
+C yj=yj-ymedi
+C zj=zj-zmedi
+ rij=xj*xj+yj*yj+zj*zj
+
+ sss=sscale(sqrt(rij))
+ sssgrad=sscagrad(sqrt(rij))
+c write (iout,*) "ij",i,j," rij",sqrt(rij)," r_cut",r_cut,
+c & " rlamb",rlamb," sss",sss
+c if (sss.gt.0.0d0) then
+ 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
+C MARYSIA
+C eesij=(el1+el2)
+C 12/26/95 - for the evaluation of multi-body H-bonding interactions
+ ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
+ if (shield_mode.gt.0) then
+C fac_shield(i)=0.4
+C fac_shield(j)=0.6
+ el1=el1*fac_shield(i)**2*fac_shield(j)**2
+ el2=el2*fac_shield(i)**2*fac_shield(j)**2
+ eesij=(el1+el2)
+ ees=ees+eesij
+ else
+ fac_shield(i)=1.0
+ fac_shield(j)=1.0
+ eesij=(el1+el2)
+ ees=ees+eesij
+ endif
+ evdw1=evdw1+evdwij*sss
+cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
+cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
+cd & 1.0D0/dsqrt(rrmij),evdwij,eesij,
+cd & xmedi,ymedi,zmedi,xj,yj,zj
+
+ if (energy_dec) then
+ write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
+ &'evdw1',i,j,evdwij
+ &,iteli,itelj,aaa,evdw1,sss
+ write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
+ &fac_shield(i),fac_shield(j)
+ endif
+
+C
+C Calculate contributions to the Cartesian gradient.
+C
+#ifdef SPLITELE
+ facvdw=-6*rrmij*(ev1+evdwij)*sss
+ facel=-3*rrmij*(el1+eesij)
+ fac1=fac
+ erij(1)=xj*rmij
+ erij(2)=yj*rmij
+ erij(3)=zj*rmij
+
+*
+* Radial derivatives. First process both termini of the fragment (i,j)
+*
+ if (calc_grad) then
+ ggg(1)=facel*xj
+ ggg(2)=facel*yj
+ ggg(3)=facel*zj
+ if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
+ & (shield_mode.gt.0)) then
+C print *,i,j
+ do ilist=1,ishield_list(i)
+ iresshield=shield_list(ilist,i)
+ do k=1,3
+ rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
+ & *2.0
+ gshieldx(k,iresshield)=gshieldx(k,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
+ gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
+C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
+C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
+C if (iresshield.gt.i) then
+C do ishi=i+1,iresshield-1
+C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
+C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
+C
+C enddo
+C else
+C do ishi=iresshield,i
+C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
+C & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
+C
+C enddo
+C endif
+ enddo
+ enddo
+ do ilist=1,ishield_list(j)
+ iresshield=shield_list(ilist,j)
+ do k=1,3
+ rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
+ & *2.0
+ gshieldx(k,iresshield)=gshieldx(k,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
+ gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
+
+C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
+C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
+C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
+C if (iresshield.gt.j) then
+C do ishi=j+1,iresshield-1
+C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
+C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
+C
+C enddo
+C else
+C do ishi=iresshield,j
+C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
+C & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
+C enddo
+C endif
+ enddo
+ enddo
+
+ do k=1,3
+ gshieldc(k,i)=gshieldc(k,i)+
+ & grad_shield(k,i)*eesij/fac_shield(i)*2.0
+ gshieldc(k,j)=gshieldc(k,j)+
+ & grad_shield(k,j)*eesij/fac_shield(j)*2.0
+ gshieldc(k,i-1)=gshieldc(k,i-1)+
+ & grad_shield(k,i)*eesij/fac_shield(i)*2.0
+ gshieldc(k,j-1)=gshieldc(k,j-1)+
+ & grad_shield(k,j)*eesij/fac_shield(j)*2.0
+
+ enddo
+ endif
+c do k=1,3
+c ghalf=0.5D0*ggg(k)
+c gelc(k,i)=gelc(k,i)+ghalf
+c gelc(k,j)=gelc(k,j)+ghalf
+c enddo
+c 9/28/08 AL Gradient compotents will be summed only at the end
+C print *,"before", gelc_long(1,i), gelc_long(1,j)
+ do k=1,3
+ gelc_long(k,j)=gelc_long(k,j)+ggg(k)
+C & +grad_shield(k,j)*eesij/fac_shield(j)
+ gelc_long(k,i)=gelc_long(k,i)-ggg(k)
+C & +grad_shield(k,i)*eesij/fac_shield(i)
+C gelc_long(k,i-1)=gelc_long(k,i-1)
+C & +grad_shield(k,i)*eesij/fac_shield(i)
+C gelc_long(k,j-1)=gelc_long(k,j-1)
+C & +grad_shield(k,j)*eesij/fac_shield(j)
+ enddo
+C print *,"bafter", gelc_long(1,i), gelc_long(1,j)
+
+*
+* Loop over residues i+1 thru j-1.
+*
+cgrad do k=i+1,j-1
+cgrad do l=1,3
+cgrad gelc(l,k)=gelc(l,k)+ggg(l)
+cgrad enddo
+cgrad enddo
+ if (sss.gt.0.0) then
+ ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
+ ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
+ ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
+ else
+ ggg(1)=0.0
+ ggg(2)=0.0
+ ggg(3)=0.0
+ endif
+c do k=1,3
+c ghalf=0.5D0*ggg(k)
+c gvdwpp(k,i)=gvdwpp(k,i)+ghalf
+c gvdwpp(k,j)=gvdwpp(k,j)+ghalf
+c enddo
+c 9/28/08 AL Gradient compotents will be summed only at the end
+ do k=1,3
+ gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
+ gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
+ enddo
+*
+* Loop over residues i+1 thru j-1.
+*
+cgrad do k=i+1,j-1
+cgrad do l=1,3
+cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
+cgrad enddo
+cgrad enddo
+ endif ! calc_grad
+#else
+C MARYSIA
+ facvdw=(ev1+evdwij)*sss
+ facel=(el1+eesij)
+ fac1=fac
+ fac=-3*rrmij*(facvdw+facvdw+facel)
+ erij(1)=xj*rmij
+ erij(2)=yj*rmij
+ erij(3)=zj*rmij
+*
+* Radial derivatives. First process both termini of the fragment (i,j)
+*
+ if (calc_grad) then
+ ggg(1)=fac*xj
+C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
+ ggg(2)=fac*yj
+C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
+ ggg(3)=fac*zj
+C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
+c do k=1,3
+c ghalf=0.5D0*ggg(k)
+c gelc(k,i)=gelc(k,i)+ghalf
+c gelc(k,j)=gelc(k,j)+ghalf
+c enddo
+c 9/28/08 AL Gradient compotents will be summed only at the end
+ do k=1,3
+ gelc_long(k,j)=gelc(k,j)+ggg(k)
+ gelc_long(k,i)=gelc(k,i)-ggg(k)
+ enddo
+*
+* Loop over residues i+1 thru j-1.
+*
+cgrad do k=i+1,j-1
+cgrad do l=1,3
+cgrad gelc(l,k)=gelc(l,k)+ggg(l)
+cgrad enddo
+cgrad enddo
+c 9/28/08 AL Gradient compotents will be summed only at the end
+ ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
+ ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
+ ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
+ do k=1,3
+ gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
+ gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
+ enddo
+ endif ! calc_grad
+#endif
+*
+* Angular part
+*
+ if (calc_grad) then
+ 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))*
+ & fac_shield(i)**2*fac_shield(j)**2
+ enddo
+c do k=1,3
+c ghalf=0.5D0*ggg(k)
+c gelc(k,i)=gelc(k,i)+ghalf
+c & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
+c & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
+c gelc(k,j)=gelc(k,j)+ghalf
+c & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
+c & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
+c enddo
+cgrad do k=i+1,j-1
+cgrad do l=1,3
+cgrad gelc(l,k)=gelc(l,k)+ggg(l)
+cgrad enddo
+cgrad enddo
+C print *,"before22", gelc_long(1,i), gelc_long(1,j)
+ do k=1,3
+ gelc(k,i)=gelc(k,i)
+ & +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
+ & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
+ & *fac_shield(i)**2*fac_shield(j)**2
+ gelc(k,j)=gelc(k,j)
+ & +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
+ & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
+ & *fac_shield(i)**2*fac_shield(j)**2
+ gelc_long(k,j)=gelc_long(k,j)+ggg(k)
+ gelc_long(k,i)=gelc_long(k,i)-ggg(k)
+ enddo
+C print *,"before33", gelc_long(1,i), gelc_long(1,j)
+
+C MARYSIA
+c endif !sscale
+ endif ! calc_grad
+ 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
+ lll=0
+ do k=1,2
+ do l=1,2
+ kkk=kkk+1
+ muij(kkk)=mu(k,i)*mu(l,j)
+c write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
+#ifdef NEWCORR
+ if (calc_grad) then
+ gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
+c write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
+ gmuij2(kkk)=gUb2(k,i)*mu(l,j)
+ gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
+c write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
+ gmuji2(kkk)=mu(k,i)*gUb2(l,j)
+ endif
+#endif
+ enddo
+ enddo
+#ifdef DEBUG
+ write (iout,*) 'EELEC: i',i,' j',j
+ write (iout,*) 'j',j,' j1',j1,' j2',j2
+ write(iout,*) 'muij',muij
+ write (iout,*) "uy",uy(:,i)
+ write (iout,*) "uz",uz(:,j)
+ write (iout,*) "erij",erij
+#endif
+ ury=scalar(uy(1,i),erij)
+ urz=scalar(uz(1,i),erij)
+ vry=scalar(uy(1,j),erij)
+ vrz=scalar(uz(1,j),erij)
+ a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
+ a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
+ a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
+ a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
+ fac=dsqrt(-ael6i)*r3ij
+ a22=a22*fac
+ a23=a23*fac
+ a32=a32*fac
+ a33=a33*fac
+cd write (iout,'(4i5,4f10.5)')
+cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
+cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
+cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
+cd & uy(:,j),uz(:,j)
+cd write (iout,'(4f10.5)')
+cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
+cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
+cd write (iout,'(4f10.5)') ury,urz,vry,vrz
+cd write (iout,'(9f10.5/)')
+cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
+C Derivatives of the elements of A in virtual-bond vectors
+ if (calc_grad) then
+ call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
+ do k=1,3
+ uryg(k,1)=scalar(erder(1,k),uy(1,i))
+ uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
+ uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
+ urzg(k,1)=scalar(erder(1,k),uz(1,i))
+ urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
+ urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
+ vryg(k,1)=scalar(erder(1,k),uy(1,j))
+ vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
+ vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
+ vrzg(k,1)=scalar(erder(1,k),uz(1,j))
+ vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
+ vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
+ enddo
+C Compute radial contributions to the gradient
+ facr=-3.0d0*rrmij
+ a22der=a22*facr
+ a23der=a23*facr
+ a32der=a32*facr
+ a33der=a33*facr
+ agg(1,1)=a22der*xj
+ agg(2,1)=a22der*yj
+ agg(3,1)=a22der*zj
+ agg(1,2)=a23der*xj
+ agg(2,2)=a23der*yj
+ agg(3,2)=a23der*zj
+ agg(1,3)=a32der*xj
+ agg(2,3)=a32der*yj
+ agg(3,3)=a32der*zj
+ agg(1,4)=a33der*xj
+ agg(2,4)=a33der*yj
+ agg(3,4)=a33der*zj
+C Add the contributions coming from er
+ fac3=-3.0d0*fac
+ do k=1,3
+ agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
+ agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
+ agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
+ agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
+ enddo
+ do k=1,3
+C Derivatives in DC(i)
+cgrad ghalf1=0.5d0*agg(k,1)
+cgrad ghalf2=0.5d0*agg(k,2)
+cgrad ghalf3=0.5d0*agg(k,3)
+cgrad ghalf4=0.5d0*agg(k,4)
+ aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
+ & -3.0d0*uryg(k,2)*vry)!+ghalf1
+ aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
+ & -3.0d0*uryg(k,2)*vrz)!+ghalf2
+ aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
+ & -3.0d0*urzg(k,2)*vry)!+ghalf3
+ aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
+ & -3.0d0*urzg(k,2)*vrz)!+ghalf4
+C Derivatives in DC(i+1)
+ aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
+ & -3.0d0*uryg(k,3)*vry)!+agg(k,1)
+ aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
+ & -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
+ aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
+ & -3.0d0*urzg(k,3)*vry)!+agg(k,3)
+ aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
+ & -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
+C Derivatives in DC(j)
+ aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
+ & -3.0d0*vryg(k,2)*ury)!+ghalf1
+ aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
+ & -3.0d0*vrzg(k,2)*ury)!+ghalf2
+ aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
+ & -3.0d0*vryg(k,2)*urz)!+ghalf3
+ aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
+ & -3.0d0*vrzg(k,2)*urz)!+ghalf4
+C Derivatives in DC(j+1) or DC(nres-1)
+ aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
+ & -3.0d0*vryg(k,3)*ury)
+ aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
+ & -3.0d0*vrzg(k,3)*ury)
+ aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
+ & -3.0d0*vryg(k,3)*urz)
+ aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
+ & -3.0d0*vrzg(k,3)*urz)
+cgrad if (j.eq.nres-1 .and. i.lt.j-2) then
+cgrad do l=1,4
+cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l)
+cgrad enddo
+cgrad endif
+ enddo
+ endif ! calc_grad
+ acipa(1,1)=a22
+ acipa(1,2)=a23
+ acipa(2,1)=a32
+ acipa(2,2)=a33
+ a22=-a22
+ a23=-a23
+ if (calc_grad) then
+ 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
+ endif ! calc_grad
+ if (j.lt.nres-1) then
+ a22=-a22
+ a32=-a32
+ do l=1,3,2
+ do k=1,3
+ agg(k,l)=-agg(k,l)
+ aggi(k,l)=-aggi(k,l)
+ aggi1(k,l)=-aggi1(k,l)
+ aggj(k,l)=-aggj(k,l)
+ aggj1(k,l)=-aggj1(k,l)
+ enddo
+ enddo
+ else
+ a22=-a22
+ a23=-a23
+ a32=-a32
+ a33=-a33
+ do l=1,4
+ do k=1,3
+ agg(k,l)=-agg(k,l)
+ aggi(k,l)=-aggi(k,l)
+ aggi1(k,l)=-aggi1(k,l)
+ aggj(k,l)=-aggj(k,l)
+ aggj1(k,l)=-aggj1(k,l)
+ enddo
+ enddo
+ endif
+ ENDIF ! WCORR
+ IF (wel_loc.gt.0.0d0) THEN
+C Contribution to the local-electrostatic energy coming from the i-j pair
+ eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
+ & +a33*muij(4)
+#ifdef DEBUG
+ write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
+ & " a33",a33
+ write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
+ & " wel_loc",wel_loc
+#endif
+ if (shield_mode.eq.0) then
+ fac_shield(i)=1.0
+ fac_shield(j)=1.0
+C else
+C fac_shield(i)=0.4
+C fac_shield(j)=0.6
+ endif
+ eel_loc_ij=eel_loc_ij
+ & *fac_shield(i)*fac_shield(j)
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
+ & 'eelloc',i,j,eel_loc_ij
+c if (eel_loc_ij.ne.0)
+c & write (iout,'(a4,2i4,8f9.5)')'chuj',
+c & i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
+
+ eel_loc=eel_loc+eel_loc_ij
+C Now derivative over eel_loc
+ if (calc_grad) then
+ if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
+ & (shield_mode.gt.0)) then
+C print *,i,j
+
+ do ilist=1,ishield_list(i)
+ iresshield=shield_list(ilist,i)
+ do k=1,3
+ rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
+ & /fac_shield(i)
+C & *2.0
+ gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
+ gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
+ & +rlocshield
+ enddo
+ enddo
+ do ilist=1,ishield_list(j)
+ iresshield=shield_list(ilist,j)
+ do k=1,3
+ rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
+ & /fac_shield(j)
+C & *2.0
+ gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
+ gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
+ & +rlocshield
+
+ enddo
+ enddo
+
+ do k=1,3
+ gshieldc_ll(k,i)=gshieldc_ll(k,i)+
+ & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
+ gshieldc_ll(k,j)=gshieldc_ll(k,j)+
+ & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
+ gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
+ & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
+ gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
+ & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
+ enddo
+ endif
+
+
+c write (iout,*) 'i',i,' j',j,itype(i),itype(j),
+c & ' eel_loc_ij',eel_loc_ij
+C write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
+C Calculate patrial derivative for theta angle
+#ifdef NEWCORR
+ geel_loc_ij=(a22*gmuij1(1)
+ & +a23*gmuij1(2)
+ & +a32*gmuij1(3)
+ & +a33*gmuij1(4))
+ & *fac_shield(i)*fac_shield(j)
+c write(iout,*) "derivative over thatai"
+c write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
+c & a33*gmuij1(4)
+ gloc(nphi+i,icg)=gloc(nphi+i,icg)+
+ & geel_loc_ij*wel_loc
+c write(iout,*) "derivative over thatai-1"
+c write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
+c & a33*gmuij2(4)
+ geel_loc_ij=
+ & a22*gmuij2(1)
+ & +a23*gmuij2(2)
+ & +a32*gmuij2(3)
+ & +a33*gmuij2(4)
+ gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
+ & geel_loc_ij*wel_loc
+ & *fac_shield(i)*fac_shield(j)
+
+c Derivative over j residue
+ geel_loc_ji=a22*gmuji1(1)
+ & +a23*gmuji1(2)
+ & +a32*gmuji1(3)
+ & +a33*gmuji1(4)
+c write(iout,*) "derivative over thataj"
+c write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
+c & a33*gmuji1(4)
+
+ gloc(nphi+j,icg)=gloc(nphi+j,icg)+
+ & geel_loc_ji*wel_loc
+ & *fac_shield(i)*fac_shield(j)
+
+ geel_loc_ji=
+ & +a22*gmuji2(1)
+ & +a23*gmuji2(2)
+ & +a32*gmuji2(3)
+ & +a33*gmuji2(4)
+c write(iout,*) "derivative over thataj-1"
+c write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
+c & a33*gmuji2(4)
+ gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
+ & geel_loc_ji*wel_loc
+ & *fac_shield(i)*fac_shield(j)
+#endif
+cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
+
+C Partial derivatives in virtual-bond dihedral angles gamma
+ if (i.gt.1)
+ & gel_loc_loc(i-1)=gel_loc_loc(i-1)+
+ & (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
+ & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
+ & *fac_shield(i)*fac_shield(j)
+
+ gel_loc_loc(j-1)=gel_loc_loc(j-1)+
+ & (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
+ & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
+ & *fac_shield(i)*fac_shield(j)
+C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
+ do l=1,3
+ ggg(l)=(agg(l,1)*muij(1)+
+ & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
+ & *fac_shield(i)*fac_shield(j)
+ gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
+ gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
+cgrad ghalf=0.5d0*ggg(l)
+cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf
+cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf
+ enddo
+cgrad do k=i+1,j2
+cgrad do l=1,3
+cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l)
+cgrad enddo
+cgrad enddo
+C Remaining derivatives of eello
+ do l=1,3
+ gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
+ & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
+ & *fac_shield(i)*fac_shield(j)
+
+ gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
+ & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
+ & *fac_shield(i)*fac_shield(j)
+
+ gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
+ & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
+ & *fac_shield(i)*fac_shield(j)
+
+ gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
+ & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
+ & *fac_shield(i)*fac_shield(j)
+
+ enddo
+ endif ! calc_grad
+ ENDIF
+
+
+C Change 12/26/95 to calculate four-body contributions to H-bonding energy
+c if (j.gt.i+1 .and. num_conti.le.maxconts) then
+ if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
+ & .and. num_conti.le.maxconts) then
+c write (iout,*) i,j," entered corr"
+C
+C Calculate the contact function. The ith column of the array JCONT will
+C contain the numbers of atoms that make contacts with the atom I (of numbers
+C greater than I). The arrays FACONT and GACONT will contain the values of
+C the contact function and its derivative.
+c r0ij=1.02D0*rpp(iteli,itelj)
+c r0ij=1.11D0*rpp(iteli,itelj)
+ r0ij=2.20D0*rpp(iteli,itelj)
+c r0ij=1.55D0*rpp(iteli,itelj)
+ call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
+ if (fcont.gt.0.0D0) then
+ num_conti=num_conti+1
+ if (num_conti.gt.maxconts) then
+ write (iout,*) 'WARNING - max. # of contacts exceeded;',
+ & ' will skip next contacts for this conf.'
+ else
+ jcont_hb(num_conti,i)=j
+cd write (iout,*) "i",i," j",j," num_conti",num_conti,
+cd & " jcont_hb",jcont_hb(num_conti,i)
+ IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
+ & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
+C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
+C terms.
+ d_cont(num_conti,i)=rij
+cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
+C --- Electrostatic-interaction matrix ---
+ a_chuj(1,1,num_conti,i)=a22
+ a_chuj(1,2,num_conti,i)=a23
+ a_chuj(2,1,num_conti,i)=a32
+ a_chuj(2,2,num_conti,i)=a33
+C --- Gradient of rij
+ if (calc_grad) then
+ do kkk=1,3
+ grij_hb_cont(kkk,num_conti,i)=erij(kkk)
+ enddo
+ kkll=0
+ do k=1,2
+ do l=1,2
+ kkll=kkll+1
+ do m=1,3
+ a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
+ a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
+ a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
+ a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
+ a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
+ enddo
+ enddo
+ enddo
+ endif ! calc_grad
+ ENDIF
+ IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
+C Calculate contact energies
+ cosa4=4.0D0*cosa
+ wij=cosa-3.0D0*cosb*cosg
+ cosbg1=cosb+cosg
+ cosbg2=cosb-cosg
+c fac3=dsqrt(-ael6i)/r0ij**3
+ fac3=dsqrt(-ael6i)*r3ij
+c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
+ ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
+ if (ees0tmp.gt.0) then
+ ees0pij=dsqrt(ees0tmp)
+ else
+ ees0pij=0
+ endif
+c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
+ ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
+ if (ees0tmp.gt.0) then
+ ees0mij=dsqrt(ees0tmp)
+ else
+ ees0mij=0
+ endif
+c ees0mij=0.0D0
+ if (shield_mode.eq.0) then
+ fac_shield(i)=1.0d0
+ fac_shield(j)=1.0d0
+ else
+ ees0plist(num_conti,i)=j
+C fac_shield(i)=0.4d0
+C fac_shield(j)=0.6d0
+ endif
+ ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
+ & *fac_shield(i)*fac_shield(j)
+ ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
+ & *fac_shield(i)*fac_shield(j)
+C Diagnostics. Comment out or remove after debugging!
+c ees0p(num_conti,i)=0.5D0*fac3*ees0pij
+c ees0m(num_conti,i)=0.5D0*fac3*ees0mij
+c ees0m(num_conti,i)=0.0D0
+C End diagnostics.
+c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
+c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
+C Angular derivatives of the contact function
+
+ ees0pij1=fac3/ees0pij
+ ees0mij1=fac3/ees0mij
+ fac3p=-3.0D0*fac3*rrmij
+ ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
+ ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
+c ees0mij1=0.0D0
+ ecosa1= ees0pij1*( 1.0D0+0.5D0*wij)
+ ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
+ ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
+ ecosa2= ees0mij1*(-1.0D0+0.5D0*wij)
+ ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
+ ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
+ ecosap=ecosa1+ecosa2
+ ecosbp=ecosb1+ecosb2
+ ecosgp=ecosg1+ecosg2
+ ecosam=ecosa1-ecosa2
+ ecosbm=ecosb1-ecosb2
+ ecosgm=ecosg1-ecosg2
+C Diagnostics
+c ecosap=ecosa1
+c ecosbp=ecosb1
+c ecosgp=ecosg1
+c ecosam=0.0D0
+c ecosbm=0.0D0
+c ecosgm=0.0D0
+C End diagnostics
+ facont_hb(num_conti,i)=fcont
+
+ if (calc_grad) then
+ fprimcont=fprimcont/rij
+cd facont_hb(num_conti,i)=1.0D0
+C Following line is for diagnostics.
+cd fprimcont=0.0D0
+ do k=1,3
+ dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
+ dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
+ enddo
+ do k=1,3
+ gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
+ gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
+ enddo
+ gggp(1)=gggp(1)+ees0pijp*xj
+ gggp(2)=gggp(2)+ees0pijp*yj
+ gggp(3)=gggp(3)+ees0pijp*zj
+ gggm(1)=gggm(1)+ees0mijp*xj
+ gggm(2)=gggm(2)+ees0mijp*yj
+ gggm(3)=gggm(3)+ees0mijp*zj
+C Derivatives due to the contact function
+ gacont_hbr(1,num_conti,i)=fprimcont*xj
+ gacont_hbr(2,num_conti,i)=fprimcont*yj
+ gacont_hbr(3,num_conti,i)=fprimcont*zj
+ do k=1,3
+c
+c 10/24/08 cgrad and ! comments indicate the parts of the code removed
+c following the change of gradient-summation algorithm.
+c
+cgrad ghalfp=0.5D0*gggp(k)
+cgrad ghalfm=0.5D0*gggm(k)
+ gacontp_hb1(k,num_conti,i)=!ghalfp
+ & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
+ & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
+ & *fac_shield(i)*fac_shield(j)
+
+ gacontp_hb2(k,num_conti,i)=!ghalfp
+ & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
+ & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
+ & *fac_shield(i)*fac_shield(j)
+
+ gacontp_hb3(k,num_conti,i)=gggp(k)
+ & *fac_shield(i)*fac_shield(j)
+
+ gacontm_hb1(k,num_conti,i)=!ghalfm
+ & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
+ & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
+ & *fac_shield(i)*fac_shield(j)
+
+ gacontm_hb2(k,num_conti,i)=!ghalfm
+ & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
+ & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
+ & *fac_shield(i)*fac_shield(j)
+
+ gacontm_hb3(k,num_conti,i)=gggm(k)
+ & *fac_shield(i)*fac_shield(j)
+
+ enddo
+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 ! calc_grad
+
+ ENDIF ! wcorr
+ endif ! num_conti.le.maxconts
+ endif ! fcont.gt.0
+ endif ! j.gt.i+1
+ if (calc_grad) then
+ if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
+ do k=1,4
+ do l=1,3
+ ghalf=0.5d0*agg(l,k)
+ aggi(l,k)=aggi(l,k)+ghalf
+ aggi1(l,k)=aggi1(l,k)+agg(l,k)
+ aggj(l,k)=aggj(l,k)+ghalf
+ enddo
+ enddo
+ if (j.eq.nres-1 .and. i.lt.j-2) then
+ do k=1,4
+ do l=1,3
+ aggj1(l,k)=aggj1(l,k)+agg(l,k)
+ enddo
+ enddo
+ endif
+ endif
+ endif ! calc_grad
+c t_eelecij=t_eelecij+MPI_Wtime()-time00
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine eturn3(i,eello_turn3)
+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'
+ include 'COMMON.CONTROL'
+ include 'COMMON.SHIELD'
+ 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),gpizda1(2,2),
+ & gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
+ & auxgmat2(2,2),auxgmatt2(2,2)
+ double precision agg(3,4),aggi(3,4),aggi1(3,4),
+ & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
+ common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
+ & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
+ & num_conti,j1,j2
+ j=i+2
+c write (iout,*) "eturn3",i,j,j1,j2
+ a_temp(1,1)=a22
+ a_temp(1,2)=a23
+ a_temp(2,1)=a32
+ a_temp(2,2)=a33
+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))
+c auxalary matices for theta gradient
+c auxalary matrix for i+1 and constant i+2
+ call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
+c auxalary matrix for i+2 and constant i+1
+ call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
+ call transpose2(auxmat(1,1),auxmat1(1,1))
+ call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
+ call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
+ call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
+ call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
+ call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
+ if (shield_mode.eq.0) then
+ fac_shield(i)=1.0
+ fac_shield(j)=1.0
+C else
+C fac_shield(i)=0.4
+C fac_shield(j)=0.6
+ endif
+ eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
+ & *fac_shield(i)*fac_shield(j)
+ eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
+ & *fac_shield(i)*fac_shield(j)
+ if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
+ & eello_t3
+ if (calc_grad) then
+C#ifdef NEWCORR
+C Derivatives in theta
+ gloc(nphi+i,icg)=gloc(nphi+i,icg)
+ & +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
+ & *fac_shield(i)*fac_shield(j)
+ gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
+ & +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
+ & *fac_shield(i)*fac_shield(j)
+C#endif
+
+C Derivatives in shield mode
+ if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
+ & (shield_mode.gt.0)) then
+C print *,i,j
+
+ do ilist=1,ishield_list(i)
+ iresshield=shield_list(ilist,i)
+ do k=1,3
+ rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
+C & *2.0
+ gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
+ gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
+ & +rlocshield
+ enddo
+ enddo
+ do ilist=1,ishield_list(j)
+ iresshield=shield_list(ilist,j)
+ do k=1,3
+ rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
+C & *2.0
+ gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
+ gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
+ & +rlocshield
+
+ enddo
+ enddo
+
+ do k=1,3
+ gshieldc_t3(k,i)=gshieldc_t3(k,i)+
+ & grad_shield(k,i)*eello_t3/fac_shield(i)
+ gshieldc_t3(k,j)=gshieldc_t3(k,j)+
+ & grad_shield(k,j)*eello_t3/fac_shield(j)
+ gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
+ & grad_shield(k,i)*eello_t3/fac_shield(i)
+ gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
+ & grad_shield(k,j)*eello_t3/fac_shield(j)
+ enddo
+ endif
+
+C if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
+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
+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),auxmat3(1,1))
+ call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
+ gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
+ & *fac_shield(i)*fac_shield(j)
+C Derivatives in gamma(i+1)
+ call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
+ call transpose2(auxmat2(1,1),auxmat3(1,1))
+ call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
+ gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
+ & +0.5d0*(pizda(1,1)+pizda(2,2))
+ & *fac_shield(i)*fac_shield(j)
+C Cartesian derivatives
+ do l=1,3
+c ghalf1=0.5d0*agg(l,1)
+c ghalf2=0.5d0*agg(l,2)
+c ghalf3=0.5d0*agg(l,3)
+c ghalf4=0.5d0*agg(l,4)
+ a_temp(1,1)=aggi(l,1)!+ghalf1
+ a_temp(1,2)=aggi(l,2)!+ghalf2
+ a_temp(2,1)=aggi(l,3)!+ghalf3
+ a_temp(2,2)=aggi(l,4)!+ghalf4
+ call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
+ gcorr3_turn(l,i)=gcorr3_turn(l,i)
+ & +0.5d0*(pizda(1,1)+pizda(2,2))
+ & *fac_shield(i)*fac_shield(j)
+
+ a_temp(1,1)=aggi1(l,1)!+agg(l,1)
+ a_temp(1,2)=aggi1(l,2)!+agg(l,2)
+ a_temp(2,1)=aggi1(l,3)!+agg(l,3)
+ a_temp(2,2)=aggi1(l,4)!+agg(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))
+ & *fac_shield(i)*fac_shield(j)
+ a_temp(1,1)=aggj(l,1)!+ghalf1
+ a_temp(1,2)=aggj(l,2)!+ghalf2
+ a_temp(2,1)=aggj(l,3)!+ghalf3
+ a_temp(2,2)=aggj(l,4)!+ghalf4
+ call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
+ gcorr3_turn(l,j)=gcorr3_turn(l,j)
+ & +0.5d0*(pizda(1,1)+pizda(2,2))
+ & *fac_shield(i)*fac_shield(j)
+ a_temp(1,1)=aggj1(l,1)
+ a_temp(1,2)=aggj1(l,2)
+ a_temp(2,1)=aggj1(l,3)
+ 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))
+ & *fac_shield(i)*fac_shield(j)
+ enddo
+
+ endif ! calc_grad
+
+ return
+ end
+C-------------------------------------------------------------------------------
+ subroutine eturn4(i,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'
+ include 'COMMON.CONTROL'
+ include 'COMMON.SHIELD'
+ 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),auxgvec(2),
+ & auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
+ & gte1t(2,2),gte2t(2,2),gte3t(2,2),
+ & gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
+ & gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
+ double precision agg(3,4),aggi(3,4),aggi1(3,4),
+ & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
+ common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
+ & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
+ & num_conti,j1,j2
+ j=i+3
+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)
+c write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
+c write(iout,*)"WCHODZE W PROGRAM"
+ a_temp(1,1)=a22
+ a_temp(1,2)=a23
+ a_temp(2,1)=a32
+ a_temp(2,2)=a33
+ iti1=itype2loc(itype(i+1))
+ iti2=itype2loc(itype(i+2))
+ iti3=itype2loc(itype(i+3))
+c write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
+ 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))
+C Ematrix derivative in theta
+ call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
+ call transpose2(gtEug(1,1,i+2),gte2t(1,1))
+ call transpose2(gtEug(1,1,i+3),gte3t(1,1))
+ call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
+c eta1 in derivative theta
+ call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
+ call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
+c auxgvec is derivative of Ub2 so i+3 theta
+ call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
+c auxalary matrix of E i+1
+ call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
+c s1=0.0
+c gs1=0.0
+ s1=scalar2(b1(1,i+2),auxvec(1))
+c derivative of theta i+2 with constant i+3
+ gs23=scalar2(gtb1(1,i+2),auxvec(1))
+c derivative of theta i+2 with constant i+2
+ gs32=scalar2(b1(1,i+2),auxgvec(1))
+c derivative of E matix in theta of i+1
+ gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
+
+ call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
+c ea31 in derivative theta
+ call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
+ call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
+c auxilary matrix auxgvec of Ub2 with constant E matirx
+ call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
+c auxilary matrix auxgEvec1 of E matix with Ub2 constant
+ call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
+
+c s2=0.0
+c gs2=0.0
+ s2=scalar2(b1(1,i+1),auxvec(1))
+c derivative of theta i+1 with constant i+3
+ gs13=scalar2(gtb1(1,i+1),auxvec(1))
+c derivative of theta i+2 with constant i+1
+ gs21=scalar2(b1(1,i+1),auxgvec(1))
+c derivative of theta i+3 with constant i+1
+ gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
+c write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
+c & gtb1(1,i+1)
+ call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
+c two derivatives over diffetent matrices
+c gtae3e2 is derivative over i+3
+ call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
+c ae3gte2 is derivative over i+2
+ call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
+ call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
+c three possible derivative over theta E matices
+c i+1
+ call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
+c i+2
+ call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
+c i+3
+ call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+
+ gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
+ gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
+ gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
+ if (shield_mode.eq.0) then
+ fac_shield(i)=1.0
+ fac_shield(j)=1.0
+C else
+C fac_shield(i)=0.6
+C fac_shield(j)=0.4
+ endif
+ eello_turn4=eello_turn4-(s1+s2+s3)
+ & *fac_shield(i)*fac_shield(j)
+ eello_t4=-(s1+s2+s3)
+ & *fac_shield(i)*fac_shield(j)
+c write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
+ & 'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
+C Now derivative over shield:
+ if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
+ & (shield_mode.gt.0)) then
+C print *,i,j
+
+ do ilist=1,ishield_list(i)
+ iresshield=shield_list(ilist,i)
+ do k=1,3
+ rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
+C & *2.0
+ gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
+ gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
+ & +rlocshield
+ enddo
+ enddo
+ do ilist=1,ishield_list(j)
+ iresshield=shield_list(ilist,j)
+ do k=1,3
+ rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
+C & *2.0
+ gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
+ gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
+ & +rlocshield
+
+ enddo
+ enddo
+
+ do k=1,3
+ gshieldc_t4(k,i)=gshieldc_t4(k,i)+
+ & grad_shield(k,i)*eello_t4/fac_shield(i)
+ gshieldc_t4(k,j)=gshieldc_t4(k,j)+
+ & grad_shield(k,j)*eello_t4/fac_shield(j)
+ gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
+ & grad_shield(k,i)*eello_t4/fac_shield(i)
+ gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
+ & grad_shield(k,j)*eello_t4/fac_shield(j)
+ enddo
+ endif
+cd write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
+cd & ' eello_turn4_num',8*eello_turn4_num
+#ifdef NEWCORR
+ gloc(nphi+i,icg)=gloc(nphi+i,icg)
+ & -(gs13+gsE13+gsEE1)*wturn4
+ & *fac_shield(i)*fac_shield(j)
+ gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
+ & -(gs23+gs21+gsEE2)*wturn4
+ & *fac_shield(i)*fac_shield(j)
+
+ gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
+ & -(gs32+gsE31+gsEE3)*wturn4
+ & *fac_shield(i)*fac_shield(j)
+
+c gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
+c & gs2
+#endif
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
+ & 'eturn4',i,j,-(s1+s2+s3)
+c write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
+c & ' eello_turn4_num',8*eello_turn4_num
+C Derivatives in gamma(i)
+ 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,i+2),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)
+ & *fac_shield(i)*fac_shield(j)
+C Derivatives in gamma(i+1)
+ call transpose2(EUgder(1,1,i+2),e2tder(1,1))
+ call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
+ s2=scalar2(b1(1,i+1),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)
+ & *fac_shield(i)*fac_shield(j)
+C Derivatives in gamma(i+2)
+ call transpose2(EUgder(1,1,i+3),e3tder(1,1))
+ call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
+ s1=scalar2(b1(1,i+2),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,i+1),auxvec(1))
+ call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
+ call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+ gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
+ & *fac_shield(i)*fac_shield(j)
+ if (calc_grad) then
+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,i+2),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,i+1),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)
+ & *fac_shield(i)*fac_shield(j)
+ 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,i+2),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,i+1),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)
+ & *fac_shield(i)*fac_shield(j)
+ a_temp(1,1)=aggi1(l,1)
+ a_temp(1,2)=aggi1(l,2)
+ a_temp(2,1)=aggi1(l,3)
+ 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,i+2),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,i+1),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)
+ & *fac_shield(i)*fac_shield(j)
+ a_temp(1,1)=aggj(l,1)
+ a_temp(1,2)=aggj(l,2)
+ a_temp(2,1)=aggj(l,3)
+ 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,i+2),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,i+1),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)
+ & *fac_shield(i)*fac_shield(j)
+ a_temp(1,1)=aggj1(l,1)
+ a_temp(1,2)=aggj1(l,2)
+ a_temp(2,1)=aggj1(l,3)
+ 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,i+2),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,i+1),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))
+c write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
+ gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
+ & *fac_shield(i)*fac_shield(j)
+ enddo
+
+ endif ! calc_grad
+
+ 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.CONTROL'
+ 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
+ if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
+ iteli=itel(i)
+c write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
+c & " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
+ 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))
+C Returning the ith atom to box
+ xi=mod(xi,boxxsize)
+ if (xi.lt.0) xi=xi+boxxsize
+ yi=mod(yi,boxysize)
+ if (yi.lt.0) yi=yi+boxysize
+ zi=mod(zi,boxzsize)
+ if (zi.lt.0) zi=zi+boxzsize
+ do iint=1,nscp_gr(i)
+
+ do j=iscpstart(i,iint),iscpend(i,iint)
+ itypj=iabs(itype(j))
+ if (itypj.eq.ntyp1) cycle
+C Uncomment following three lines for SC-p interactions
+c xj=c(1,nres+j)-xi
+c yj=c(2,nres+j)-yi
+c zj=c(3,nres+j)-zi
+C Uncomment following three lines for Ca-p interactions
+ xj=c(1,j)
+ yj=c(2,j)
+ zj=c(3,j)
+C returning the jth atom to box
+ xj=mod(xj,boxxsize)
+ if (xj.lt.0) xj=xj+boxxsize
+ yj=mod(yj,boxysize)
+ if (yj.lt.0) yj=yj+boxysize
+ zj=mod(zj,boxzsize)
+ if (zj.lt.0) zj=zj+boxzsize
+ dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
+ xj_safe=xj
+ yj_safe=yj
+ zj_safe=zj
+ subchap=0
+C Finding the closest jth atom
+ do xshift=-1,1
+ do yshift=-1,1
+ do zshift=-1,1
+ xj=xj_safe+xshift*boxxsize
+ yj=yj_safe+yshift*boxysize
+ zj=zj_safe+zshift*boxzsize
+ dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
+ if(dist_temp.lt.dist_init) then
+ dist_init=dist_temp
+ xj_temp=xj
+ yj_temp=yj
+ zj_temp=zj
+ subchap=1
+ endif
+ enddo
+ enddo
+ enddo
+ if (subchap.eq.1) then
+ xj=xj_temp-xi
+ yj=yj_temp-yi
+ zj=zj_temp-zi
+ else
+ xj=xj_safe-xi
+ yj=yj_safe-yi
+ zj=zj_safe-zi
+ endif
+ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
+C sss is scaling function for smoothing the cutoff gradient otherwise
+C the gradient would not be continuouse
+ sss=sscale(1.0d0/(dsqrt(rrij)))
+ if (sss.le.0.0d0) cycle
+ sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
+ fac=rrij**expon2
+ e1=fac*fac*aad(itypj,iteli)
+ e2=fac*bad(itypj,iteli)
+ if (iabs(j-i) .le. 2) then
+ e1=scal14*e1
+ e2=scal14*e2
+ evdw2_14=evdw2_14+(e1+e2)*sss
+ endif
+ evdwij=e1+e2
+c write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
+c & 'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
+c & bad(itypj,iteli)
+ evdw2=evdw2+evdwij*sss
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
+ & 'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
+ & bad(itypj,iteli)
+
+ if (calc_grad) then
+C
+C Calculate contributions to the gradient in the virtual-bond and SC vectors.
+C
+ fac=-(evdwij+e1)*rrij*sss
+ fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
+ ggg(1)=xj*fac
+ ggg(2)=yj*fac
+ ggg(3)=zj*fac
+ if (j.lt.i) then
+cd write (iout,*) 'j<i'
+C Uncomment following three lines for SC-p interactions
+c do k=1,3
+c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
+c enddo
+ else
+cd write (iout,*) 'j>i'
+ 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 ! calc_grad
+ 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 'DIMENSIONS.ZSCOPT'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.VAR'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTROL'
+ include 'COMMON.IOUNITS'
+ dimension ggg(3),ggg_peak(3,1000)
+ ehpb=0.0D0
+ do i=1,3
+ ggg(i)=0.0d0
+ enddo
+c 8/21/18 AL: added explicit restraints on reference coords
+c write (iout,*) "restr_on_coord",restr_on_coord
+ if (restr_on_coord) then
+
+ do i=nnt,nct
+ ecoor=0.0d0
+ if (itype(i).eq.ntyp1) cycle
+ do j=1,3
+ ecoor=ecoor+(c(j,i)-cref(j,i))**2
+ ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
+ enddo
+ if (itype(i).ne.10) then
+ do j=1,3
+ ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
+ ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
+ enddo
+ endif
+ if (energy_dec) write (iout,*)
+ & "i",i," bfac",bfac(i)," ecoor",ecoor
+ ehpb=ehpb+0.5d0*bfac(i)*ecoor
+ enddo
+
+ endif
+
+C write (iout,*) ,"link_end",link_end,constr_dist
+cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
+c write(iout,*)'link_start=',link_start,' link_end=',link_end,
+c & " constr_dist",constr_dist
+ if (link_end.eq.0.and.link_end_peak.eq.0) return
+ do i=link_start_peak,link_end_peak
+ ehpb_peak=0.0d0
+c print *,"i",i," link_end_peak",link_end_peak," ipeak",
+c & ipeak(1,i),ipeak(2,i)
+ do ip=ipeak(1,i),ipeak(2,i)
+ ii=ihpb_peak(ip)
+ jj=jhpb_peak(ip)
+ dd=dist(ii,jj)
+ iip=ip-ipeak(1,i)+1
+C iii and jjj point to the residues for which the distance is assigned.
+c if (ii.gt.nres) then
+c iii=ii-nres
+c jjj=jj-nres
+c else
+c iii=ii
+c jjj=jj
+c endif
+ if (ii.gt.nres) then
+ iii=ii-nres
+ else
+ iii=ii
+ endif
+ if (jj.gt.nres) then
+ jjj=jj-nres
+ else
+ jjj=jj
+ endif
+ aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
+ aux=dexp(-scal_peak*aux)
+ ehpb_peak=ehpb_peak+aux
+ fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
+ & forcon_peak(ip))*aux/dd
+ do j=1,3
+ ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
+ enddo
+ if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
+ & "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
+ & forcon_peak(ip),fordepth_peak(ip),ehpb_peak
+ enddo
+c write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
+ ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
+ do ip=ipeak(1,i),ipeak(2,i)
+ iip=ip-ipeak(1,i)+1
+ do j=1,3
+ ggg(j)=ggg_peak(j,iip)/ehpb_peak
+ enddo
+ ii=ihpb_peak(ip)
+ jj=jhpb_peak(ip)
+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
+ if (iii.lt.ii) then
+ do j=1,3
+ ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
+ enddo
+ endif
+ if (jjj.lt.jj) then
+ do j=1,3
+ 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
+ enddo
+ enddo
+ 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
+ else
+ iii=ii
+ endif
+ if (jj.gt.nres) then
+ jjj=jj-nres
+ else
+ 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.
+C if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
+C & iabs(itype(jjj)).eq.1) then
+cmc if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
+C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
+ if (.not.dyn_ss .and. i.le.nss) then
+C 15/02/13 CC dynamic SSbond - additional check
+ if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
+ & iabs(itype(jjj)).eq.1) then
+ call ssbond_ene(iii,jjj,eij)
+ ehpb=ehpb+2*eij
+ endif
+cd write (iout,*) "eij",eij
+cd & ' waga=',waga,' fac=',fac
+! else if (ii.gt.nres .and. jj.gt.nres) then
+ else
+C Calculate the distance between the two points and its difference from the
+C target distance.
+ dd=dist(ii,jj)
+ if (irestr_type(i).eq.11) then
+ ehpb=ehpb+fordepth(i)!**4.0d0
+ & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
+ fac=fordepth(i)!**4.0d0
+ & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
+ if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
+ & "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
+ & ehpb,irestr_type(i)
+ else if (irestr_type(i).eq.10) then
+c AL 6//19/2018 cross-link restraints
+ xdis = 0.5d0*(dd/forcon(i))**2
+ expdis = dexp(-xdis)
+c aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
+ aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
+c write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
+c & " wboltzd",wboltzd
+ ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
+c fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
+ fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
+ & *expdis/(aux*forcon(i)**2)
+ if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
+ & "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
+ & -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
+ else if (irestr_type(i).eq.2) then
+c Quartic restraints
+ ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
+ if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
+ & "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
+ & forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
+ fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
+ else
+c Quadratic restraints
+ rdis=dd-dhpb(i)
+C Get the force constant corresponding to this distance.
+ waga=forcon(i)
+C Calculate the contribution to energy.
+ ehpb=ehpb+0.5d0*waga*rdis*rdis
+ if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
+ & "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
+ & 0.5d0*waga*rdis*rdis,irestr_type(i)
+C
+C Evaluate gradient.
+C
+ fac=waga*rdis/dd
+ endif
+c Calculate Cartesian gradient
+ 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)
+ enddo
+ endif
+ if (jjj.lt.jj) then
+ do j=1,3
+ 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
+ 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=iabs(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=iabs(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--------------------------------------------------------------------------
+c MODELLER restraint function
+ subroutine e_modeller(ehomology_constr)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'DIMENSIONS.ZSCOPT'
+ include 'DIMENSIONS.FREE'
+ integer nnn, i, j, k, ki, irec, l
+ integer katy, odleglosci, test7
+ real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
+ real*8 distance(max_template),distancek(max_template),
+ & min_odl,godl(max_template),dih_diff(max_template)
+
+c
+c FP - 30/10/2014 Temporary specifications for homology restraints
+c
+ double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
+ & sgtheta
+ double precision, dimension (maxres) :: guscdiff,usc_diff
+ double precision, dimension (max_template) ::
+ & gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
+ & theta_diff
+
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.CHAIN'
+ include 'COMMON.GEO'
+ include 'COMMON.DERIV'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.VAR'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.HOMRESTR'
+ include 'COMMON.HOMOLOGY'
+ include 'COMMON.SETUP'
+ include 'COMMON.NAMES'
+
+ do i=1,max_template
+ distancek(i)=9999999.9
+ enddo
+
+ odleg=0.0d0
+
+c Pseudo-energy and gradient from homology restraints (MODELLER-like
+c function)
+C AL 5/2/14 - Introduce list of restraints
+c write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
+#ifdef DEBUG
+ write(iout,*) "------- dist restrs start -------"
+#endif
+ do ii = link_start_homo,link_end_homo
+ i = ires_homo(ii)
+ j = jres_homo(ii)
+ dij=dist(i,j)
+c write (iout,*) "dij(",i,j,") =",dij
+ nexl=0
+ do k=1,constr_homology
+ if(.not.l_homo(k,ii)) then
+ nexl=nexl+1
+ cycle
+ endif
+ distance(k)=odl(k,ii)-dij
+c write (iout,*) "distance(",k,") =",distance(k)
+c
+c For Gaussian-type Urestr
+c
+ distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
+c write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
+c write (iout,*) "distancek(",k,") =",distancek(k)
+c distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
+c
+c For Lorentzian-type Urestr
+c
+ if (waga_dist.lt.0.0d0) then
+ sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
+ distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
+ & (distance(k)**2+sigma_odlir(k,ii)**2))
+ endif
+ enddo
+
+c min_odl=minval(distancek)
+ do kk=1,constr_homology
+ if(l_homo(kk,ii)) then
+ min_odl=distancek(kk)
+ exit
+ endif
+ enddo
+ do kk=1,constr_homology
+ if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
+ & min_odl=distancek(kk)
+ enddo
+c write (iout,* )"min_odl",min_odl
+#ifdef DEBUG
+ write (iout,*) "ij dij",i,j,dij
+ write (iout,*) "distance",(distance(k),k=1,constr_homology)
+ write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
+ write (iout,* )"min_odl",min_odl
+#endif
+#ifdef OLDRESTR
+ odleg2=0.0d0
+#else
+ if (waga_dist.ge.0.0d0) then
+ odleg2=nexl
+ else
+ odleg2=0.0d0
+ endif
+#endif
+ do k=1,constr_homology
+c Nie wiem po co to liczycie jeszcze raz!
+c odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
+c & (2*(sigma_odl(i,j,k))**2))
+ if(.not.l_homo(k,ii)) cycle
+ if (waga_dist.ge.0.0d0) then
+c
+c For Gaussian-type Urestr
+c
+ godl(k)=dexp(-distancek(k)+min_odl)
+ odleg2=odleg2+godl(k)
+c
+c For Lorentzian-type Urestr
+c
+ else
+ odleg2=odleg2+distancek(k)
+ endif
+
+ccc write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
+ccc & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
+ccc & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
+ccc & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
+
+ enddo
+c write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
+c write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
+#ifdef DEBUG
+ write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
+ write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
+#endif
+ if (waga_dist.ge.0.0d0) then
+c
+c For Gaussian-type Urestr
+c
+ odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
+c
+c For Lorentzian-type Urestr
+c
+ else
+ odleg=odleg+odleg2/constr_homology
+ endif
+c
+#ifdef GRAD
+c write (iout,*) "odleg",odleg ! sum of -ln-s
+c Gradient
+c
+c For Gaussian-type Urestr
+c
+ if (waga_dist.ge.0.0d0) sum_godl=odleg2
+ sum_sgodl=0.0d0
+ do k=1,constr_homology
+c godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
+c & *waga_dist)+min_odl
+c sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
+c
+ if(.not.l_homo(k,ii)) cycle
+ if (waga_dist.ge.0.0d0) then
+c For Gaussian-type Urestr
+c
+ sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
+c
+c For Lorentzian-type Urestr
+c
+ else
+ sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
+ & sigma_odlir(k,ii)**2)**2)
+ endif
+ sum_sgodl=sum_sgodl+sgodl
+
+c sgodl2=sgodl2+sgodl
+c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
+c write(iout,*) "constr_homology=",constr_homology
+c write(iout,*) i, j, k, "TEST K"
+ enddo
+ if (waga_dist.ge.0.0d0) then
+c
+c For Gaussian-type Urestr
+c
+ grad_odl3=waga_homology(iset)*waga_dist
+ & *sum_sgodl/(sum_godl*dij)
+c
+c For Lorentzian-type Urestr
+c
+ else
+c Original grad expr modified by analogy w Gaussian-type Urestr grad
+c grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
+ grad_odl3=-waga_homology(iset)*waga_dist*
+ & sum_sgodl/(constr_homology*dij)
+ endif
+c
+c grad_odl3=sum_sgodl/(sum_godl*dij)
+
+
+c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
+c write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
+c & (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
+
+ccc write(iout,*) godl, sgodl, grad_odl3
+
+c grad_odl=grad_odl+grad_odl3
+
+ do jik=1,3
+ ggodl=grad_odl3*(c(jik,i)-c(jik,j))
+ccc write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
+ccc write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
+ccc & ghpbc(jik,i+1), ghpbc(jik,j+1)
+ ghpbc(jik,i)=ghpbc(jik,i)+ggodl
+ ghpbc(jik,j)=ghpbc(jik,j)-ggodl
+ccc write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
+ccc & ghpbc(jik,i+1), ghpbc(jik,j+1)
+c if (i.eq.25.and.j.eq.27) then
+c write(iout,*) "jik",jik,"i",i,"j",j
+c write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
+c write(iout,*) "grad_odl3",grad_odl3
+c write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
+c write(iout,*) "ggodl",ggodl
+c write(iout,*) "ghpbc(",jik,i,")",
+c & ghpbc(jik,i),"ghpbc(",jik,j,")",
+c & ghpbc(jik,j)
+c endif
+ enddo
+#endif
+ccc write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
+ccc & dLOG(odleg2),"-odleg=", -odleg
+
+ enddo ! ii-loop for dist
+#ifdef DEBUG
+ write(iout,*) "------- dist restrs end -------"
+c if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
+c & waga_d.eq.1.0d0) call sum_gradient
+#endif
+c Pseudo-energy and gradient from dihedral-angle restraints from
+c homology templates
+c write (iout,*) "End of distance loop"
+c call flush(iout)
+ kat=0.0d0
+c write (iout,*) idihconstr_start_homo,idihconstr_end_homo
+#ifdef DEBUG
+ write(iout,*) "------- dih restrs start -------"
+ do i=idihconstr_start_homo,idihconstr_end_homo
+ write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
+ enddo
+#endif
+ do i=idihconstr_start_homo,idihconstr_end_homo
+ kat2=0.0d0
+c betai=beta(i,i+1,i+2,i+3)
+ betai = phi(i)
+c write (iout,*) "betai =",betai
+ do k=1,constr_homology
+ dih_diff(k)=pinorm(dih(k,i)-betai)
+c write (iout,*) "dih_diff(",k,") =",dih_diff(k)
+c if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
+c & -(6.28318-dih_diff(i,k))
+c if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
+c & 6.28318+dih_diff(i,k)
+#ifdef OLD_DIHED
+ kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
+#else
+ kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i)
+#endif
+c kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
+ gdih(k)=dexp(kat3)
+ kat2=kat2+gdih(k)
+c write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
+c write(*,*)""
+ enddo
+c write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
+c write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
+#ifdef DEBUG
+ write (iout,*) "i",i," betai",betai," kat2",kat2
+ write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
+#endif
+ if (kat2.le.1.0d-14) cycle
+ kat=kat-dLOG(kat2/constr_homology)
+c write (iout,*) "kat",kat ! sum of -ln-s
+
+ccc write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
+ccc & dLOG(kat2), "-kat=", -kat
+
+#ifdef GRAD
+c ----------------------------------------------------------------------
+c Gradient
+c ----------------------------------------------------------------------
+
+ sum_gdih=kat2
+ sum_sgdih=0.0d0
+ do k=1,constr_homology
+#ifdef OLD_DIHED
+ sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i) ! waga_angle rmvd
+#else
+ sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)
+#endif
+c sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
+ sum_sgdih=sum_sgdih+sgdih
+ enddo
+c grad_dih3=sum_sgdih/sum_gdih
+ grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
+
+c write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
+ccc write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
+ccc & gloc(nphi+i-3,icg)
+ gloc(i,icg)=gloc(i,icg)+grad_dih3
+c if (i.eq.25) then
+c write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
+c endif
+ccc write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
+ccc & gloc(nphi+i-3,icg)
+#endif
+ enddo ! i-loop for dih
+#ifdef DEBUG
+ write(iout,*) "------- dih restrs end -------"
+#endif
+
+c Pseudo-energy and gradient for theta angle restraints from
+c homology templates
+c FP 01/15 - inserted from econstr_local_test.F, loop structure
+c adapted
+
+c
+c For constr_homology reference structures (FP)
+c
+c Uconst_back_tot=0.0d0
+ Eval=0.0d0
+ Erot=0.0d0
+c Econstr_back legacy
+#ifdef GRAD
+ do i=1,nres
+c do i=ithet_start,ithet_end
+ dutheta(i)=0.0d0
+c enddo
+c do i=loc_start,loc_end
+ do j=1,3
+ duscdiff(j,i)=0.0d0
+ duscdiffx(j,i)=0.0d0
+ enddo
+ enddo
+#endif
+c
+c do iref=1,nref
+c write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
+c write (iout,*) "waga_theta",waga_theta
+ if (waga_theta.gt.0.0d0) then
+#ifdef DEBUG
+ write (iout,*) "usampl",usampl
+ write(iout,*) "------- theta restrs start -------"
+c do i=ithet_start,ithet_end
+c write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
+c enddo
+#endif
+c write (iout,*) "maxres",maxres,"nres",nres
+
+ do i=ithet_start,ithet_end
+c
+c do i=1,nfrag_back
+c ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
+c
+c Deviation of theta angles wrt constr_homology ref structures
+c
+ utheta_i=0.0d0 ! argument of Gaussian for single k
+ gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
+c do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
+c over residues in a fragment
+c write (iout,*) "theta(",i,")=",theta(i)
+ do k=1,constr_homology
+c
+c dtheta_i=theta(j)-thetaref(j,iref)
+c dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
+ theta_diff(k)=thetatpl(k,i)-theta(i)
+c
+ utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
+c utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
+ gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
+ gutheta_i=gutheta_i+dexp(utheta_i) ! Sum of Gaussians (pk)
+c Gradient for single Gaussian restraint in subr Econstr_back
+c dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
+c
+ enddo
+c write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
+c write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
+
+c
+#ifdef GRAD
+c Gradient for multiple Gaussian restraint
+ sum_gtheta=gutheta_i
+ sum_sgtheta=0.0d0
+ do k=1,constr_homology
+c New generalized expr for multiple Gaussian from Econstr_back
+ sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
+c
+c sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
+ sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
+ enddo
+c
+c Final value of gradient using same var as in Econstr_back
+ dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
+ & *waga_homology(iset)
+c dutheta(i)=sum_sgtheta/sum_gtheta
+c
+c Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
+#endif
+ Eval=Eval-dLOG(gutheta_i/constr_homology)
+c write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
+c write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
+c Uconst_back=Uconst_back+utheta(i)
+ enddo ! (i-loop for theta)
+#ifdef DEBUG
+ write(iout,*) "------- theta restrs end -------"
+#endif
+ endif
+c
+c Deviation of local SC geometry
+c
+c Separation of two i-loops (instructed by AL - 11/3/2014)
+c
+c write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
+c write (iout,*) "waga_d",waga_d
+
+#ifdef DEBUG
+ write(iout,*) "------- SC restrs start -------"
+ write (iout,*) "Initial duscdiff,duscdiffx"
+ do i=loc_start,loc_end
+ write (iout,*) i,(duscdiff(jik,i),jik=1,3),
+ & (duscdiffx(jik,i),jik=1,3)
+ enddo
+#endif
+ do i=loc_start,loc_end
+ usc_diff_i=0.0d0 ! argument of Gaussian for single k
+ guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
+c do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
+c write(iout,*) "xxtab, yytab, zztab"
+c write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
+ do k=1,constr_homology
+c
+ dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
+c Original sign inverted for calc of gradients (s. Econstr_back)
+ dyy=-yytpl(k,i)+yytab(i) ! ibid y
+ dzz=-zztpl(k,i)+zztab(i) ! ibid z
+c write(iout,*) "dxx, dyy, dzz"
+c write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
+c
+ usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d rmvd from Gaussian argument
+c usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
+c uscdiffk(k)=usc_diff(i)
+ guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
+ guscdiff(i)=guscdiff(i)+dexp(usc_diff_i) !Sum of Gaussians (pk)
+c write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
+c & xxref(j),yyref(j),zzref(j)
+ enddo
+c
+c Gradient
+c
+c Generalized expression for multiple Gaussian acc to that for a single
+c Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
+c
+c Original implementation
+c sum_guscdiff=guscdiff(i)
+c
+c sum_sguscdiff=0.0d0
+c do k=1,constr_homology
+c sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
+c sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
+c sum_sguscdiff=sum_sguscdiff+sguscdiff
+c enddo
+c
+c Implementation of new expressions for gradient (Jan. 2015)
+c
+c grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
+#ifdef GRAD
+ do k=1,constr_homology
+c
+c New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
+c before. Now the drivatives should be correct
+c
+ dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
+c Original sign inverted for calc of gradients (s. Econstr_back)
+ dyy=-yytpl(k,i)+yytab(i) ! ibid y
+ dzz=-zztpl(k,i)+zztab(i) ! ibid z
+c
+c New implementation
+c
+ sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
+ & sigma_d(k,i) ! for the grad wrt r'
+c sum_sguscdiff=sum_sguscdiff+sum_guscdiff
+c
+c
+c New implementation
+ sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
+ do jik=1,3
+ duscdiff(jik,i-1)=duscdiff(jik,i-1)+
+ & sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
+ & dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
+ duscdiff(jik,i)=duscdiff(jik,i)+
+ & sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
+ & dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
+ duscdiffx(jik,i)=duscdiffx(jik,i)+
+ & sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
+ & dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
+c
+#ifdef DEBUG
+ write(iout,*) "jik",jik,"i",i
+ write(iout,*) "dxx, dyy, dzz"
+ write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
+ write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
+c write(iout,*) "sum_sguscdiff",sum_sguscdiff
+cc write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
+c write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
+c write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
+c write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
+c write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
+c write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
+c write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
+c write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
+c write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
+c write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
+c write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
+c write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
+c endif
+#endif
+ enddo
+ enddo
+#endif
+c
+c uscdiff(i)=-dLOG(guscdiff(i)/(ii-1)) ! Weighting by (ii-1) required?
+c usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
+c
+c write (iout,*) i," uscdiff",uscdiff(i)
+c
+c Put together deviations from local geometry
+
+c Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
+c & wfrag_back(3,i,iset)*uscdiff(i)
+ Erot=Erot-dLOG(guscdiff(i)/constr_homology)
+c write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
+c write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
+c Uconst_back=Uconst_back+usc_diff(i)
+c
+c Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
+c
+c New implment: multiplied by sum_sguscdiff
+c
+
+ enddo ! (i-loop for dscdiff)
+
+c endif
+
+#ifdef DEBUG
+ write(iout,*) "------- SC restrs end -------"
+ write (iout,*) "------ After SC loop in e_modeller ------"
+ do i=loc_start,loc_end
+ write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
+ write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
+ enddo
+ if (waga_theta.eq.1.0d0) then
+ write (iout,*) "in e_modeller after SC restr end: dutheta"
+ do i=ithet_start,ithet_end
+ write (iout,*) i,dutheta(i)
+ enddo
+ endif
+ if (waga_d.eq.1.0d0) then
+ write (iout,*) "e_modeller after SC loop: duscdiff/x"
+ do i=1,nres
+ write (iout,*) i,(duscdiff(j,i),j=1,3)
+ write (iout,*) i,(duscdiffx(j,i),j=1,3)
+ enddo
+ endif
+#endif
+
+c Total energy from homology restraints
+#ifdef DEBUG
+ write (iout,*) "odleg",odleg," kat",kat
+ write (iout,*) "odleg",odleg," kat",kat
+ write (iout,*) "Eval",Eval," Erot",Erot
+ write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
+ write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
+ write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
+#endif
+c
+c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
+c
+c ehomology_constr=odleg+kat
+c
+c For Lorentzian-type Urestr
+c
+
+ if (waga_dist.ge.0.0d0) then
+c
+c For Gaussian-type Urestr
+c
+c ehomology_constr=(waga_dist*odleg+waga_angle*kat+
+c & waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
+ ehomology_constr=waga_dist*odleg+waga_angle*kat+
+ & waga_theta*Eval+waga_d*Erot
+c write (iout,*) "ehomology_constr=",ehomology_constr
+ else
+c
+c For Lorentzian-type Urestr
+c
+c ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
+c & waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
+ ehomology_constr=-waga_dist*odleg+waga_angle*kat+
+ & waga_theta*Eval+waga_d*Erot
+c write (iout,*) "ehomology_constr=",ehomology_constr
+ endif
+#ifdef DEBUG
+ write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
+ & "Eval",waga_theta,eval,
+ & "Erot",waga_d,Erot
+ write (iout,*) "ehomology_constr",ehomology_constr
+#endif
+ return
+
+ 748 format(a8,f12.3,a6,f12.3,a7,f12.3)
+ 747 format(a12,i4,i4,i4,f8.3,f8.3)
+ 746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
+ 778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
+ 779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
+ & f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
+ end
+c-----------------------------------------------------------------------
+ subroutine ebond(estr)
+c
+c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
+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
+ estr1=0.0d0
+c write (iout,*) "distchainmax",distchainmax
+ do i=nnt+1,nct
+ if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
+C estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
+C do j=1,3
+C gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
+C & *dc(j,i-1)/vbld(i)
+C enddo
+C if (energy_dec) write(iout,*)
+C & "estr1",i,vbld(i),distchainmax,
+C & gnmr1(vbld(i),-1.0d0,distchainmax)
+C else
+ if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
+ diff = vbld(i)-vbldpDUM
+C write(iout,*) i,diff
+ else
+ diff = vbld(i)-vbldp0
+c write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
+ endif
+ estr=estr+diff*diff
+ do j=1,3
+ gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
+ enddo
+C endif
+C write (iout,'(a7,i5,4f7.3)')
+C & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
+ enddo
+ estr=0.5d0*AKP*estr+estr1
+c
+c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
+c
+ do i=nnt,nct
+ iti=iabs(itype(i))
+ if (iti.ne.10 .and. iti.ne.ntyp1) then
+ nbi=nbondterm(iti)
+ if (nbi.eq.1) then
+ diff=vbld(i+nres)-vbldsc0(1,iti)
+C write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
+C & AKSC(1,iti),AKSC(1,iti)*diff*diff
+ 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,ethetacnstr)
+C
+C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
+C angles gamma and its derivatives in consecutive thetas and gammas.
+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.TORCNSTR'
+ common /calcthet/ term1,term2,termm,diffak,ratak,
+ & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
+ & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
+ double precision y(2),z(2)
+ delta=0.02d0*pi
+c time11=dexp(-2*time)
+c time12=1.0d0
+ etheta=0.0D0
+c write (iout,*) "nres",nres
+c write (*,'(a,i2)') 'EBEND ICG=',icg
+c write (iout,*) ithet_start,ithet_end
+ do i=ithet_start,ithet_end
+C if (itype(i-1).eq.ntyp1) cycle
+ if (i.le.2) cycle
+ if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
+ & .or.itype(i).eq.ntyp1) cycle
+C Zero the energy function and its derivative at 0 or pi.
+ call splinthet(theta(i),0.5d0*delta,ss,ssd)
+ it=itype(i-1)
+ ichir1=isign(1,itype(i-2))
+ ichir2=isign(1,itype(i))
+ if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
+ if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
+ if (itype(i-1).eq.10) then
+ itype1=isign(10,itype(i-2))
+ ichir11=isign(1,itype(i-2))
+ ichir12=isign(1,itype(i-2))
+ itype2=isign(10,itype(i))
+ ichir21=isign(1,itype(i))
+ ichir22=isign(1,itype(i))
+ endif
+ if (i.eq.3) then
+ y(1)=0.0D0
+ y(2)=0.0D0
+ else
+
+ if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
+#ifdef OSF
+ phii=phi(i)
+c icrc=0
+c 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
+ endif
+ if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
+#ifdef OSF
+ phii1=phi(i+1)
+c icrc=0
+c 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,ichir1,ichir2)
+ bthetk=bthet(k,it,ichir1,ichir2)
+ if (it.eq.10) then
+ athetk=athet(k,itype1,ichir11,ichir12)
+ bthetk=bthet(k,itype2,ichir21,ichir22)
+ endif
+ thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
+ enddo
+c write (iout,*) "thet_pred_mean",thet_pred_mean
+ 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,ichir1,ichir2)*y(2)
+ &+athet(2,it,ichir1,ichir2)*y(1))*ss
+ dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
+ & +bthet(2,it,ichir1,ichir2)*z(1))*ss
+ if (it.eq.10) then
+ dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
+ &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
+ dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
+ & +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
+ endif
+ if (theta(i).gt.pi-delta) then
+ call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
+ & E_tc0)
+ 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,'(a6,i5,0pf7.3,f7.3,i5)')
+c & 'ebend',i,ethetai,theta(i),itype(i)
+c write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
+c & rad2deg*phii,rad2deg*phii1,ethetai
+ if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
+ if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
+ gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
+c 1215 continue
+ enddo
+ ethetacnstr=0.0d0
+C print *,ithetaconstr_start,ithetaconstr_end,"TU"
+ do i=1,ntheta_constr
+ itheta=itheta_constr(i)
+ thetiii=theta(itheta)
+ difi=pinorm(thetiii-theta_constr0(i))
+ if (difi.gt.theta_drange(i)) then
+ difi=difi-theta_drange(i)
+ ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
+ gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
+ & +for_thet_constr(i)*difi**3
+ else if (difi.lt.-drange(i)) then
+ difi=difi+drange(i)
+ ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
+ gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
+ & +for_thet_constr(i)*difi**3
+ else
+ difi=0.0
+ endif
+C if (energy_dec) then
+C write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
+C & i,itheta,rad2deg*thetiii,
+C & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
+C & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
+C & gloc(itheta+nphi-2,icg)
+C endif
+ enddo
+C Ufff.... We've done all this!!!
+ return
+ 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'
+ include 'COMMON.TORCNSTR'
+ 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
+C if (i.eq.2) cycle
+C if (itype(i-1).eq.ntyp1) cycle
+ if (i.le.2) cycle
+ if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
+ & .or.itype(i).eq.ntyp1) cycle
+ if (iabs(itype(i+1)).eq.20) iblock=2
+ if (iabs(itype(i+1)).ne.20) iblock=1
+ dethetai=0.0d0
+ dephii=0.0d0
+ dephii1=0.0d0
+ theti2=0.5d0*theta(i)
+ ityp2=ithetyp((itype(i-1)))
+ do k=1,nntheterm
+ coskt(k)=dcos(k*theti2)
+ sinkt(k)=dsin(k*theti2)
+ enddo
+ if (i.eq.3) then
+ phii=0.0d0
+ ityp1=nthetyp+1
+ do k=1,nsingle
+ cosph1(k)=0.0d0
+ sinph1(k)=0.0d0
+ enddo
+ else
+ if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
+#ifdef OSF
+ phii=phi(i)
+ if (phii.ne.phii) phii=150.0
+#else
+ phii=phi(i)
+#endif
+ ityp1=ithetyp((itype(i-2)))
+ do k=1,nsingle
+ cosph1(k)=dcos(k*phii)
+ sinph1(k)=dsin(k*phii)
+ enddo
+ else
+ phii=0.0d0
+c ityp1=nthetyp+1
+ do k=1,nsingle
+ ityp1=ithetyp((itype(i-2)))
+ cosph1(k)=0.0d0
+ sinph1(k)=0.0d0
+ enddo
+ endif
+ endif
+ if (i.lt.nres .and. itype(i+1).ne.ntyp1) 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
+c ityp3=nthetyp+1
+ ityp3=ithetyp((itype(i)))
+ 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,iblock)
+ 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,iblock)*sinkt(k)
+ dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
+ & *coskt(k)
+ if (lprn)
+ & write (iout,*) "k",k,"
+ & aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
+ & " 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,iblock)*cosph1(k)
+ & +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
+ & +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
+ & +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
+ ethetai=ethetai+sinkt(m)*aux
+ dethetai=dethetai+0.5d0*m*aux*coskt(m)
+ dephii=dephii+k*sinkt(m)*(
+ & ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
+ & bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
+ dephii1=dephii1+k*sinkt(m)*(
+ & eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
+ & ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
+ if (lprn)
+ & write (iout,*) "m",m," k",k," bbthet",
+ & bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
+ & ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
+ & ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
+ & eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
+ enddo
+ enddo
+ if (lprn)
+ & 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,iblock)*cosph1ph2(l,k)+
+ & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
+ & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
+ & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
+ ethetai=ethetai+sinkt(m)*aux
+ dethetai=dethetai+0.5d0*m*coskt(m)*aux
+ dephii=dephii+l*sinkt(m)*(
+ & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
+ & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
+ & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
+ & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
+ dephii1=dephii1+(k-l)*sinkt(m)*(
+ & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
+ & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
+ & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
+ & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
+ if (lprn) then
+ write (iout,*) "m",m," k",k," l",l," ffthet",
+ & ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
+ & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
+ & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
+ & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
+ & " ethetai",ethetai
+ write (iout,*) cosph1ph2(l,k)*sinkt(m),
+ & cosph1ph2(k,l)*sinkt(m),
+ & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
+ 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
+c gloc(nphi+i-2,icg)=wang*dethetai
+ gloc(nphi+i-2,icg)=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,*) 'ESC'
+ do i=loc_start,loc_end
+ it=itype(i)
+ if (it.eq.ntyp1) cycle
+ if (it.eq.10) goto 1
+ nlobit=nlob(iabs(it))
+c print *,'i=',i,' it=',it,' nlobit=',nlobit
+C write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
+ theti=theta(i+1)-pipol
+ 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)
+ write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
+ & esclocbi,ss,ssd
+ escloci=ss*escloci+(1.0d0-ss)*esclocbi
+c escloci=esclocbi
+c write (iout,*) escloci
+ 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,*) 'i=',i, escloci
+ else
+ call enesc(x,escloci,dersc,ddummy,.false.)
+ endif
+
+ escloc=escloc+escloci
+C write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
+ write (iout,'(a6,i5,0pf7.3)')
+ & 'escloc',i,escloci
+
+ gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
+ & wscloc*dersc(1)
+ 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,iabs(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,iabs(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
+ if (itype(i).eq.ntyp1) cycle
+ costtab(i+1) =dcos(theta(i+1))
+ sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
+ cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
+ 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=iabs(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)*dsign(1.0d0,dfloat(itype(i)))
+ 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=iabs(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 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
+ write(2,'(3f8.1,3f9.3,1x,3f9.3)')
+ & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
+ & xx1,yy1,zz1
+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
+c write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
+c & zz,xx,yy
+ 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)
+ & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
+ dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
+ & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
+ enddo
+
+ dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
+ 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,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 (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
+ & .or. itype(i).eq.ntyp1) cycle
+ itori=itortyp(itype(i-2))
+ itori1=itortyp(itype(i-1))
+ phii=phi(i)
+ 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
+ return
+ end
+c------------------------------------------------------------------------------
+#else
+ subroutine etor(etors,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 (i.le.2) cycle
+ if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
+ & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
+C if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
+C & .or. itype(i).eq.ntyp1) cycle
+ if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
+ if (iabs(itype(i)).eq.20) then
+ iblock=2
+ else
+ iblock=1
+ endif
+ itori=itortyp(itype(i-2))
+ itori1=itortyp(itype(i-1))
+ phii=phi(i)
+ gloci=0.0D0
+C Regular cosine and sine terms
+ do j=1,nterm(itori,itori1,iblock)
+ v1ij=v1(j,itori,itori1,iblock)
+ v2ij=v2(j,itori,itori1,iblock)
+ cosphi=dcos(j*phii)
+ sinphi=dsin(j*phii)
+ etors=etors+v1ij*cosphi+v2ij*sinphi
+ 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,iblock)
+ vl1ij=vlor1(j,itori,itori1)
+ vl2ij=vlor2(j,itori,itori1)
+ vl3ij=vlor3(j,itori,itori1)
+ pom=vl2ij*cosphi+vl3ij*sinphi
+ pom1=1.0d0/(pom*pom+1.0d0)
+ etors=etors+vl1ij*pom1
+c if (energy_dec) etors_ii=etors_ii+
+c & vl1ij*pom1
+ pom=-pom*pom1*pom1
+ gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
+ enddo
+C Subtract the constant term
+ etors=etors-v0(itori,itori1,iblock)
+ if (lprn)
+ & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
+ & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
+ & (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
+ gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
+c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
+ 1215 continue
+ enddo
+ 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 (i.le.3) cycle
+C if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
+C & .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
+ if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
+ & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
+ & (itype(i+1).eq.ntyp1)) cycle
+ if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
+ & goto 1215
+ itori=itortyp(itype(i-2))
+ itori1=itortyp(itype(i-1))
+ itori2=itortyp(itype(i))
+ phii=phi(i)
+ phii1=phi(i+1)
+ gloci1=0.0D0
+ gloci2=0.0D0
+ iblock=1
+ if (iabs(itype(i+1)).eq.20) iblock=2
+C Regular cosine and sine terms
+ do j=1,ntermd_1(itori,itori1,itori2,iblock)
+ v1cij=v1c(1,j,itori,itori1,itori2,iblock)
+ v1sij=v1s(1,j,itori,itori1,itori2,iblock)
+ v2cij=v1c(2,j,itori,itori1,itori2,iblock)
+ v2sij=v1s(2,j,itori,itori1,itori2,iblock)
+ cosphi1=dcos(j*phii)
+ sinphi1=dsin(j*phii)
+ cosphi2=dcos(j*phii1)
+ 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,iblock)
+ do l=1,k-1
+ v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
+ v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
+ v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
+ v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
+ cosphi1p2=dcos(l*phii+(k-l)*phii1)
+ cosphi1m2=dcos(l*phii-(k-l)*phii1)
+ sinphi1p2=dsin(l*phii+(k-l)*phii1)
+ 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---------------------------------------------------------------------------
+C The rigorous attempt to derive energy function
+ subroutine etor_kcc(etors,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'
+ include 'COMMON.CONTROL'
+ double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
+ logical lprn
+c double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
+C Set lprn=.true. for debugging
+ lprn=energy_dec
+c lprn=.true.
+C print *,"wchodze kcc"
+ if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
+ etors=0.0D0
+ do i=iphi_start,iphi_end
+C ANY TWO ARE DUMMY ATOMS in row CYCLE
+c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
+c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
+c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
+ if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
+ & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
+ itori=itortyp(itype(i-2))
+ itori1=itortyp(itype(i-1))
+ phii=phi(i)
+ glocig=0.0D0
+ glocit1=0.0d0
+ glocit2=0.0d0
+C to avoid multiple devision by 2
+c theti22=0.5d0*theta(i)
+C theta 12 is the theta_1 /2
+C theta 22 is theta_2 /2
+c theti12=0.5d0*theta(i-1)
+C and appropriate sinus function
+ sinthet1=dsin(theta(i-1))
+ sinthet2=dsin(theta(i))
+ costhet1=dcos(theta(i-1))
+ costhet2=dcos(theta(i))
+C to speed up lets store its mutliplication
+ sint1t2=sinthet2*sinthet1
+ sint1t2n=1.0d0
+C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
+C +d_n*sin(n*gamma)) *
+C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
+C we have two sum 1) Non-Chebyshev which is with n and gamma
+ nval=nterm_kcc_Tb(itori,itori1)
+ c1(0)=0.0d0
+ c2(0)=0.0d0
+ c1(1)=1.0d0
+ c2(1)=1.0d0
+ do j=2,nval
+ c1(j)=c1(j-1)*costhet1
+ c2(j)=c2(j-1)*costhet2
+ enddo
+ etori=0.0d0
+ do j=1,nterm_kcc(itori,itori1)
+ cosphi=dcos(j*phii)
+ sinphi=dsin(j*phii)
+ sint1t2n1=sint1t2n
+ sint1t2n=sint1t2n*sint1t2
+ sumvalc=0.0d0
+ gradvalct1=0.0d0
+ gradvalct2=0.0d0
+ do k=1,nval
+ do l=1,nval
+ sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
+ gradvalct1=gradvalct1+
+ & (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
+ gradvalct2=gradvalct2+
+ & (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
+ enddo
+ enddo
+ gradvalct1=-gradvalct1*sinthet1
+ gradvalct2=-gradvalct2*sinthet2
+ sumvals=0.0d0
+ gradvalst1=0.0d0
+ gradvalst2=0.0d0
+ do k=1,nval
+ do l=1,nval
+ sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
+ gradvalst1=gradvalst1+
+ & (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
+ gradvalst2=gradvalst2+
+ & (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
+ enddo
+ enddo
+ gradvalst1=-gradvalst1*sinthet1
+ gradvalst2=-gradvalst2*sinthet2
+ etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
+C glocig is the gradient local i site in gamma
+ glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
+C now gradient over theta_1
+ glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
+ & +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
+ glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
+ & +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
+ enddo ! j
+ etors=etors+etori
+C derivative over gamma
+ gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
+C derivative over theta1
+ gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
+C now derivative over theta2
+ gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
+ if (lprn) then
+ write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
+ & theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
+ write (iout,*) "c1",(c1(k),k=0,nval),
+ & " c2",(c2(k),k=0,nval)
+ write (iout,*) "sumvalc",sumvalc," sumvals",sumvals
+ endif
+ enddo
+ return
+ end
+c---------------------------------------------------------------------------------------------
+ subroutine etor_constr(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'
+ include 'COMMON.CONTROL'
+! 6/20/98 - dihedral angle constraints
+ edihcnstr=0.0d0
+c do i=1,ndih_constr
+c write (iout,*) "idihconstr_start",idihconstr_start,
+c & " idihconstr_end",idihconstr_end
+
+ if (raw_psipred) then
+ do i=idihconstr_start,idihconstr_end
+ itori=idih_constr(i)
+ phii=phi(itori)
+ gaudih_i=vpsipred(1,i)
+ gauder_i=0.0d0
+ do j=1,2
+ s = sdihed(j,i)
+ cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
+ dexpcos_i=dexp(-cos_i*cos_i)
+ gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
+ gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
+ & *cos_i*dexpcos_i/s**2
+ enddo
+ edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
+ gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
+ if (energy_dec)
+ & write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
+ & i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
+ & phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
+ & phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
+ & -wdihc*dlog(gaudih_i)
+ enddo
+ else
+
+ do i=idihconstr_start,idihconstr_end
+ itori=idih_constr(i)
+ phii=phi(itori)
+ difi=pinorm(phii-phi0(i))
+ if (difi.gt.drange(i)) then
+ difi=difi-drange(i)
+ edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
+ gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
+ else if (difi.lt.-drange(i)) then
+ difi=difi+drange(i)
+ edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
+ gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
+ else
+ difi=0.0
+ endif
+ enddo
+
+ endif
+
+c write (iout,*) "ETOR_CONSTR",edihcnstr
+ return
+ end
+c----------------------------------------------------------------------------
+C The rigorous attempt to derive energy function
+ subroutine ebend_kcc(etheta)
+
+ 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'
+ include 'COMMON.CONTROL'
+ logical lprn
+ double precision thybt1(maxang_kcc)
+C Set lprn=.true. for debugging
+ lprn=energy_dec
+c lprn=.true.
+C print *,"wchodze kcc"
+ if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
+ etheta=0.0D0
+ do i=ithet_start,ithet_end
+c print *,i,itype(i-1),itype(i),itype(i-2)
+ if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
+ & .or.itype(i).eq.ntyp1) cycle
+ iti=iabs(itortyp(itype(i-1)))
+ sinthet=dsin(theta(i))
+ costhet=dcos(theta(i))
+ do j=1,nbend_kcc_Tb(iti)
+ thybt1(j)=v1bend_chyb(j,iti)
+ enddo
+ sumth1thyb=v1bend_chyb(0,iti)+
+ & tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
+ if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
+ & sumth1thyb
+ ihelp=nbend_kcc_Tb(iti)-1
+ gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
+ etheta=etheta+sumth1thyb
+C print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
+ gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
+ enddo
+ return
+ end
+c-------------------------------------------------------------------------------------
+ subroutine etheta_constr(ethetacnstr)
+
+ 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'
+ include 'COMMON.CONTROL'
+ ethetacnstr=0.0d0
+C print *,ithetaconstr_start,ithetaconstr_end,"TU"
+ do i=ithetaconstr_start,ithetaconstr_end
+ itheta=itheta_constr(i)
+ thetiii=theta(itheta)
+ difi=pinorm(thetiii-theta_constr0(i))
+ if (difi.gt.theta_drange(i)) then
+ difi=difi-theta_drange(i)
+ ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
+ gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
+ & +for_thet_constr(i)*difi**3
+ else if (difi.lt.-drange(i)) then
+ difi=difi+drange(i)
+ ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
+ gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
+ & +for_thet_constr(i)*difi**3
+ else
+ difi=0.0
+ endif
+ if (energy_dec) then
+ write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
+ & i,itheta,rad2deg*thetiii,
+ & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
+ & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
+ & gloc(itheta+nphi-2,icg)
+ endif
+ enddo
+ return
+ end
+c------------------------------------------------------------------------------
+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",iphi_start,iphi_end,nterm_sccor
+ esccor=0.0D0
+ do i=itau_start,itau_end
+ if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
+ esccor_ii=0.0D0
+ isccori=isccortyp(itype(i-2))
+ isccori1=isccortyp(itype(i-1))
+ phii=phi(i)
+ 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.ntyp1).or.
+ & (itype(i-1).eq.ntyp1)))
+ & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
+ & .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
+ & .or.(itype(i).eq.ntyp1)))
+ & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
+ & (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
+ & (itype(i-3).eq.ntyp1)))) cycle
+ if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
+ if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
+ & 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
+C write (iout,*)"EBACK_SC_COR",esccor,i
+c write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
+c & nterm_sccor(isccori,isccori1),isccori,isccori1
+c gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
+ 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,1,itori,itori1),j=1,6)
+ & ,(v2sccor(j,1,itori,itori1),j=1,6)
+c gsccor_loc(i-3)=gloci
+ enddo !intertyp
+ enddo
+ return
+ end
+c------------------------------------------------------------------------------
+ subroutine multibody(ecorr)
+C This subroutine calculates multi-body contributions to energy following
+C the idea of Skolnick et al. If side chains I and J make a contact and
+C at the same time side chains I+1 and J+1 make a contact, an extra
+C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTACTS'
+ double precision gx(3),gx1(3)
+ logical lprn
+
+C Set lprn=.true. for debugging
+ lprn=.false.
+
+ if (lprn) then
+ write (iout,'(a)') 'Contact function values:'
+ do i=nnt,nct-2
+ write (iout,'(i2,20(1x,i2,f10.5))')
+ & i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
+ enddo
+ endif
+ ecorr=0.0D0
+ do i=nnt,nct
+ do j=1,3
+ gradcorr(j,i)=0.0D0
+ gradxorr(j,i)=0.0D0
+ enddo
+ enddo
+ do i=nnt,nct-2
+
+ DO ISHIFT = 3,4
+
+ i1=i+ishift
+ num_conti=num_cont(i)
+ num_conti1=num_cont(i1)
+ do jj=1,num_conti
+ j=jcont(jj,i)
+ do kk=1,num_conti1
+ j1=jcont(kk,i1)
+ if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
+cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
+cd & ' ishift=',ishift
+C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
+C The system gains extra energy.
+ ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
+ endif ! j1==j+-ishift
+ enddo ! kk
+ enddo ! jj
+
+ ENDDO ! ISHIFT
+
+ enddo ! i
+ return
+ end
+c------------------------------------------------------------------------------
+ double precision function esccorr(i,j,k,l,jj,kk)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTACTS'
+ double precision gx(3),gx1(3)
+ logical lprn
+ lprn=.false.
+ eij=facont(jj,i)
+ ekl=facont(kk,k)
+cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
+C Calculate the multi-body contribution to energy.
+C Calculate multi-body contributions to the gradient.
+cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
+cd & k,l,(gacont(m,kk,k),m=1,3)
+ do m=1,3
+ gx(m) =ekl*gacont(m,jj,i)
+ gx1(m)=eij*gacont(m,kk,k)
+ gradxorr(m,i)=gradxorr(m,i)-gx(m)
+ gradxorr(m,j)=gradxorr(m,j)+gx(m)
+ gradxorr(m,k)=gradxorr(m,k)-gx1(m)
+ gradxorr(m,l)=gradxorr(m,l)+gx1(m)
+ enddo
+ do m=i,j-1
+ do ll=1,3
+ gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
+ enddo
+ enddo
+ do m=k,l-1
+ do ll=1,3
+ gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
+ enddo
+ enddo
+ esccorr=-eij*ekl
+ return
+ end
+c------------------------------------------------------------------------------
+ subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
+C This subroutine calculates multi-body contributions to hydrogen-bonding
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'DIMENSIONS.ZSCOPT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.FFIELD'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTACTS'
+ double precision gx(3),gx1(3)
+ logical lprn,ldone
+
+C Set lprn=.true. for debugging
+ lprn=.false.
+ 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 MPI
+ include "mpif.h"
+#endif
+ include 'COMMON.FFIELD'
+ include 'COMMON.DERIV'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.CONTROL'
+ include 'COMMON.SHIELD'
+ double precision gx(3),gx1(3)
+ integer num_cont_hb_old(maxres)
+ logical lprn,ldone
+ double precision eello4,eello5,eelo6,eello_turn6
+ external eello4,eello5,eello6,eello_turn6
+C Set lprn=.true. for debugging
+ lprn=.false.
+ eturn6=0.0d0
+ if (lprn) then
+ write (iout,'(a)') 'Contact function values:'
+ do i=nnt,nct-2
+ write (iout,'(2i3,50(1x,i2,5f6.3))')
+ & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
+ & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
+ enddo
+ endif
+ ecorr=0.0D0
+ ecorr5=0.0d0
+ ecorr6=0.0d0
+C Remove the loop below after debugging !!!
+ do i=nnt,nct
+ do j=1,3
+ gradcorr(j,i)=0.0D0
+ gradxorr(j,i)=0.0D0
+ enddo
+ enddo
+C Calculate the dipole-dipole interaction energies
+ if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
+ do i=iatel_s,iatel_e+1
+ num_conti=num_cont_hb(i)
+ do jj=1,num_conti
+ j=jcont_hb(jj,i)
+#ifdef MOMENT
+ call dipole(i,j,jj)
+#endif
+ enddo
+ enddo
+ endif
+C Calculate the local-electrostatic correlation terms
+c write (iout,*) "gradcorr5 in eello5 before loop"
+c do iii=1,nres
+c write (iout,'(i5,3f10.5)')
+c & iii,(gradcorr5(jjj,iii),jjj=1,3)
+c enddo
+ do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
+c write (iout,*) "corr loop i",i
+ i1=i+1
+ num_conti=num_cont_hb(i)
+ num_conti1=num_cont_hb(i+1)
+ do jj=1,num_conti
+ j=jcont_hb(jj,i)
+ jp=iabs(j)
+ do kk=1,num_conti1
+ j1=jcont_hb(kk,i1)
+ jp1=iabs(j1)
+c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
+c & ' jj=',jj,' kk=',kk
+c if (j1.eq.j+1 .or. j1.eq.j-1) then
+ if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
+ & .or. j.lt.0 .and. j1.gt.0) .and.
+ & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
+C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
+C The system gains extra energy.
+ n_corr=n_corr+1
+ sqd1=dsqrt(d_cont(jj,i))
+ sqd2=dsqrt(d_cont(kk,i1))
+ sred_geom = sqd1*sqd2
+ IF (sred_geom.lt.cutoff_corr) THEN
+ call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
+ & ekont,fprimcont)
+cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
+cd & ' jj=',jj,' kk=',kk
+ fac_prim1=0.5d0*sqd2/sqd1*fprimcont
+ fac_prim2=0.5d0*sqd1/sqd2*fprimcont
+ do l=1,3
+ g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
+ g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
+ enddo
+ n_corr1=n_corr1+1
+cd write (iout,*) 'sred_geom=',sred_geom,
+cd & ' ekont=',ekont,' fprim=',fprimcont,
+cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
+cd write (iout,*) "g_contij",g_contij
+cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
+cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
+ call calc_eello(i,jp,i+1,jp1,jj,kk)
+ if (wcorr4.gt.0.0d0)
+ & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
+CC & *fac_shield(i)**2*fac_shield(j)**2
+ if (energy_dec.and.wcorr4.gt.0.0d0)
+ 1 write (iout,'(a6,4i5,0pf7.3)')
+ 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
+c write (iout,*) "gradcorr5 before eello5"
+c do iii=1,nres
+c write (iout,'(i5,3f10.5)')
+c & iii,(gradcorr5(jjj,iii),jjj=1,3)
+c enddo
+ if (wcorr5.gt.0.0d0)
+ & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
+c write (iout,*) "gradcorr5 after eello5"
+c do iii=1,nres
+c write (iout,'(i5,3f10.5)')
+c & iii,(gradcorr5(jjj,iii),jjj=1,3)
+c enddo
+ if (energy_dec.and.wcorr5.gt.0.0d0)
+ 1 write (iout,'(a6,4i5,0pf7.3)')
+ 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
+cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
+cd write(2,*)'ijkl',i,jp,i+1,jp1
+ if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
+ & .or. wturn6.eq.0.0d0))then
+cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
+ ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
+ if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
+ 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
+cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
+cd & 'ecorr6=',ecorr6
+cd write (iout,'(4e15.5)') sred_geom,
+cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)),
+cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)),
+cd & dabs(eello6(i,jp,i+1,jp1,jj,kk))
+ else if (wturn6.gt.0.0d0
+ & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
+cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
+ eturn6=eturn6+eello_turn6(i,jj,kk)
+ if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
+ 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
+cd write (2,*) 'multibody_eello:eturn6',eturn6
+ endif
+ ENDIF
+1111 continue
+ endif
+ enddo ! kk
+ enddo ! jj
+ enddo ! i
+ do i=1,nres
+ num_cont_hb(i)=num_cont_hb_old(i)
+ enddo
+c write (iout,*) "gradcorr5 in eello5"
+c do iii=1,nres
+c write (iout,'(i5,3f10.5)')
+c & iii,(gradcorr5(jjj,iii),jjj=1,3)
+c enddo
+ return
+ end
+c------------------------------------------------------------------------------
+ double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'DIMENSIONS.ZSCOPT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.SHIELD'
+ include 'COMMON.CONTROL'
+ double precision gx(3),gx1(3)
+ logical lprn
+ lprn=.false.
+C print *,"wchodze",fac_shield(i),shield_mode
+ 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)
+C*
+C & fac_shield(i)**2*fac_shield(j)**2
+cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
+C Following 4 lines for diagnostics.
+cd ees0pkl=0.0D0
+cd ees0pij=1.0D0
+cd ees0mkl=0.0D0
+cd ees0mij=1.0D0
+c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
+c & 'Contacts ',i,j,
+c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
+c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
+c & 'gradcorr_long'
+C Calculate the multi-body contribution to energy.
+C ecorr=ecorr+ekont*ees
+C Calculate multi-body contributions to the gradient.
+ coeffpees0pij=coeffp*ees0pij
+ coeffmees0mij=coeffm*ees0mij
+ coeffpees0pkl=coeffp*ees0pkl
+ coeffmees0mkl=coeffm*ees0mkl
+ do ll=1,3
+cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
+ gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
+ & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
+ & coeffmees0mkl*gacontm_hb1(ll,jj,i))
+ gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
+ & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
+ & coeffmees0mkl*gacontm_hb2(ll,jj,i))
+cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k)
+ gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
+ & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
+ & coeffmees0mij*gacontm_hb1(ll,kk,k))
+ gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
+ & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
+ & coeffmees0mij*gacontm_hb2(ll,kk,k))
+ gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
+ & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
+ & coeffmees0mkl*gacontm_hb3(ll,jj,i))
+ gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
+ gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
+ gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
+ & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
+ & coeffmees0mij*gacontm_hb3(ll,kk,k))
+ gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
+ gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
+c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
+ enddo
+c write (iout,*)
+cgrad do m=i+1,j-1
+cgrad do ll=1,3
+cgrad gradcorr(ll,m)=gradcorr(ll,m)+
+cgrad & ees*ekl*gacont_hbr(ll,jj,i)-
+cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
+cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
+cgrad enddo
+cgrad enddo
+cgrad do m=k+1,l-1
+cgrad do ll=1,3
+cgrad gradcorr(ll,m)=gradcorr(ll,m)+
+cgrad & ees*eij*gacont_hbr(ll,kk,k)-
+cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
+cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k))
+cgrad enddo
+cgrad enddo
+c write (iout,*) "ehbcorr",ekont*ees
+C print *,ekont,ees,i,k
+ ehbcorr=ekont*ees
+C now gradient over shielding
+C return
+ if (shield_mode.gt.0) then
+ j=ees0plist(jj,i)
+ l=ees0plist(kk,k)
+C print *,i,j,fac_shield(i),fac_shield(j),
+C &fac_shield(k),fac_shield(l)
+ if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
+ & (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
+ do ilist=1,ishield_list(i)
+ iresshield=shield_list(ilist,i)
+ do m=1,3
+ rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
+C & *2.0
+ gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
+ gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
+ &+rlocshield
+ enddo
+ enddo
+ do ilist=1,ishield_list(j)
+ iresshield=shield_list(ilist,j)
+ do m=1,3
+ rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
+C & *2.0
+ gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
+ gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
+ & +rlocshield
+ enddo
+ enddo
+
+ do ilist=1,ishield_list(k)
+ iresshield=shield_list(ilist,k)
+ do m=1,3
+ rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
+C & *2.0
+ gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
+ gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
+ & +rlocshield
+ enddo
+ enddo
+ do ilist=1,ishield_list(l)
+ iresshield=shield_list(ilist,l)
+ do m=1,3
+ rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
+C & *2.0
+ gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
+ gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
+ & +rlocshield
+ enddo
+ enddo
+C print *,gshieldx(m,iresshield)
+ do m=1,3
+ gshieldc_ec(m,i)=gshieldc_ec(m,i)+
+ & grad_shield(m,i)*ehbcorr/fac_shield(i)
+ gshieldc_ec(m,j)=gshieldc_ec(m,j)+
+ & grad_shield(m,j)*ehbcorr/fac_shield(j)
+ gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
+ & grad_shield(m,i)*ehbcorr/fac_shield(i)
+ gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
+ & grad_shield(m,j)*ehbcorr/fac_shield(j)
+
+ gshieldc_ec(m,k)=gshieldc_ec(m,k)+
+ & grad_shield(m,k)*ehbcorr/fac_shield(k)
+ gshieldc_ec(m,l)=gshieldc_ec(m,l)+
+ & grad_shield(m,l)*ehbcorr/fac_shield(l)
+ gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
+ & grad_shield(m,k)*ehbcorr/fac_shield(k)
+ gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
+ & grad_shield(m,l)*ehbcorr/fac_shield(l)
+
+ enddo
+ endif
+ endif
+ return
+ end
+#ifdef MOMENT
+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 = itype2loc(itype(j+1))
+ else
+ itj1=nloctyp
+ endif
+ do iii=1,2
+ dipi(iii,1)=Ub2(iii,i)
+ dipderi(iii)=Ub2der(iii,i)
+ dipi(iii,2)=b1(iii,i+1)
+ dipj(iii,1)=Ub2(iii,j)
+ dipderj(iii)=Ub2der(iii,j)
+ dipj(iii,2)=b1(iii,j+1)
+ enddo
+ kkk=0
+ do iii=1,2
+ call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
+ do jjj=1,2
+ kkk=kkk+1
+ dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
+ enddo
+ enddo
+ do kkk=1,5
+ do lll=1,3
+ mmm=0
+ do iii=1,2
+ call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
+ & auxvec(1))
+ do jjj=1,2
+ mmm=mmm+1
+ dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
+ enddo
+ enddo
+ enddo
+ enddo
+ call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
+ call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
+ do iii=1,2
+ dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
+ enddo
+ call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
+ do iii=1,2
+ dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
+ enddo
+ return
+ end
+#endif
+C---------------------------------------------------------------------------
+ subroutine calc_eello(i,j,k,l,jj,kk)
+C
+C This subroutine computes matrices and vectors needed to calculate
+C the fourth-, fifth-, and sixth-order local-electrostatic terms.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include '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
+cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
+cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
+ do iii=1,2
+ do jjj=1,2
+ aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
+ aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
+ enddo
+ enddo
+ call transpose2(aa1(1,1),aa1t(1,1))
+ call transpose2(aa2(1,1),aa2t(1,1))
+ do kkk=1,5
+ do lll=1,3
+ call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
+ & aa1tder(1,1,lll,kkk))
+ call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
+ & aa2tder(1,1,lll,kkk))
+ enddo
+ enddo
+ if (l.eq.j+1) then
+C parallel orientation of the two CA-CA-CA frames.
+ if (i.gt.1) then
+ iti=itype2loc(itype(i))
+ else
+ iti=nloctyp
+ endif
+ itk1=itype2loc(itype(k+1))
+ itj=itype2loc(itype(j))
+ if (l.lt.nres-1) then
+ itl1=itype2loc(itype(l+1))
+ else
+ itl1=nloctyp
+ 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,i),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,i),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,k+1),AEAb1(1,2,1))
+ call matvec2(AEAderg(1,1,1),b1(1,k+1),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,j),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,j),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,l+1),AEAb1(1,2,2))
+ call matvec2(AEAderg(1,1,2),b1(1,l+1),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,i),
+ & 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,k+1),
+ & 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,j),
+ & 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,l+1),
+ & 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=itype2loc(itype(i))
+ else
+ iti=nloctyp
+ endif
+ itk1=itype2loc(itype(k+1))
+ itl=itype2loc(itype(l))
+ itj=itype2loc(itype(j))
+ if (j.lt.nres-1) then
+ itj1=itype2loc(itype(j+1))
+ else
+ itj1=nloctyp
+ 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,i),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,i),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,k+1),AEAb1(1,2,1))
+ call matvec2(AEAderg(1,1,1),b1(1,k+1),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,j+1),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,l),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,j+1),AEAb1(1,2,2))
+ call matvec2(AEAderg(1,1,2),b1(1,j+1),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,i),
+ & 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,k+1),
+ & 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,l),
+ & 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,j+1),
+ & 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
+cgrad ggg1(ll)=eel4*g_contij(ll,1)
+cgrad ggg2(ll)=eel4*g_contij(ll,2)
+ glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
+ glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
+cgrad ghalf=0.5d0*ggg1(ll)
+ gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
+ gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
+ gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
+ gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
+ gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
+ gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
+cgrad ghalf=0.5d0*ggg2(ll)
+ gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
+ gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
+ gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
+ gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
+ gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
+ gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
+ enddo
+cgrad do m=i+1,j-1
+cgrad do ll=1,3
+cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
+cgrad enddo
+cgrad enddo
+cgrad do m=k+1,l-1
+cgrad do ll=1,3
+cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
+cgrad enddo
+cgrad enddo
+cgrad do m=i+2,j2
+cgrad do ll=1,3
+cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
+cgrad enddo
+cgrad enddo
+cgrad do m=k+2,l2
+cgrad do ll=1,3
+cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
+cgrad enddo
+cgrad enddo
+cd do iii=1,nres-3
+cd write (2,*) iii,gcorr_loc(iii)
+cd enddo
+ endif ! calc_grad
+ 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=itype2loc(itype(k))
+ itl=itype2loc(itype(l))
+ itj=itype2loc(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
+ endif ! calc_grad
+c goto 1112
+c1111 continue
+C Contribution from graph II
+ call transpose2(EE(1,1,k),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,k))
+ & -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,k))
+ & -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,k))
+ & -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,k))
+ & -0.5d0*scalar2(vv(1),Ctobr(1,k))
+ enddo
+ enddo
+ enddo
+ endif ! calc_grad
+cd goto 1112
+cd1111 continue
+ if (l.eq.j+1) then
+cd goto 1110
+C Parallel orientation
+C Contribution from graph III
+ call transpose2(EUg(1,1,l),auxmat(1,1))
+ call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
+ vv(1)=pizda(1,1)-pizda(2,2)
+ vv(2)=pizda(1,2)+pizda(2,1)
+ eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
+ & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
+ 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
+C Contribution from graph IV
+cd1110 continue
+ call transpose2(EE(1,1,l),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,l))
+ & -0.5d0*scalar2(vv(1),Ctobr(1,l))
+C Explicit gradient in virtual-dihedral angles.
+ g_corr5_loc(l-1)=g_corr5_loc(l-1)
+ & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
+ call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
+ vv(1)=pizda(1,1)+pizda(2,2)
+ vv(2)=pizda(2,1)-pizda(1,2)
+ g_corr5_loc(k-1)=g_corr5_loc(k-1)
+ & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
+ & -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,l))
+ & -0.5d0*scalar2(vv(1),Ctobr(1,l))
+ enddo
+ enddo
+ enddo
+ endif ! calc_grad
+ 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
+ endif ! calc_grad
+cd goto 1112
+C Contribution from graph IV
+1110 continue
+ call transpose2(EE(1,1,j),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,j))
+ & -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,j))
+ & -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,j))
+ & -0.5d0*scalar2(vv(1),Ctobr(1,j))
+ enddo
+ enddo
+ enddo
+ endif ! calc_grad
+ 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
+C 2/11/08 AL Gradients over DC's connecting interacting sites will be
+C summed up outside the subrouine as for the other subroutines
+C handling long-range interactions. The old code is commented out
+C with "cgrad" to keep track of changes.
+ do ll=1,3
+cgrad ggg1(ll)=eel5*g_contij(ll,1)
+cgrad ggg2(ll)=eel5*g_contij(ll,2)
+ gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
+ gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
+c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
+c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
+c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
+c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont
+c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
+c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
+c & gradcorr5ij,
+c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
+cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
+cgrad ghalf=0.5d0*ggg1(ll)
+cd ghalf=0.0d0
+ gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
+ gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
+ gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
+ gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
+ gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
+ gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
+cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
+cgrad ghalf=0.5d0*ggg2(ll)
+cd ghalf=0.0d0
+ gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
+ gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
+ gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
+ gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
+ gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
+ gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
+ enddo
+ endif ! calc_grad
+cd goto 1112
+cgrad do m=i+1,j-1
+cgrad do ll=1,3
+cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
+cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
+cgrad enddo
+cgrad enddo
+cgrad do m=k+1,l-1
+cgrad do ll=1,3
+cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
+cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
+cgrad enddo
+cgrad enddo
+c1112 continue
+cgrad do m=i+2,j2
+cgrad do ll=1,3
+cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
+cgrad enddo
+cgrad enddo
+cgrad do m=k+2,l2
+cgrad do ll=1,3
+cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
+cgrad enddo
+cgrad enddo
+cd do iii=1,nres-3
+cd write (2,*) iii,g_corr5_loc(iii)
+cd enddo
+ eello5=ekont*eel5
+cd write (2,*) 'ekont',ekont
+cd write (iout,*) 'eello5',ekont*eel5
+ return
+ end
+c--------------------------------------------------------------------------
+ double precision function eello6(i,j,k,l,jj,kk)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include '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
+cgrad ggg1(ll)=eel6*g_contij(ll,1)
+cgrad ggg2(ll)=eel6*g_contij(ll,2)
+cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
+cgrad ghalf=0.5d0*ggg1(ll)
+cd ghalf=0.0d0
+ gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
+ gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
+ gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
+ gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
+ gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
+ gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
+ gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
+ gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
+cgrad ghalf=0.5d0*ggg2(ll)
+cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
+cd ghalf=0.0d0
+ gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
+ gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
+ gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
+ gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
+ gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
+ gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
+ enddo
+ endif ! calc_grad
+cd goto 1112
+cgrad do m=i+1,j-1
+cgrad do ll=1,3
+cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
+cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
+cgrad enddo
+cgrad enddo
+cgrad do m=k+1,l-1
+cgrad do ll=1,3
+cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
+cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
+cgrad enddo
+cgrad enddo
+cgrad1112 continue
+cgrad do m=i+2,j2
+cgrad do ll=1,3
+cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
+cgrad enddo
+cgrad enddo
+cgrad do m=k+2,l2
+cgrad do ll=1,3
+cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
+cgrad enddo
+cgrad enddo
+cd do iii=1,nres-3
+cd write (2,*) iii,g_corr6_loc(iii)
+cd enddo
+ eello6=ekont*eel6
+cd write (2,*) 'ekont',ekont
+cd write (iout,*) 'eello6',ekont*eel6
+ return
+ end
+c--------------------------------------------------------------------------
+ double precision function eello6_graph1(i,j,k,l,imat,swap)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include '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=itype2loc(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,k)-AEAb1(2,2,imat)*b1(2,k)
+ vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
+ 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 (calc_grad) then
+ 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,k)-AEAb1derg(2,2,imat)*b1(2,k)
+ vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
+ 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,k)
+ & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
+ vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
+ & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
+ 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
+ endif ! calc_grad
+ 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(2),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
+C Derivatives in gamma(i-1)
+ if (calc_grad) then
+ 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
+ endif ! calc_grad
+ 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=itype2loc(itype(j+1))
+ else
+ itj1=nloctyp
+ endif
+ itk=itype2loc(itype(k))
+ itk1=itype2loc(itype(k+1))
+ if (l.lt.nres-1) then
+ itl1=itype2loc(itype(l+1))
+ else
+ itl1=nloctyp
+ endif
+#ifdef MOMENT
+ s1=dip(4,jj,i)*dip(4,kk,k)
+#endif
+ call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
+ s2=0.5d0*scalar2(b1(1,k),auxvec(1))
+ call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
+ s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
+ call transpose2(EE(1,1,k),auxmat(1,1))
+ call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
+ vv(1)=pizda(1,1)+pizda(2,2)
+ vv(2)=pizda(2,1)-pizda(1,2)
+ s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
+cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
+cd & "sum",-(s2+s3+s4)
+#ifdef MOMENT
+ eello6_graph3=-(s1+s2+s3+s4)
+#else
+ eello6_graph3=-(s2+s3+s4)
+#endif
+c eello6_graph3=-s4
+C Derivatives in gamma(k-1)
+ if (calc_grad) then
+ call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
+ s3=0.5d0*scalar2(b1(1,j+1),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,k+1),auxvec(1))
+ s2=0.5d0*scalar2(b1(1,k),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,k+1),
+ & auxvec(1))
+ s2=0.5d0*scalar2(b1(1,k),auxvec(1))
+ call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
+ & auxvec(1))
+ s3=0.5d0*scalar2(b1(1,j+1),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
+ endif ! calc_grad
+ 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=itype2loc(itype(i))
+ itj=itype2loc(itype(j))
+ if (j.lt.nres-1) then
+ itj1=itype2loc(itype(j+1))
+ else
+ itj1=nloctyp
+ endif
+ itk=itype2loc(itype(k))
+ if (k.lt.nres-1) then
+ itk1=itype2loc(itype(k+1))
+ else
+ itk1=nloctyp
+ endif
+ itl=itype2loc(itype(l))
+ if (l.lt.nres-1) then
+ itl1=itype2loc(itype(l+1))
+ else
+ itl1=nloctyp
+ 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,j+1),auxvec1(1))
+ s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
+ else
+ call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
+ s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
+ endif
+ call transpose2(EUg(1,1,k),auxmat(1,1))
+ call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
+ vv(1)=pizda(1,1)-pizda(2,2)
+ vv(2)=pizda(2,1)+pizda(1,2)
+ s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
+cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
+#ifdef MOMENT
+ eello6_graph4=-(s1+s2+s3+s4)
+#else
+ eello6_graph4=-(s2+s3+s4)
+#endif
+C Derivatives in gamma(i-1)
+ if (calc_grad) then
+ 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,j+1),auxvec1(1))
+ s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
+ else
+ call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
+ s3=-0.5d0*scalar2(b1(1,l),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,j+1),auxvec1(1))
+ s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
+ else
+ call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
+ s3=-0.5d0*scalar2(b1(1,l),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,j+1),auxvec(1))
+ s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
+ else
+ call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
+ & b1(1,l+1),auxvec(1))
+ s3=-0.5d0*scalar2(b1(1,l),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
+ endif ! calc_grad
+ 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.
+ s1=0.0d0
+ s8=0.0d0
+ s13=0.0d0
+c
+ eello_turn6=0.0d0
+ j=i+4
+ k=i+1
+ l=i+3
+ iti=itype2loc(itype(i))
+ itk=itype2loc(itype(k))
+ itk1=itype2loc(itype(k+1))
+ itl=itype2loc(itype(l))
+ itj=itype2loc(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,l))
+ s1 = (auxmat(1,1)+auxmat(2,2))*ss1
+#endif
+ call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
+ call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
+ s2 = scalar2(b1(1,k),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,k+1),vtemp2(1))
+ s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),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,k),vtemp4(1))
+ s13 = (gtemp(1,1)+gtemp(2,2))*ss13
+#endif
+c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
+c s1=0.0d0
+c s2=0.0d0
+c s8=0.0d0
+c s12=0.0d0
+c s13=0.0d0
+ eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
+C Derivatives in gamma(i+2)
+ if (calc_grad) then
+ s1d =0.0d0
+ s8d =0.0d0
+#ifdef MOMENT
+ call transpose2(AEA(1,1,1),auxmatd(1,1))
+ call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
+ s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
+ call transpose2(AEAderg(1,1,2),atempd(1,1))
+ call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
+ s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),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,l))
+ s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
+#endif
+ call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
+ call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
+ s2d = scalar2(b1(1,k),vtemp1d(1))
+#ifdef MOMENT
+ call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
+ s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),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,l),vtemp1d(1))
+ call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
+ s2d = scalar2(b1(1,k),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,l),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,k),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,l),vtemp1(1))
+ call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
+ & vtemp1d(1))
+ s2d = scalar2(b1(1,k),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,l),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,k),vtemp4d(1))
+ s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
+ derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
+ enddo
+ enddo
+#endif
+cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
+cd & 16*eel_turn6_num
+cd goto 1112
+ if (j.lt.nres-1) then
+ j1=j+1
+ j2=j-1
+ else
+ j1=j-1
+ j2=j-2
+ endif
+ if (l.lt.nres-1) then
+ l1=l+1
+ l2=l-1
+ else
+ l1=l-1
+ l2=l-2
+ endif
+ do ll=1,3
+cgrad ggg1(ll)=eel_turn6*g_contij(ll,1)
+cgrad ggg2(ll)=eel_turn6*g_contij(ll,2)
+cgrad ghalf=0.5d0*ggg1(ll)
+cd ghalf=0.0d0
+ gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
+ gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
+ gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
+ & +ekont*derx_turn(ll,2,1)
+ gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
+ gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
+ & +ekont*derx_turn(ll,4,1)
+ gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
+ gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
+ gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
+cgrad ghalf=0.5d0*ggg2(ll)
+cd ghalf=0.0d0
+ gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
+ & +ekont*derx_turn(ll,2,2)
+ gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
+ gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
+ & +ekont*derx_turn(ll,4,2)
+ gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
+ gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
+ gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
+ enddo
+cd goto 1112
+cgrad do m=i+1,j-1
+cgrad do ll=1,3
+cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
+cgrad enddo
+cgrad enddo
+cgrad do m=k+1,l-1
+cgrad do ll=1,3
+cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
+cgrad enddo
+cgrad enddo
+cgrad1112 continue
+cgrad do m=i+2,j2
+cgrad do ll=1,3
+cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
+cgrad enddo
+cgrad enddo
+cgrad do m=k+2,l2
+cgrad do ll=1,3
+cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
+cgrad enddo
+cgrad enddo
+cd do iii=1,nres-3
+cd write (2,*) iii,g_corr6_loc(iii)
+cd enddo
+ endif ! calc_grad
+ eello_turn6=ekont*eel_turn6
+cd write (2,*) 'ekont',ekont
+cd write (2,*) 'eel_turn6',ekont*eel_turn6
+ return
+ end
+
+crc-------------------------------------------------
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ subroutine Eliptransfer(eliptran)
+ 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.IOUNITS'
+ include 'COMMON.CALC'
+ include 'COMMON.CONTROL'
+ include 'COMMON.SPLITELE'
+ include 'COMMON.SBRIDGE'
+C this is done by Adasko
+C print *,"wchodze"
+C structure of box:
+C water
+C--bordliptop-- buffore starts
+C--bufliptop--- here true lipid starts
+C lipid
+C--buflipbot--- lipid ends buffore starts
+C--bordlipbot--buffore ends
+ eliptran=0.0
+ do i=1,nres
+C do i=1,1
+ if (itype(i).eq.ntyp1) cycle
+
+ positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
+ if (positi.le.0) positi=positi+boxzsize
+C print *,i
+C first for peptide groups
+c for each residue check if it is in lipid or lipid water border area
+ if ((positi.gt.bordlipbot)
+ &.and.(positi.lt.bordliptop)) then
+C the energy transfer exist
+ if (positi.lt.buflipbot) then
+C what fraction I am in
+ fracinbuf=1.0d0-
+ & ((positi-bordlipbot)/lipbufthick)
+C lipbufthick is thickenes of lipid buffore
+ sslip=sscalelip(fracinbuf)
+ ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
+ eliptran=eliptran+sslip*pepliptran
+ gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
+ gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
+C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
+ elseif (positi.gt.bufliptop) then
+ fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
+ sslip=sscalelip(fracinbuf)
+ ssgradlip=sscagradlip(fracinbuf)/lipbufthick
+ eliptran=eliptran+sslip*pepliptran
+ gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
+ gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
+C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
+C print *, "doing sscalefor top part"
+C print *,i,sslip,fracinbuf,ssgradlip
+ else
+ eliptran=eliptran+pepliptran
+C print *,"I am in true lipid"
+ endif
+C else
+C eliptran=elpitran+0.0 ! I am in water
+ endif
+ enddo
+C print *, "nic nie bylo w lipidzie?"
+C now multiply all by the peptide group transfer factor
+C eliptran=eliptran*pepliptran
+C now the same for side chains
+CV do i=1,1
+ do i=1,nres
+ if (itype(i).eq.ntyp1) cycle
+ positi=(mod(c(3,i+nres),boxzsize))
+ if (positi.le.0) positi=positi+boxzsize
+C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
+c for each residue check if it is in lipid or lipid water border area
+C respos=mod(c(3,i+nres),boxzsize)
+C print *,positi,bordlipbot,buflipbot
+ if ((positi.gt.bordlipbot)
+ & .and.(positi.lt.bordliptop)) then
+C the energy transfer exist
+ if (positi.lt.buflipbot) then
+ fracinbuf=1.0d0-
+ & ((positi-bordlipbot)/lipbufthick)
+C lipbufthick is thickenes of lipid buffore
+ sslip=sscalelip(fracinbuf)
+ ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
+ eliptran=eliptran+sslip*liptranene(itype(i))
+ gliptranx(3,i)=gliptranx(3,i)
+ &+ssgradlip*liptranene(itype(i))
+ gliptranc(3,i-1)= gliptranc(3,i-1)
+ &+ssgradlip*liptranene(itype(i))
+C print *,"doing sccale for lower part"
+ elseif (positi.gt.bufliptop) then
+ fracinbuf=1.0d0-
+ &((bordliptop-positi)/lipbufthick)
+ sslip=sscalelip(fracinbuf)
+ ssgradlip=sscagradlip(fracinbuf)/lipbufthick
+ eliptran=eliptran+sslip*liptranene(itype(i))
+ gliptranx(3,i)=gliptranx(3,i)
+ &+ssgradlip*liptranene(itype(i))
+ gliptranc(3,i-1)= gliptranc(3,i-1)
+ &+ssgradlip*liptranene(itype(i))
+C print *, "doing sscalefor top part",sslip,fracinbuf
+ else
+ eliptran=eliptran+liptranene(itype(i))
+C print *,"I am in true lipid"
+ endif
+ endif ! if in lipid or buffor
+C else
+C eliptran=elpitran+0.0 ! I am in water
+ enddo
+ return
+ end
+
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+ 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
+C-----------------------------------------------------------------------
+ double precision function sscale(r)
+ double precision r,gamm
+ include "COMMON.SPLITELE"
+ if(r.lt.r_cut-rlamb) then
+ sscale=1.0d0
+ else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
+ gamm=(r-(r_cut-rlamb))/rlamb
+ sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
+ else
+ sscale=0d0
+ endif
+ return
+ end
+C-----------------------------------------------------------------------
+C-----------------------------------------------------------------------
+ double precision function sscagrad(r)
+ double precision r,gamm
+ include "COMMON.SPLITELE"
+ if(r.lt.r_cut-rlamb) then
+ sscagrad=0.0d0
+ else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
+ gamm=(r-(r_cut-rlamb))/rlamb
+ sscagrad=gamm*(6*gamm-6.0d0)/rlamb
+ else
+ sscagrad=0.0d0
+ endif
+ return
+ end
+C-----------------------------------------------------------------------
+C-----------------------------------------------------------------------
+ double precision function sscalelip(r)
+ double precision r,gamm
+ include "COMMON.SPLITELE"
+C if(r.lt.r_cut-rlamb) then
+C sscale=1.0d0
+C else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
+C gamm=(r-(r_cut-rlamb))/rlamb
+ sscalelip=1.0d0+r*r*(2*r-3.0d0)
+C else
+C sscale=0d0
+C endif
+ return
+ end
+C-----------------------------------------------------------------------
+ double precision function sscagradlip(r)
+ double precision r,gamm
+ include "COMMON.SPLITELE"
+C if(r.lt.r_cut-rlamb) then
+C sscagrad=0.0d0
+C else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
+C gamm=(r-(r_cut-rlamb))/rlamb
+ sscagradlip=r*(6*r-6.0d0)
+C else
+C sscagrad=0.0d0
+C endif
+ return
+ end
+
+C-----------------------------------------------------------------------
+ subroutine set_shield_fac
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'DIMENSIONS.ZSCOPT'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.SHIELD'
+ include 'COMMON.INTERACT'
+C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
+ double precision div77_81/0.974996043d0/,
+ &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
+
+C the vector between center of side_chain and peptide group
+ double precision pep_side(3),long,side_calf(3),
+ &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
+ &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
+C the line belowe needs to be changed for FGPROC>1
+ do i=1,nres-1
+ if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
+ ishield_list(i)=0
+Cif there two consequtive dummy atoms there is no peptide group between them
+C the line below has to be changed for FGPROC>1
+ VolumeTotal=0.0
+ do k=1,nres
+ if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
+ dist_pep_side=0.0
+ dist_side_calf=0.0
+ do j=1,3
+C first lets set vector conecting the ithe side-chain with kth side-chain
+ pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
+C pep_side(j)=2.0d0
+C and vector conecting the side-chain with its proper calfa
+ side_calf(j)=c(j,k+nres)-c(j,k)
+C side_calf(j)=2.0d0
+ pept_group(j)=c(j,i)-c(j,i+1)
+C lets have their lenght
+ dist_pep_side=pep_side(j)**2+dist_pep_side
+ dist_side_calf=dist_side_calf+side_calf(j)**2
+ dist_pept_group=dist_pept_group+pept_group(j)**2
+ enddo
+ dist_pep_side=dsqrt(dist_pep_side)
+ dist_pept_group=dsqrt(dist_pept_group)
+ dist_side_calf=dsqrt(dist_side_calf)
+ do j=1,3
+ pep_side_norm(j)=pep_side(j)/dist_pep_side
+ side_calf_norm(j)=dist_side_calf
+ enddo
+C now sscale fraction
+ sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
+C print *,buff_shield,"buff"
+C now sscale
+ if (sh_frac_dist.le.0.0) cycle
+C If we reach here it means that this side chain reaches the shielding sphere
+C Lets add him to the list for gradient
+ ishield_list(i)=ishield_list(i)+1
+C ishield_list is a list of non 0 side-chain that contribute to factor gradient
+C this list is essential otherwise problem would be O3
+ shield_list(ishield_list(i),i)=k
+C Lets have the sscale value
+ if (sh_frac_dist.gt.1.0) then
+ scale_fac_dist=1.0d0
+ do j=1,3
+ sh_frac_dist_grad(j)=0.0d0
+ enddo
+ else
+ scale_fac_dist=-sh_frac_dist*sh_frac_dist
+ & *(2.0*sh_frac_dist-3.0d0)
+ fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
+ & /dist_pep_side/buff_shield*0.5
+C remember for the final gradient multiply sh_frac_dist_grad(j)
+C for side_chain by factor -2 !
+ do j=1,3
+ sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
+C print *,"jestem",scale_fac_dist,fac_help_scale,
+C & sh_frac_dist_grad(j)
+ enddo
+ endif
+C if ((i.eq.3).and.(k.eq.2)) then
+C print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
+C & ,"TU"
+C endif
+
+C this is what is now we have the distance scaling now volume...
+ short=short_r_sidechain(itype(k))
+ long=long_r_sidechain(itype(k))
+ costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
+C now costhet_grad
+C costhet=0.0d0
+ costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
+C costhet_fac=0.0d0
+ do j=1,3
+ costhet_grad(j)=costhet_fac*pep_side(j)
+ enddo
+C remember for the final gradient multiply costhet_grad(j)
+C for side_chain by factor -2 !
+C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
+C pep_side0pept_group is vector multiplication
+ pep_side0pept_group=0.0
+ do j=1,3
+ pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
+ enddo
+ cosalfa=(pep_side0pept_group/
+ & (dist_pep_side*dist_side_calf))
+ fac_alfa_sin=1.0-cosalfa**2
+ fac_alfa_sin=dsqrt(fac_alfa_sin)
+ rkprim=fac_alfa_sin*(long-short)+short
+C now costhet_grad
+ cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
+ cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
+
+ do j=1,3
+ cosphi_grad_long(j)=cosphi_fac*pep_side(j)
+ &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
+ &*(long-short)/fac_alfa_sin*cosalfa/
+ &((dist_pep_side*dist_side_calf))*
+ &((side_calf(j))-cosalfa*
+ &((pep_side(j)/dist_pep_side)*dist_side_calf))
+
+ cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
+ &*(long-short)/fac_alfa_sin*cosalfa
+ &/((dist_pep_side*dist_side_calf))*
+ &(pep_side(j)-
+ &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
+ enddo
+
+ VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
+ & /VSolvSphere_div
+ & *wshield
+C now the gradient...
+C grad_shield is gradient of Calfa for peptide groups
+C write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
+C & costhet,cosphi
+C write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
+C & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
+ do j=1,3
+ grad_shield(j,i)=grad_shield(j,i)
+C gradient po skalowaniu
+ & +(sh_frac_dist_grad(j)
+C gradient po costhet
+ &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
+ &-scale_fac_dist*(cosphi_grad_long(j))
+ &/(1.0-cosphi) )*div77_81
+ &*VofOverlap
+C grad_shield_side is Cbeta sidechain gradient
+ grad_shield_side(j,ishield_list(i),i)=
+ & (sh_frac_dist_grad(j)*(-2.0d0)
+ & +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
+ & +scale_fac_dist*(cosphi_grad_long(j))
+ & *2.0d0/(1.0-cosphi))
+ & *div77_81*VofOverlap
+
+ grad_shield_loc(j,ishield_list(i),i)=
+ & scale_fac_dist*cosphi_grad_loc(j)
+ & *2.0d0/(1.0-cosphi)
+ & *div77_81*VofOverlap
+ enddo
+ VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
+ enddo
+ fac_shield(i)=VolumeTotal*div77_81+div4_81
+C write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
+ enddo
+ return
+ end
+C--------------------------------------------------------------------------
+C first for shielding is setting of function of side-chains
+ subroutine set_shield_fac2
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'DIMENSIONS.ZSCOPT'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.SHIELD'
+ include 'COMMON.INTERACT'
+C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
+ double precision div77_81/0.974996043d0/,
+ &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
+
+C the vector between center of side_chain and peptide group
+ double precision pep_side(3),long,side_calf(3),
+ &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
+ &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
+C the line belowe needs to be changed for FGPROC>1
+ do i=1,nres-1
+ if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
+ ishield_list(i)=0
+Cif there two consequtive dummy atoms there is no peptide group between them
+C the line below has to be changed for FGPROC>1
+ VolumeTotal=0.0
+ do k=1,nres
+ if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
+ dist_pep_side=0.0
+ dist_side_calf=0.0
+ do j=1,3
+C first lets set vector conecting the ithe side-chain with kth side-chain
+ pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
+C pep_side(j)=2.0d0
+C and vector conecting the side-chain with its proper calfa
+ side_calf(j)=c(j,k+nres)-c(j,k)
+C side_calf(j)=2.0d0
+ pept_group(j)=c(j,i)-c(j,i+1)
+C lets have their lenght
+ dist_pep_side=pep_side(j)**2+dist_pep_side
+ dist_side_calf=dist_side_calf+side_calf(j)**2
+ dist_pept_group=dist_pept_group+pept_group(j)**2
+ enddo
+ dist_pep_side=dsqrt(dist_pep_side)
+ dist_pept_group=dsqrt(dist_pept_group)
+ dist_side_calf=dsqrt(dist_side_calf)
+ do j=1,3
+ pep_side_norm(j)=pep_side(j)/dist_pep_side
+ side_calf_norm(j)=dist_side_calf
+ enddo
+C now sscale fraction
+ sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
+C print *,buff_shield,"buff"
+C now sscale
+ if (sh_frac_dist.le.0.0) cycle
+C If we reach here it means that this side chain reaches the shielding sphere
+C Lets add him to the list for gradient
+ ishield_list(i)=ishield_list(i)+1
+C ishield_list is a list of non 0 side-chain that contribute to factor gradient
+C this list is essential otherwise problem would be O3
+ shield_list(ishield_list(i),i)=k
+C Lets have the sscale value
+ if (sh_frac_dist.gt.1.0) then
+ scale_fac_dist=1.0d0
+ do j=1,3
+ sh_frac_dist_grad(j)=0.0d0
+ enddo
+ else
+ scale_fac_dist=-sh_frac_dist*sh_frac_dist
+ & *(2.0d0*sh_frac_dist-3.0d0)
+ fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
+ & /dist_pep_side/buff_shield*0.5d0
+C remember for the final gradient multiply sh_frac_dist_grad(j)
+C for side_chain by factor -2 !
+ do j=1,3
+ sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
+C sh_frac_dist_grad(j)=0.0d0
+C scale_fac_dist=1.0d0
+C print *,"jestem",scale_fac_dist,fac_help_scale,
+C & sh_frac_dist_grad(j)
+ enddo
+ endif
+C this is what is now we have the distance scaling now volume...
+ short=short_r_sidechain(itype(k))
+ long=long_r_sidechain(itype(k))
+ costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
+ sinthet=short/dist_pep_side*costhet
+C now costhet_grad
+C costhet=0.6d0
+C sinthet=0.8
+ costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
+C sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
+C & -short/dist_pep_side**2/costhet)
+C costhet_fac=0.0d0
+ do j=1,3
+ costhet_grad(j)=costhet_fac*pep_side(j)
+ enddo
+C remember for the final gradient multiply costhet_grad(j)
+C for side_chain by factor -2 !
+C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
+C pep_side0pept_group is vector multiplication
+ pep_side0pept_group=0.0d0
+ do j=1,3
+ pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
+ enddo
+ cosalfa=(pep_side0pept_group/
+ & (dist_pep_side*dist_side_calf))
+ fac_alfa_sin=1.0d0-cosalfa**2
+ fac_alfa_sin=dsqrt(fac_alfa_sin)
+ rkprim=fac_alfa_sin*(long-short)+short
+C rkprim=short
+
+C now costhet_grad
+ cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
+C cosphi=0.6
+ cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
+ sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
+ & dist_pep_side**2)
+C sinphi=0.8
+ do j=1,3
+ cosphi_grad_long(j)=cosphi_fac*pep_side(j)
+ &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
+ &*(long-short)/fac_alfa_sin*cosalfa/
+ &((dist_pep_side*dist_side_calf))*
+ &((side_calf(j))-cosalfa*
+ &((pep_side(j)/dist_pep_side)*dist_side_calf))
+C cosphi_grad_long(j)=0.0d0
+ cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
+ &*(long-short)/fac_alfa_sin*cosalfa
+ &/((dist_pep_side*dist_side_calf))*
+ &(pep_side(j)-
+ &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
+C cosphi_grad_loc(j)=0.0d0
+ enddo
+C print *,sinphi,sinthet
+ VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
+ & /VSolvSphere_div
+C & *wshield
+C now the gradient...
+ do j=1,3
+ grad_shield(j,i)=grad_shield(j,i)
+C gradient po skalowaniu
+ & +(sh_frac_dist_grad(j)*VofOverlap
+C gradient po costhet
+ & +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
+ &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
+ & sinphi/sinthet*costhet*costhet_grad(j)
+ & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
+ & )*wshield
+C grad_shield_side is Cbeta sidechain gradient
+ grad_shield_side(j,ishield_list(i),i)=
+ & (sh_frac_dist_grad(j)*(-2.0d0)
+ & *VofOverlap
+ & -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
+ &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
+ & sinphi/sinthet*costhet*costhet_grad(j)
+ & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
+ & )*wshield
+
+ grad_shield_loc(j,ishield_list(i),i)=
+ & scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
+ &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
+ & sinthet/sinphi*cosphi*cosphi_grad_loc(j)
+ & ))
+ & *wshield
+ enddo
+ VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
+ enddo
+ fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
+c write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
+c & " wshield",wshield
+c write(2,*) "TU",rpp(1,1),short,long,buff_shield
+ enddo
+ return
+ end
+C--------------------------------------------------------------------------
+ double precision function tschebyshev(m,n,x,y)
+ implicit none
+ include "DIMENSIONS"
+ integer i,m,n
+ double precision x(n),y,yy(0:maxvar),aux
+c Tschebyshev polynomial. Note that the first term is omitted
+c m=0: the constant term is included
+c m=1: the constant term is not included
+ yy(0)=1.0d0
+ yy(1)=y
+ do i=2,n
+ yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
+ enddo
+ aux=0.0d0
+ do i=m,n
+ aux=aux+x(i)*yy(i)
+ enddo
+ tschebyshev=aux
+ return
+ end
+C--------------------------------------------------------------------------
+ double precision function gradtschebyshev(m,n,x,y)
+ implicit none
+ include "DIMENSIONS"
+ integer i,m,n
+ double precision x(n+1),y,yy(0:maxvar),aux
+c Tschebyshev polynomial. Note that the first term is omitted
+c m=0: the constant term is included
+c m=1: the constant term is not included
+ yy(0)=1.0d0
+ yy(1)=2.0d0*y
+ do i=2,n
+ yy(i)=2*y*yy(i-1)-yy(i-2)
+ enddo
+ aux=0.0d0
+ do i=m,n
+ aux=aux+x(i+1)*yy(i)*(i+1)
+C print *, x(i+1),yy(i),i
+ enddo
+ gradtschebyshev=aux
+ return
+ end
+c----------------------------------------------------------------------------
+ double precision function sscale2(r,r_cut,r0,rlamb)
+ implicit none
+ double precision r,gamm,r_cut,r0,rlamb,rr
+ rr = dabs(r-r0)
+c write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
+c write (2,*) "rr",rr
+ if(rr.lt.r_cut-rlamb) then
+ sscale2=1.0d0
+ else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
+ gamm=(rr-(r_cut-rlamb))/rlamb
+ sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
+ else
+ sscale2=0d0
+ endif
+ return
+ end
+C-----------------------------------------------------------------------
+ double precision function sscalgrad2(r,r_cut,r0,rlamb)
+ implicit none
+ double precision r,gamm,r_cut,r0,rlamb,rr
+ rr = dabs(r-r0)
+ if(rr.lt.r_cut-rlamb) then
+ sscalgrad2=0.0d0
+ else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
+ gamm=(rr-(r_cut-rlamb))/rlamb
+ if (r.ge.r0) then
+ sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
+ else
+ sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
+ endif
+ else
+ sscalgrad2=0.0d0
+ endif
+ return
+ end
+c----------------------------------------------------------------------------
+ subroutine e_saxs(Esaxs_constr)
+ implicit none
+ include 'DIMENSIONS'
+ include 'DIMENSIONS.ZSCOPT'
+ include 'DIMENSIONS.FREE'
+#ifdef MPI
+ include "mpif.h"
+ include "COMMON.SETUP"
+ integer IERR
+#endif
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.CHAIN'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.VAR'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.DERIV'
+ include 'COMMON.CONTROL'
+ include 'COMMON.NAMES'
+ include 'COMMON.FFIELD'
+ include 'COMMON.LANGEVIN'
+ include 'COMMON.SAXS'
+c
+ double precision Esaxs_constr
+ integer i,iint,j,k,l
+ double precision PgradC(maxSAXS,3,maxres),
+ & PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
+#ifdef MPI
+ double precision PgradC_(maxSAXS,3,maxres),
+ & PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
+#endif
+ double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
+ & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
+ & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
+ & auxX,auxX1,CACAgrad,Cnorm
+ double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
+ double precision dist
+ external dist
+c SAXS restraint penalty function
+#ifdef DEBUG
+ write(iout,*) "------- SAXS penalty function start -------"
+ write (iout,*) "nsaxs",nsaxs
+ write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
+ write (iout,*) "Psaxs"
+ do i=1,nsaxs
+ write (iout,'(i5,e15.5)') i, Psaxs(i)
+ enddo
+#endif
+ Esaxs_constr = 0.0d0
+ do k=1,nsaxs
+ Pcalc(k)=0.0d0
+ do j=1,nres
+ do l=1,3
+ PgradC(k,l,j)=0.0d0
+ PgradX(k,l,j)=0.0d0
+ enddo
+ enddo
+ enddo
+ do i=iatsc_s,iatsc_e
+ if (itype(i).eq.ntyp1) cycle
+ do iint=1,nint_gr(i)
+ do j=istart(i,iint),iend(i,iint)
+ if (itype(j).eq.ntyp1) cycle
+#ifdef ALLSAXS
+ dijCACA=dist(i,j)
+ dijCASC=dist(i,j+nres)
+ dijSCCA=dist(i+nres,j)
+ dijSCSC=dist(i+nres,j+nres)
+ sigma2CACA=2.0d0/(pstok**2)
+ sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
+ sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
+ sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
+ do k=1,nsaxs
+ dk = distsaxs(k)
+ expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
+ if (itype(j).ne.10) then
+ expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
+ else
+ endif
+ expCASC = 0.0d0
+ if (itype(i).ne.10) then
+ expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
+ else
+ expSCCA = 0.0d0
+ endif
+ if (itype(i).ne.10 .and. itype(j).ne.10) then
+ expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
+ else
+ expSCSC = 0.0d0
+ endif
+ Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
+#ifdef DEBUG
+ write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
+#endif
+ CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
+ CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
+ SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
+ SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
+ do l=1,3
+c CA CA
+ aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
+ PgradC(k,l,i) = PgradC(k,l,i)-aux
+ PgradC(k,l,j) = PgradC(k,l,j)+aux
+c CA SC
+ if (itype(j).ne.10) then
+ aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
+ PgradC(k,l,i) = PgradC(k,l,i)-aux
+ PgradC(k,l,j) = PgradC(k,l,j)+aux
+ PgradX(k,l,j) = PgradX(k,l,j)+aux
+ endif
+c SC CA
+ if (itype(i).ne.10) then
+ aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
+ PgradX(k,l,i) = PgradX(k,l,i)-aux
+ PgradC(k,l,i) = PgradC(k,l,i)-aux
+ PgradC(k,l,j) = PgradC(k,l,j)+aux
+ endif
+c SC SC
+ if (itype(i).ne.10 .and. itype(j).ne.10) then
+ aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
+ PgradC(k,l,i) = PgradC(k,l,i)-aux
+ PgradC(k,l,j) = PgradC(k,l,j)+aux
+ PgradX(k,l,i) = PgradX(k,l,i)-aux
+ PgradX(k,l,j) = PgradX(k,l,j)+aux
+ endif
+ enddo ! l
+ enddo ! k
+#else
+ dijCACA=dist(i,j)
+ sigma2CACA=scal_rad**2*0.25d0/
+ & (restok(itype(j))**2+restok(itype(i))**2)
+
+ IF (saxs_cutoff.eq.0) THEN
+ do k=1,nsaxs
+ dk = distsaxs(k)
+ expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
+ Pcalc(k) = Pcalc(k)+expCACA
+ CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
+ do l=1,3
+ aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
+ PgradC(k,l,i) = PgradC(k,l,i)-aux
+ PgradC(k,l,j) = PgradC(k,l,j)+aux
+ enddo ! l
+ enddo ! k
+ ELSE
+ rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
+ do k=1,nsaxs
+ dk = distsaxs(k)
+c write (2,*) "ijk",i,j,k
+ sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
+ if (sss2.eq.0.0d0) cycle
+ ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
+ expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
+ Pcalc(k) = Pcalc(k)+expCACA
+#ifdef DEBUG
+ write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
+#endif
+ CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
+ & ssgrad2*expCACA/sss2
+ do l=1,3
+c CA CA
+ aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
+ PgradC(k,l,i) = PgradC(k,l,i)+aux
+ PgradC(k,l,j) = PgradC(k,l,j)-aux
+ enddo ! l
+ enddo ! k
+ ENDIF
+#endif
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+#ifdef MPI
+ if (nfgtasks.gt.1) then
+ call MPI_Reduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
+ & MPI_SUM,king,FG_COMM,IERR)
+ if (fg_rank.eq.king) then
+ do k=1,nsaxs
+ Pcalc(k) = Pcalc_(k)
+ enddo
+ endif
+ call MPI_Reduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
+ & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
+ if (fg_rank.eq.king) then
+ do i=1,nres
+ do l=1,3
+ do k=1,nsaxs
+ PgradC(k,l,i) = PgradC_(k,l,i)
+ enddo
+ enddo
+ enddo
+ endif
+#ifdef ALLSAXS
+ call MPI_Reduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
+ & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
+ if (fg_rank.eq.king) then
+ do i=1,nres
+ do l=1,3
+ do k=1,nsaxs
+ PgradX(k,l,i) = PgradX_(k,l,i)
+ enddo
+ enddo
+ enddo
+ endif
+#endif
+ endif
+#endif
+#ifdef MPI
+ if (fg_rank.eq.king) then
+#endif
+ Cnorm = 0.0d0
+ do k=1,nsaxs
+ Cnorm = Cnorm + Pcalc(k)
+ enddo
+ Esaxs_constr = dlog(Cnorm)-wsaxs0
+ do k=1,nsaxs
+ if (Pcalc(k).gt.0.0d0)
+ & Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
+#ifdef DEBUG
+ write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
+#endif
+ enddo
+#ifdef DEBUG
+ write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
+#endif
+ do i=nnt,nct
+ do l=1,3
+ auxC=0.0d0
+ auxC1=0.0d0
+ auxX=0.0d0
+ auxX1=0.d0
+ do k=1,nsaxs
+ if (Pcalc(k).gt.0)
+ & auxC = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
+ auxC1 = auxC1+PgradC(k,l,i)
+#ifdef ALLSAXS
+ auxX = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
+ auxX1 = auxX1+PgradX(k,l,i)
+#endif
+ enddo
+ gsaxsC(l,i) = auxC - auxC1/Cnorm
+#ifdef ALLSAXS
+ gsaxsX(l,i) = auxX - auxX1/Cnorm
+#endif
+c write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
+c * " gradX",wsaxs*(auxX - auxX1/Cnorm)
+ enddo
+ enddo
+#ifdef MPI
+ endif
+#endif
+ return
+ end
+c----------------------------------------------------------------------------
+ subroutine e_saxsC(Esaxs_constr)
+ implicit none
+ include 'DIMENSIONS'
+ include 'DIMENSIONS.ZSCOPT'
+ include 'DIMENSIONS.FREE'
+#ifdef MPI
+ include "mpif.h"
+ include "COMMON.SETUP"
+ integer IERR
+#endif
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.CHAIN'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.VAR'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.DERIV'
+ include 'COMMON.CONTROL'
+ include 'COMMON.NAMES'
+ include 'COMMON.FFIELD'
+ include 'COMMON.LANGEVIN'
+ include 'COMMON.SAXS'
+c
+ double precision Esaxs_constr
+ integer i,iint,j,k,l
+ double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
+#ifdef MPI
+ double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
+#endif
+ double precision dk,dijCASPH,dijSCSPH,
+ & sigma2CA,sigma2SC,expCASPH,expSCSPH,
+ & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
+ & auxX,auxX1,Cnorm
+c SAXS restraint penalty function
+#ifdef DEBUG
+ write(iout,*) "------- SAXS penalty function start -------"
+ write (iout,*) "nsaxs",nsaxs," isaxs_start",isaxs_start,
+ & " isaxs_end",isaxs_end
+ write (iout,*) "nnt",nnt," ntc",nct
+ do i=nnt,nct
+ write(iout,'(a6,i5,3f10.5,5x,2f10.5)')
+ & "CA",i,(C(j,i),j=1,3),pstok,restok(itype(i))
+ enddo
+ do i=nnt,nct
+ write(iout,'(a6,i5,3f10.5)')"CSaxs",i,(Csaxs(j,i),j=1,3)
+ enddo
+#endif
+ Esaxs_constr = 0.0d0
+ logPtot=0.0d0
+ do j=isaxs_start,isaxs_end
+ Pcalc=0.0d0
+ do i=1,nres
+ do l=1,3
+ PgradC(l,i)=0.0d0
+ PgradX(l,i)=0.0d0
+ enddo
+ enddo
+ do i=nnt,nct
+ dijCASPH=0.0d0
+ dijSCSPH=0.0d0
+ do l=1,3
+ dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
+ enddo
+ if (itype(i).ne.10) then
+ do l=1,3
+ dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
+ enddo
+ endif
+ sigma2CA=2.0d0/pstok**2
+ sigma2SC=4.0d0/restok(itype(i))**2
+ expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
+ expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
+ Pcalc = Pcalc+expCASPH+expSCSPH
+#ifdef DEBUG
+ write(*,*) "processor i j Pcalc",
+ & MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
+#endif
+ CASPHgrad = sigma2CA*expCASPH
+ SCSPHgrad = sigma2SC*expSCSPH
+ do l=1,3
+ aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
+ PgradX(l,i) = PgradX(l,i) + aux
+ PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
+ enddo ! l
+ enddo ! i
+ do i=nnt,nct
+ do l=1,3
+ gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
+ gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
+ enddo
+ enddo
+ logPtot = logPtot - dlog(Pcalc)
+c print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
+c & " logPtot",logPtot
+ enddo ! j
+#ifdef MPI
+ if (nfgtasks.gt.1) then
+c write (iout,*) "logPtot before reduction",logPtot
+ call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
+ & MPI_SUM,king,FG_COMM,IERR)
+ logPtot = logPtot_
+c write (iout,*) "logPtot after reduction",logPtot
+ call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
+ & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
+ if (fg_rank.eq.king) then
+ do i=1,nres
+ do l=1,3
+ gsaxsC(l,i) = gsaxsC_(l,i)
+ enddo
+ enddo
+ endif
+ call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
+ & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
+ if (fg_rank.eq.king) then
+ do i=1,nres
+ do l=1,3
+ gsaxsX(l,i) = gsaxsX_(l,i)
+ enddo
+ enddo
+ endif
+ endif
+#endif
+ Esaxs_constr = logPtot
+ return
+ end
+
--- /dev/null
+ 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 (r<sigma).
+C
+ if (fcont.gt.0.0D0) then
+C If the SC-SC distance if close to sigma, apply spline.
+cAdam call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
+cAdam & fcont1,fprimcont1)
+cAdam fcont1=1.0d0-fcont1
+cAdam if (fcont1.gt.0.0d0) then
+cAdam fprimcont=fprimcont*fcont1+fcont*fprimcont1
+cAdam fcont=fcont*fcont1
+cAdam endif
+C Uncomment following 4 lines to have the geometric average of the epsilon0's
+cga eps0ij=1.0d0/dsqrt(eps0ij)
+cga do k=1,3
+cga gg(k)=gg(k)*eps0ij
+cga enddo
+cga eps0ij=-evdwij*eps0ij
+C Uncomment for AL's type of SC correlation interactions.
+cadam eps0ij=-evdwij
+ num_conti=num_conti+1
+ jcont(num_conti,i)=j
+ facont(num_conti,i)=fcont*eps0ij
+ fprimcont=eps0ij*fprimcont/rij
+ fcont=expon*fcont
+cAdam gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
+cAdam gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
+cAdam gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
+C Uncomment following 3 lines for Skolnick's type of SC correlation.
+ gacont(1,num_conti,i)=-fprimcont*xj
+ gacont(2,num_conti,i)=-fprimcont*yj
+ gacont(3,num_conti,i)=-fprimcont*zj
+cd write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
+cd write (iout,'(2i3,3f10.5)')
+cd & i,j,(gacont(kk,num_conti,i),kk=1,3)
+ endif
+ endif
+ enddo ! j
+ enddo ! iint
+C Change 12/1/95
+ num_cont(i)=num_conti
+ enddo ! i
+ if (calc_grad) then
+ do i=1,nct
+ do j=1,3
+ gvdwc(j,i)=expon*gvdwc(j,i)
+ gvdwx(j,i)=expon*gvdwx(j,i)
+ enddo
+ enddo
+ endif
+C******************************************************************************
+C
+C N O T E !!!
+C
+C To save time, the factor of EXPON has been extracted from ALL components
+C of GVDWC and GRADX. Remember to multiply them by this factor before further
+C use!
+C
+C******************************************************************************
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine eljk(evdw)
+C
+C This subroutine calculates the interaction energy of nonbonded side chains
+C assuming the LJK potential of interaction.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'DIMENSIONS.ZSCOPT'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.ENEPS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ dimension gg(3)
+ logical scheck
+ integer icant
+ external icant
+c print *,'Entering ELJK 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
+C Calculate SC interaction energy.
+C
+ do iint=1,nint_gr(i)
+ do j=istart(i,iint),iend(i,iint)
+ itypj=itype(j)
+ xj=c(1,nres+j)-xi
+ yj=c(2,nres+j)-yi
+ zj=c(3,nres+j)-zi
+ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
+ fac_augm=rrij**expon
+ e_augm=augm(itypi,itypj)*fac_augm
+ r_inv_ij=dsqrt(rrij)
+ rij=1.0D0/r_inv_ij
+ r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
+ fac=r_shift_inv**expon
+ e1=fac*fac*aa(itypi,itypj)
+ e2=fac*bb(itypi,itypj)
+ evdwij=e_augm+e1+e2
+ ij=icant(itypi,itypj)
+ eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
+ & /dabs(eps(itypi,itypj))
+ eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
+cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
+cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
+cd write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
+cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
+cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
+cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
+cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
+ evdw=evdw+evdwij
+ if (calc_grad) then
+C
+C Calculate the components of the gradient in DC and X
+C
+ fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
+ 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
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+ if (calc_grad) then
+ do i=1,nct
+ do j=1,3
+ gvdwc(j,i)=expon*gvdwc(j,i)
+ gvdwx(j,i)=expon*gvdwx(j,i)
+ enddo
+ enddo
+ endif
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine ebp(evdw)
+C
+C This subroutine calculates the interaction energy of nonbonded side chains
+C assuming the Berne-Pechukas potential of interaction.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'DIMENSIONS.ZSCOPT'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.NAMES'
+ include 'COMMON.INTERACT'
+ include 'COMMON.ENEPS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CALC'
+ common /srutu/ icall
+c double precision rrsave(maxdim)
+ logical lprn
+ integer icant
+ external icant
+ do i=1,210
+ do j=1,2
+ eneps_temp(j,i)=0.0d0
+ enddo
+ enddo
+ evdw=0.0D0
+c print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
+ evdw=0.0D0
+c if (icall.eq.0) then
+c lprn=.true.
+c else
+ lprn=.false.
+c endif
+ ind=0
+ do i=iatsc_s,iatsc_e
+ itypi=itype(i)
+ itypi1=itype(i+1)
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+ dxi=dc_norm(1,nres+i)
+ dyi=dc_norm(2,nres+i)
+ dzi=dc_norm(3,nres+i)
+ dsci_inv=dsc_inv(itypi)
+C
+C Calculate SC interaction energy.
+C
+ do iint=1,nint_gr(i)
+ do j=istart(i,iint),iend(i,iint)
+ ind=ind+1
+ itypj=itype(j)
+ dscj_inv=dsc_inv(itypj)
+ chi1=chi(itypi,itypj)
+ chi2=chi(itypj,itypi)
+ chi12=chi1*chi2
+ chip1=chip(itypi)
+ chip2=chip(itypj)
+ chip12=chip1*chip2
+ alf1=alp(itypi)
+ alf2=alp(itypj)
+ alf12=0.5D0*(alf1+alf2)
+C For diagnostics only!!!
+c chi1=0.0D0
+c chi2=0.0D0
+c chi12=0.0D0
+c chip1=0.0D0
+c chip2=0.0D0
+c chip12=0.0D0
+c alf1=0.0D0
+c alf2=0.0D0
+c alf12=0.0D0
+ xj=c(1,nres+j)-xi
+ yj=c(2,nres+j)-yi
+ zj=c(3,nres+j)-zi
+ 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)
+cd if (icall.eq.0) then
+cd rrsave(ind)=rrij
+cd else
+cd rrij=rrsave(ind)
+cd endif
+ rij=dsqrt(rrij)
+C Calculate the angle-dependent terms of energy & contributions to derivatives.
+ call sc_angular
+C Calculate whole angle-dependent part of epsilon and contributions
+C to its derivatives
+ fac=(rrij*sigsq)**expon2
+ e1=fac*fac*aa(itypi,itypj)
+ e2=fac*bb(itypi,itypj)
+ evdwij=eps1*eps2rt*eps3rt*(e1+e2)
+ eps2der=evdwij*eps3rt
+ eps3der=evdwij*eps2rt
+ evdwij=evdwij*eps2rt*eps3rt
+ ij=icant(itypi,itypj)
+ aux=eps1*eps2rt**2*eps3rt**2
+ eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
+ & /dabs(eps(itypi,itypj))
+ eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
+ evdw=evdw+evdwij
+ if (calc_grad) then
+ if (lprn) then
+ sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
+ epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
+cd write (iout,'(2(a3,i3,2x),15(0pf7.3))')
+cd & restyp(itypi),i,restyp(itypj),j,
+cd & epsi,sigm,chi1,chi2,chip1,chip2,
+cd & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
+cd & om1,om2,om12,1.0D0/dsqrt(rrij),
+cd & evdwij
+ endif
+C Calculate gradient components.
+ e1=e1*eps1*eps2rt**2*eps3rt**2
+ fac=-expon*(e1+evdwij)
+ sigder=fac/sigsq
+ fac=rrij*fac
+C Calculate radial part of the gradient
+ gg(1)=xj*fac
+ gg(2)=yj*fac
+ gg(3)=zj*fac
+C Calculate the angular part of the gradient and sum add the contributions
+C to the appropriate components of the Cartesian gradient.
+ call sc_grad
+ endif
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+c stop
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine egb(evdw)
+C
+C This subroutine calculates the interaction energy of nonbonded side chains
+C assuming the Gay-Berne potential of interaction.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'DIMENSIONS.ZSCOPT'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.NAMES'
+ include 'COMMON.INTERACT'
+ include 'COMMON.ENEPS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CALC'
+ logical lprn
+ common /srutu/icall
+ integer icant
+ external icant
+ do i=1,210
+ do j=1,2
+ eneps_temp(j,i)=0.0d0
+ enddo
+ enddo
+ evdw=0.0D0
+c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
+ evdw=0.0D0
+ lprn=.false.
+c if (icall.gt.0) lprn=.true.
+ ind=0
+ do i=iatsc_s,iatsc_e
+ itypi=itype(i)
+ itypi1=itype(i+1)
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+ dxi=dc_norm(1,nres+i)
+ dyi=dc_norm(2,nres+i)
+ dzi=dc_norm(3,nres+i)
+ dsci_inv=dsc_inv(itypi)
+C
+C Calculate SC interaction energy.
+C
+ do iint=1,nint_gr(i)
+ do j=istart(i,iint),iend(i,iint)
+ ind=ind+1
+ itypj=itype(j)
+ dscj_inv=dsc_inv(itypj)
+ sig0ij=sigma(itypi,itypj)
+ chi1=chi(itypi,itypj)
+ chi2=chi(itypj,itypi)
+ chi12=chi1*chi2
+ chip1=chip(itypi)
+ chip2=chip(itypj)
+ chip12=chip1*chip2
+ alf1=alp(itypi)
+ alf2=alp(itypj)
+ alf12=0.5D0*(alf1+alf2)
+C For diagnostics only!!!
+c chi1=0.0D0
+c chi2=0.0D0
+c chi12=0.0D0
+c chip1=0.0D0
+c chip2=0.0D0
+c chip12=0.0D0
+c alf1=0.0D0
+c alf2=0.0D0
+c alf12=0.0D0
+ xj=c(1,nres+j)-xi
+ yj=c(2,nres+j)-yi
+ zj=c(3,nres+j)-zi
+ 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)
+C Calculate angle-dependent terms of energy and contributions to their
+C derivatives.
+ call sc_angular
+ sigsq=1.0D0/sigsq
+ sig=sig0ij*dsqrt(sigsq)
+ rij_shift=1.0D0/rij-sig+sig0ij
+C I hate to put IF's in the loops, but here don't have another choice!!!!
+ if (rij_shift.le.0.0D0) then
+ evdw=1.0D20
+ return
+ endif
+ sigder=-sig*sigsq
+c---------------------------------------------------------------
+ rij_shift=1.0D0/rij_shift
+ fac=rij_shift**expon
+ e1=fac*fac*aa(itypi,itypj)
+ e2=fac*bb(itypi,itypj)
+ evdwij=eps1*eps2rt*eps3rt*(e1+e2)
+ eps2der=evdwij*eps3rt
+ eps3der=evdwij*eps2rt
+ evdwij=evdwij*eps2rt*eps3rt
+ evdw=evdw+evdwij
+ ij=icant(itypi,itypj)
+ aux=eps1*eps2rt**2*eps3rt**2
+ eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
+ & /dabs(eps(itypi,itypj))
+ eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
+c write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
+c & " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
+c & aux*e2/eps(itypi,itypj)
+c if (lprn) then
+c sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
+c epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
+c write (iout,'(2(a3,i3,2x),17(0pf7.3))')
+c & restyp(itypi),i,restyp(itypj),j,
+c & epsi,sigm,chi1,chi2,chip1,chip2,
+c & eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
+c & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
+c & evdwij
+c endif
+ if (calc_grad) then
+C Calculate gradient components.
+ e1=e1*eps1*eps2rt**2*eps3rt**2
+ fac=-expon*(e1+evdwij)*rij_shift
+ sigder=fac*sigder
+ fac=rij*fac
+C Calculate the radial part of the gradient
+ gg(1)=xj*fac
+ gg(2)=yj*fac
+ gg(3)=zj*fac
+C Calculate angular part of the gradient.
+ call sc_grad
+ endif
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+ end
+C-----------------------------------------------------------------------------
+ subroutine egbv(evdw)
+C
+C This subroutine calculates the interaction energy of nonbonded side chains
+C assuming the Gay-Berne-Vorobjev potential of interaction.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'DIMENSIONS.ZSCOPT'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.NAMES'
+ include 'COMMON.INTERACT'
+ include 'COMMON.ENEPS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CALC'
+ common /srutu/ icall
+ logical lprn
+ integer icant
+ external icant
+ do i=1,210
+ do j=1,2
+ eneps_temp(j,i)=0.0d0
+ enddo
+ enddo
+ evdw=0.0D0
+c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
+ evdw=0.0D0
+ lprn=.false.
+c if (icall.gt.0) lprn=.true.
+ ind=0
+ do i=iatsc_s,iatsc_e
+ itypi=itype(i)
+ itypi1=itype(i+1)
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+ dxi=dc_norm(1,nres+i)
+ dyi=dc_norm(2,nres+i)
+ dzi=dc_norm(3,nres+i)
+ dsci_inv=dsc_inv(itypi)
+C
+C Calculate SC interaction energy.
+C
+ do iint=1,nint_gr(i)
+ do j=istart(i,iint),iend(i,iint)
+ ind=ind+1
+ itypj=itype(j)
+ dscj_inv=dsc_inv(itypj)
+ sig0ij=sigma(itypi,itypj)
+ r0ij=r0(itypi,itypj)
+ chi1=chi(itypi,itypj)
+ chi2=chi(itypj,itypi)
+ chi12=chi1*chi2
+ chip1=chip(itypi)
+ chip2=chip(itypj)
+ chip12=chip1*chip2
+ alf1=alp(itypi)
+ alf2=alp(itypj)
+ alf12=0.5D0*(alf1+alf2)
+C For diagnostics only!!!
+c chi1=0.0D0
+c chi2=0.0D0
+c chi12=0.0D0
+c chip1=0.0D0
+c chip2=0.0D0
+c chip12=0.0D0
+c alf1=0.0D0
+c alf2=0.0D0
+c alf12=0.0D0
+ xj=c(1,nres+j)-xi
+ yj=c(2,nres+j)-yi
+ zj=c(3,nres+j)-zi
+ 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)
+C Calculate angle-dependent terms of energy and contributions to their
+C derivatives.
+ call sc_angular
+ sigsq=1.0D0/sigsq
+ sig=sig0ij*dsqrt(sigsq)
+ rij_shift=1.0D0/rij-sig+r0ij
+C I hate to put IF's in the loops, but here don't have another choice!!!!
+ if (rij_shift.le.0.0D0) then
+ evdw=1.0D20
+ return
+ endif
+ sigder=-sig*sigsq
+c---------------------------------------------------------------
+ rij_shift=1.0D0/rij_shift
+ fac=rij_shift**expon
+ e1=fac*fac*aa(itypi,itypj)
+ e2=fac*bb(itypi,itypj)
+ evdwij=eps1*eps2rt*eps3rt*(e1+e2)
+ eps2der=evdwij*eps3rt
+ eps3der=evdwij*eps2rt
+ fac_augm=rrij**expon
+ e_augm=augm(itypi,itypj)*fac_augm
+ evdwij=evdwij*eps2rt*eps3rt
+ evdw=evdw+evdwij+e_augm
+ ij=icant(itypi,itypj)
+ aux=eps1*eps2rt**2*eps3rt**2
+ eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
+ & /dabs(eps(itypi,itypj))
+ eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
+c eneps_temp(ij)=eneps_temp(ij)
+c & +(evdwij+e_augm)/eps(itypi,itypj)
+c if (lprn) then
+c sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
+c epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
+c write (iout,'(2(a3,i3,2x),17(0pf7.3))')
+c & restyp(itypi),i,restyp(itypj),j,
+c & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
+c & chi1,chi2,chip1,chip2,
+c & eps1,eps2rt**2,eps3rt**2,
+c & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
+c & evdwij+e_augm
+c endif
+ if (calc_grad) then
+C Calculate gradient components.
+ e1=e1*eps1*eps2rt**2*eps3rt**2
+ fac=-expon*(e1+evdwij)*rij_shift
+ sigder=fac*sigder
+ fac=rij*fac-2*expon*rrij*e_augm
+C Calculate the radial part of the gradient
+ gg(1)=xj*fac
+ gg(2)=yj*fac
+ gg(3)=zj*fac
+C Calculate angular part of the gradient.
+ call sc_grad
+ endif
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+ end
+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'
+ 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 Calculate eps1(om12) and its derivative in 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) 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
+ 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 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
+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
+ eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*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 '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)+eom1*erij(k))*dsci_inv
+ gvdwx(k,j)=gvdwx(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
+ 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 '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)
+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 .or. itel(i+1).eq.0) 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
+ 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
+ endif
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine vec_and_deriv_test
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ 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 '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_test
+ 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_test
+ 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
+ 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
+ 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
+*
+* 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)+ecosb*erij(k))*vblinv
+ gelc(k,j)=gelc(k,j)+ghalf
+ & +(ecosa*dc_norm(k,i)+ecosg*erij(k))*vblinv
+ 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)+ecosbp*erij(k))*vblinv
+ gacontp_hb2(k,num_conti,i)=ghalfp
+ & +(ecosap*dc_norm(k,i)+ecosgp*erij(k))*vblinv
+ gacontp_hb3(k,num_conti,i)=gggp(k)
+ gacontm_hb1(k,num_conti,i)=ghalfm
+ & +(ecosam*dc_norm(k,j)+ecosbm*erij(k))*vblinv
+ gacontm_hb2(k,num_conti,i)=ghalfm
+ & +(ecosam*dc_norm(k,i)+ecosgm*erij(k))*vblinv
+ 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,*) 'j<i'
+C Uncomment following three lines for SC-p interactions
+c do k=1,3
+c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
+c enddo
+ else
+cd write (iout,*) 'j>i'
+ 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
+
--- /dev/null
+ 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
--- /dev/null
+ 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
+ character*1 chainid(10) /'A','B','C','D','E','F','G','H','I','J'/
+ 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
+ ichain=1
+ ires=0
+ do i=nnt,nct
+ iti=itype(i)
+ if (iti.eq.ntyp1) then
+ ichain=ichain+1
+ ires=0
+ write (ipdb,'(a)') 'TER'
+ else
+ ires=ires+1
+ iatom=iatom+1
+ ica(i)=iatom
+ write (ipdb,10) iatom,restyp(iti),chainid(ichain),
+ & ires,(c(j,i),j=1,3)
+ if (iti.ne.10) then
+ iatom=iatom+1
+ write (ipdb,20) iatom,restyp(iti),chainid(ichain),
+ & ires,(c(j,nres+i),j=1,3)
+ endif
+ endif
+ enddo
+ write (ipdb,'(a)') 'TER'
+ do i=nnt,nct-1
+ if (itype(i).eq.ntyp1) cycle
+ if (itype(i).eq.10 .and. itype(i+1).ne.ntyp1) then
+ write (ipdb,30) ica(i),ica(i+1)
+ else if (itype(i).ne.10 .and. itype(i+1).ne.ntyp1) then
+ write (ipdb,30) ica(i),ica(i+1),ica(i)+1
+ else if (itype(i).ne.10 .and. itype(i+1).eq.ntyp1) then
+ write (ipdb,30) ica(i),ica(i)+1
+ endif
+ enddo
+ if (itype(nct).ne.10) then
+ write (ipdb,30) ica(nct),ica(nct)+1
+ endif
+ do i=1,nss
+ if (dyn_ss) then
+ write (iunit,30) ica(idssb(i))+1,ica(jdssb(i))+1
+ else
+ write (ipdb,30) ica(ihpb(i)-nres)+1,ica(jhpb(i)-nres)+1
+ endif
+ enddo
+ write (ipdb,'(a6)') 'ENDMDL'
+ 10 FORMAT ('ATOM',I7,' CA ',A3,1X,A1,I4,4X,3F8.3,f15.3)
+ 20 FORMAT ('ATOM',I7,' CB ',A3,1X,A1,I4,4X,3F8.3,f15.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)') '\@<TRIPOS>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)') '\@<TRIPOS>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)') '\@<TRIPOS>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
+C write (imol2,'(i5,2i6,i2)') nct-nnt+i,ihpb(i),jhpb(i),1
+ if (dyn_ss) then
+ write(imol2,'(a6,i4,1x,a3,i7,4x,a3,i7)')
+ & 'SSBOND',i,'CYS',ihpb(i)-1-nres,
+ & 'CYS',jhpb(i)-1-nres
+C & 'SSBOND',i,'CYS',idssb(i)-nnt+1,
+C & 'CYS',jdssb(i)-nnt+1
+ else
+ write(imol2,'(a6,i4,1x,a3,i7,4x,a3,i7)')
+ & 'SSBOND',i,'CYS',ihpb(i)-nnt+1-nres,
+ & 'CYS',jhpb(i)-nnt+1-nres
+ endif
+ enddo
+ write (imol2,'(a)') '\@<TRIPOS>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
+ iii=igeom
+ igeom=iout
+ 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
--- /dev/null
+ 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---------------------------------------------------------------------------------
+ double precision function rlornmr1(y,ymin,ymax,sigma)
+ implicit none
+ double precision y,ymin,ymax,sigma
+ double precision wykl /4.0d0/
+ if (y.lt.ymin) then
+ rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
+ else if (y.gt.ymax) then
+ rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
+ else
+ rlornmr1=0.0d0
+ endif
+ return
+ end
+c------------------------------------------------------------------------------
+ double precision function rlornmr1prim(y,ymin,ymax,sigma)
+ implicit none
+ double precision y,ymin,ymax,sigma
+ double precision wykl /4.0d0/
+ if (y.lt.ymin) then
+ rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/
+ & ((ymin-y)**wykl+sigma**wykl)**2
+ else if (y.gt.ymax) then
+ rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/
+ & ((y-ymax)**wykl+sigma**wykl)**2
+ else
+ rlornmr1prim=0.0d0
+ endif
+ return
+ end
+
--- /dev/null
+ 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
+
--- /dev/null
+ 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
--- /dev/null
+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,gmu,gUb2,
+ & DUg,DUgder,DtUg2,DtUg2der,Ctobr,Ctobrder,Dtobr2,Dtobr2der,
+ & gtEUg
+ common /rotat/ Ug(2,2,maxres),Ugder(2,2,maxres),Ug2(2,2,maxres),
+ & Ug2der(2,2,maxres),obrot(2,maxres),obrot2(2,maxres),
+ & obrot_der(2,maxres),obrot2_der(2,maxres)
+C This common block contains vectors and matrices dependent on a single
+C amino-acid residue.
+ common /precomp1/ Ub2(2,maxres),Ub2der(2,maxres),mu(2,maxres),
+ & gmu(2,maxres),gUb2(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),
+ & gtEUg(2,2,maxres)
+C This common block contains vectors and matrices dependent on two
+C consecutive amino-acid residues.
+ double precision Ug2Db1t,Ug2Db1tder,CUgb2,CUgb2der,EUgC,
+ & EUgCder,EUgD,EUgDder,DtUg2EUg,DtUg2EUgder
+ 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
--- /dev/null
+ 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)
--- /dev/null
+ double precision dcdv,dxdv,dxds,gradx,gradc,gvdwc,gelc,gelc_long,
+ & gvdwpp,gel_loc,gel_loc_long,gvdwc_scpp,gliptranc,gliptranx,
+ & gradx_scp,gvdwc_scp,ghpbx,ghpbc,gloc,gloc_x,dtheta,dphi,dalpha,
+ & domega,gscloc,gsclocx,gradcorr,gradcorr_long,gradcorr5_long,
+ & gradcorr6_long,gcorr6_turn_long,gvdwx,gshieldx,gradafm,
+ & gradxorr,gradcorr5,gradcorr6,gcorr3_turn,gcorr4_turn,gcorr6_turn,
+ & gradb,gradbx,gel_loc_loc,gel_loc_turn3,gel_loc_turn4,
+ & gel_loc_turn6,gcorr_loc,g_corr5_loc,g_corr6_loc,gsccorc,
+ & gsccorx,gsccor_loc,
+ & gg_tube,gg_tube_SC,
+ & gshieldc, gshieldc_loc, gshieldx_ec, gshieldc_ec,
+ & gshieldc_loc_ec, gshieldx_t3,gshieldc_t3,gshieldc_loc_t3,
+ & gshieldx_t4, gshieldc_t4,gshieldc_loc_t4,gshieldx_ll,
+ & gshieldc_ll, gshieldc_loc_ll,gsaxsC,gsaxsX,
+ & gdfad,gdfat,gdfan,gdfab
+ integer nfl,icg
+ logical calc_grad
+ common /derivat/ dcdv(6,maxdim),dxdv(6,maxdim),dxds(6,maxres),
+ & gradx(3,-1:maxres,2),gradc(3,-1:maxres,2),gvdwx(3,-1:maxres),
+ & gvdwc(3,-1:maxres),gelc(3,-1:maxres),gelc_long(3,-1:maxres),
+ & gvdwpp(3,-1:maxres),gvdwc_scpp(3,-1:maxres),
+ & gliptranc(3,-1:maxres),
+ & gliptranx(3,-1:maxres),
+ & gshieldx(3,-1:maxres), gshieldc(3,-1:maxres),
+ & gshieldc_loc(3,-1:maxres),
+ & gshieldx_ec(3,-1:maxres), gshieldc_ec(3,-1:maxres),
+ & gshieldc_loc_ec(3,-1:maxres),
+ & gshieldx_t3(3,-1:maxres), gshieldc_t3(3,-1:maxres),
+ & gshieldc_loc_t3(3,-1:maxres),
+ & gshieldx_t4(3,-1:maxres), gshieldc_t4(3,-1:maxres),
+ & gshieldc_loc_t4(3,-1:maxres),
+ & gshieldx_ll(3,-1:maxres), gshieldc_ll(3,-1:maxres),
+ & gshieldc_loc_ll(3,-1:maxres),
+ & gradafm(3,-1:maxres),gg_tube(3,-1:maxres),
+ & gg_tube_sc(3,-1:maxres),
+ & gradx_scp(3,-1:maxres),gvdwc_scp(3,-1:maxres),
+ & ghpbx(3,-1:maxres),
+ & gsaxsC(3,-1:maxres),gsaxsX(3,-1:maxres),
+ & ghpbc(3,-1:maxres),gloc(maxvar,2),gradcorr(3,-1:maxres),
+ & gradcorr_long(3,-1:maxres),gradcorr5_long(3,-1:maxres),
+ & gradcorr6_long(3,-1:maxres),gcorr6_turn_long(3,-1:maxres),
+ & gradxorr(3,-1:maxres),gradcorr5(3,-1:maxres),
+ & gradcorr6(3,-1:maxres),
+ & gloc_x(maxvar,2),gel_loc(3,-1:maxres),gel_loc_long(3,-1:maxres),
+ & gcorr3_turn(3,-1:maxres),
+ & gcorr4_turn(3,-1:maxres),gcorr6_turn(3,-1:maxres),
+ & gradb(3,-1:maxres),
+ & gradbx(3,-1: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,-1:maxres),
+ & gsccorx(3,-1:maxres),gsccor_loc(-1:maxres),
+ & dtheta(3,2,-1:maxres),
+ & gscloc(3,-1:maxres),gsclocx(3,-1:maxres),
+ & dphi(3,3,-1:maxres),dalpha(3,3,-1:maxres),domega(3,3,-1:maxres),
+ & gdfad(3,maxres),gdfat(3,maxres),gdfan(3,maxres),gdfab(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
+ integer igrad_start,igrad_end,jgrad_start(maxres),
+ & jgrad_end(maxres)
+ common /mpgrad/ igrad_start,igrad_end,jgrad_start,jgrad_end
--- /dev/null
+ double precision dcdv,dxdv,dxds,gradx,gradc,gvdwc,gelc,gvdwpp,
+ & gradx_scp,gvdwc_scp,ghpbx,ghpbc,gloc,gvdwx,gradcorr,gradxorr,
+ & gliptranc,gliptranx,
+ & gradcorr5,gradcorr6,gel_loc,gcorr3_turn,gcorr4_turn,gcorr6_turn,
+ & gel_loc_loc,gel_loc_turn3,gel_loc_turn4,gel_loc_turn6,gcorr_loc,
+ & g_corr5_loc,g_corr6_loc,gradb,gradbx,gsccorc,gsccorx,gsccor_loc,
+ & gscloc,gsclocx,gshieldx,gradafm,
+ & gshieldc, gshieldc_loc, gshieldx_ec, gshieldc_ec,
+ & gshieldc_loc_ec, gshieldx_t3,gshieldc_t3,gshieldc_loc_t3,
+ & gshieldx_t4, gshieldc_t4,gshieldc_loc_t4,gshieldx_ll,
+ & gshieldc_ll, gshieldc_loc_ll
+
+ integer nfl,icg
+ logical calc_grad
+ common /derivat/ dcdv(6,maxdim),dxdv(6,maxdim),dxds(6,maxres),
+ & gradx(3,maxres,2),gradc(3,maxres,2),gvdwx(3,maxres),
+ & gvdwc(3,maxres),gelc(3,maxres),gvdwpp(3,maxres),
+ & gradx_scp(3,maxres),
+ & gliptranc(3,-1:maxres),
+ & gliptranx(3,-1:maxres),
+ & gshieldx(3,-1:maxres), gshieldc(3,-1:maxres),
+ & gshieldc_loc(3,-1:maxres),
+ & gshieldx_ec(3,-1:maxres), gshieldc_ec(3,-1:maxres),
+ & gshieldc_loc_ec(3,-1:maxres),
+ & gshieldx_t3(3,-1:maxres), gshieldc_t3(3,-1:maxres),
+ & gshieldc_loc_t3(3,-1:maxres),
+ & gshieldx_t4(3,-1:maxres), gshieldc_t4(3,-1:maxres),
+ & gshieldc_loc_t4(3,-1:maxres),
+ & gshieldx_ll(3,-1:maxres), gshieldc_ll(3,-1:maxres),
+ & gshieldc_loc_ll(3,-1:maxres),
+ & gvdwc_scp(3,maxres),ghpbx(3,maxres),ghpbc(3,maxres),
+ & gloc(maxvar,2),gradcorr(3,maxres),gradxorr(3,maxres),
+ & gradcorr5(3,maxres),gradcorr6(3,maxres),
+ & 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
--- /dev/null
+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,
+ & wdfa_dist,wdfa_tor,wdfa_nei,wdfa_beta,
+ & r0_corr,wliptran,wsaxs
+ 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,wliptran,wsaxs,
+ & wdfa_dist,wdfa_tor,wdfa_nei,wdfa_beta,
+ & weights(max_ene),
+ & scal14,cutoff_corr,delt_corr,r0_corr,ipot,n_ene_comp
+ common /potentials/ potname(5)
+ character*3 potname
+C-----------------------------------------------------------------------
+C wlong,welec,wtor,wang,wscloc are the weight of the energy terms
+C corresponding to side-chain, electrostatic, torsional, valence-angle,
+C and local side-chain terms.
+C
+C IPOT determines which SC...SC interaction potential will be used:
+C 1 - LJ: 2n-n Lennard-Jones
+C 2 - LJK: 2n-n Kihara type (shifted Lennard-Jones)
+C 3 - BP; Berne-Pechukas (angular dependence)
+C 4 - GB; Gay-Berne (angular dependence)
+C 5 - GBV; Gay-Berne-Vorobjev; angularly-dependent Kihara potential
+C------------------------------------------------------------------------
--- /dev/null
+ 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)
--- /dev/null
+ double precision pi,dwapi,pipol,pi3,dwapi3,deg2rad,rad2deg,angmin
+ common /geo/ pi,dwapi,pipol,pi3,dwapi3,deg2rad,rad2deg,angmin
--- /dev/null
+ character*80 titel
+ common /header/ titel
--- /dev/null
+ double precision aa_aq,bb_aq,augm,aad,bad,app,bpp,ael6,ael3,
+ & aa_lip,bb_lip
+ integer nnt,nct,nint_gr,istart,iend,itype,itel,itypro,ielstart,
+ & ielend,nscp_gr,iscpstart,iscpend,iatsc_s,iatsc_e,iatel_s,
+ & iatel_e,iatscp_s,iatscp_e,ispp,iscp,expon,expon2
+ common /interact/aa_aq(ntyp,ntyp),bb_aq(ntyp,ntyp),
+ & augm(ntyp,ntyp),aa_lip(ntyp,ntyp),bb_lip(ntyp,ntyp),
+ & aad(ntyp,2),bad(ntyp,2),app(2,2),bpp(2,2),ael6(2,2),ael3(2,2),
+ & expon,expon2,nnt,nct,nint_gr(maxres),istart(maxres,maxint_gr),
+ & iend(maxres,maxint_gr),itype(maxres),itel(maxres),itypro,
+ & 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
+C 12/1/95 Array EPS included in the COMMON block.
+ double precision eps,sigma,sigmaii,rs0,chi,chip,chip0,alp,signa0,
+ & sigii,sigma0,rr0,r0,r0e,r0d,rpp,epp,elpp6,elpp3,eps_scp,rscp,
+ & eps_orig,epslip
+ common /body/eps(ntyp,ntyp),sigma(ntyp,ntyp),sigmaii(ntyp,ntyp),
+ &epslip(ntyp,ntyp),
+ & rs0(ntyp,ntyp),chi(ntyp,ntyp),chip(ntyp),chip0(ntyp),alp(ntyp),
+ & sigma0(ntyp),sigii(ntyp),rr0(ntyp),r0(ntyp,ntyp),r0e(ntyp,ntyp),
+ & r0d(ntyp,2),rpp(2,2),epp(2,2),elpp6(2,2),elpp3(2,2),
+ & eps_scp(ntyp,2),rscp(ntyp,2),eps_orig(ntyp,ntyp)
+c 12/5/03 modified 09/18/03 Bond stretching parameters.
+ double precision vbldp0,vbldsc0,akp,aksc,abond0,distchainmax
+ &,vbldpDUM
+ integer nbondterm
+ common /stretch/ vbldp0,vbldsc0(maxbondterm,ntyp),akp,
+ & aksc(maxbondterm,ntyp),abond0(maxbondterm,ntyp),
+ & distchainmax,nbondterm(ntyp)
+ &,vbldpDUM
+C 01/29/15 Lipidic parameters
+ double precision pepliptran,liptranene
+ common /lipid/ pepliptran,liptranene(ntyp)
+
+
--- /dev/null
+ double precision a0thet,athet,bthet,polthet,gthet,theta0,sig0,
+ & sigc0,dsc,dsc_inv,bsc,censc,gaussc,dsc0
+ integer nlob
+C Parameters of the virtual-bond-angle probability distribution
+ common /thetas/ a0thet(-ntyp:ntyp),athet(2,-ntyp:ntyp,-1:1,-1:1),
+ & bthet(2,-ntyp:ntyp,-1:1,-1:1),polthet(0:3,-ntyp:ntyp),
+ & gthet(3,-ntyp:ntyp),theta0(-ntyp:ntyp),sig0(-ntyp:ntyp),
+ & sigc0(-ntyp:ntyp)
+C Parameters of the side-chain probability distribution
+ common /sclocal/ dsc(ntyp1),dsc_inv(ntyp1),bsc(maxlob,ntyp),
+ & censc(3,maxlob,-ntyp:ntyp),gaussc(3,3,maxlob,-ntyp:ntyp),
+ &dsc0(ntyp1),
+ & nlob(ntyp1)
+C Parameters of ab initio-derived potential of virtual-bond-angle bending
+ integer nthetyp,ntheterm,ntheterm2,ntheterm3,nsingle,ndouble,
+ & ithetyp(-ntyp1:ntyp1),nntheterm
+ common /theta_abinitio/ aa0thet(-maxthetyp1:maxthetyp1,
+ &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2),
+ & aathet(maxtheterm,-maxthetyp1:maxthetyp1,
+ &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2),
+ & bbthet(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1,
+ &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2),
+ & ccthet(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1,
+ &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2),
+ & ddthet(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1,
+ &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2),
+ & eethet(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1,
+ &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2),
+ & ffthet(maxdouble,maxdouble,maxtheterm3,-maxthetyp1:maxthetyp1,
+ &-maxthetyp1:maxthetyp1, -maxthetyp1:maxthetyp1,2),
+ & ggthet(maxdouble,maxdouble,maxtheterm3,-maxthetyp1:maxthetyp1,
+ &-maxthetyp1:maxthetyp1, -maxthetyp1:maxthetyp1,2),
+ & ithetyp,nthetyp,ntheterm,ntheterm2,ntheterm3,nsingle,
+ & ndouble,nntheterm
+
+ double precision aa0thet,aathet,bbthet,ccthet,ddthet,eethet,
+ & ffthet,
+ & ggthet
+C Virtual-bond lenghts
+ double precision vbl,vblinv,vblinv2,vbl_cis,vbl0,vbld_inv
+ integer loc_start,loc_end,ithet_start,ithet_end,iphi_start,
+ & iphi_end,iphid_start,iphid_end,ibond_start,ibond_end,
+ & ibondp_start,ibondp_end,ivec_start,ivec_end,iset_start,iset_end,
+ & iturn3_start,iturn3_end,iturn4_start,iturn4_end,iint_start,
+ & iint_end,iphi1_start,iphi1_end,itau_start,itau_end,
+ & isaxs_start,isaxs_end
+ common /peptbond/ vbl,vblinv,vblinv2,vbl_cis,vbl0
+ common /indices/ loc_start,loc_end,ithet_start,ithet_end,
+ & iphi_start,iphi_end,iphid_start,iphid_end,ibond_start,ibond_end,
+ & ibondp_start,ibondp_end,ivec_start,ivec_end,iset_start,iset_end,
+ & iturn3_start,iturn3_end,iturn4_start,iturn4_end,iint_start,
+ & iint_end,iphi1_start,iphi1_end,itau_start,itau_end,
+ & isaxs_start,isaxs_end
+C Inverses of the actual virtual bond lengths
+ common /invlen/ vbld_inv(maxres2)
--- /dev/null
+ double precision tolf,rtolf
+ integer maxfun,maxmin
+ common /minimm/ tolf,rtolf,maxfun,maxmin
--- /dev/null
+ character*3 restyp
+ character*1 onelet
+ common /names/ restyp(-ntyp1:ntyp1),
+ & onelet(-ntyp1:ntyp1)
+ character*10 ename,wname
+ integer nprint_ene,print_order
+ common /namterm/ ename(max_ene),wname(max_ene),nprint_ene,
+ & print_order(max_ene)
--- /dev/null
+ double precision ss_depth,ebr,d0cm,akcm,akth,akct,v1ss,v2ss,v3ss
+ integer ns,nss,nfree,iss
+ common /sbridge/ ss_depth,ebr,d0cm,akcm,akth,akct,v1ss,v2ss,v3ss,
+ & ns,nss,nfree,iss(maxss)
+ double precision dhpb,dhpb1,forcon,fordepth,xlscore,wboltzd,
+ & dhpb_peak,dhpb1_peak,forcon_peak,fordepth_peak,scal_peak,bfac
+ integer ihpb,jhpb,nhpb,idssb,jdssb,ibecarb,ibecarb_peak,npeak,
+ & ipeak,irestr_type,irestr_type_peak,ihpb_peak,jhpb_peak,nhpb_peak
+ logical restr_on_coord
+ common /links/ dhpb(maxdim),dhpb1(maxdim),forcon(maxdim),
+ & fordepth(maxdim),bfac(maxres),xlscore(maxdim),wboltzd,
+ & ihpb(maxdim),jhpb(maxdim),ibecarb(maxdim),irestr_type(maxdim),
+ & nhpb,restr_on_coord
+ common /NMRpeaks/ dhpb_peak(maxdim),dhpb1_peak(maxdim),
+ & forcon_peak(maxdim),fordepth_peak(maxdim),scal_peak,
+ & ihpb_peak(maxdim),jhpb_peak(maxdim),ibecarb_peak(maxdim),
+ & irestr_type_peak(maxdim),ipeak(2,maxdim),npeak,nhpb_peak
+ double precision weidis
+ common /restraints/ weidis
+ integer link_start,link_end,link_start_peak,link_end_peak
+ common /links_split/ link_start,link_end,link_start_peak,
+ & link_end_peak
+ double precision Ht,dyn_ssbond_ij,dtriss,atriss,btriss,ctriss
+ logical dyn_ss,dyn_ss_mask
+ common /dyn_ssbond/ dtriss,atriss,btriss,ctriss,Ht,
+ & dyn_ssbond_ij(maxres,maxres),
+ & idssb(maxdim),jdssb(maxdim)
+ common /dyn_ss_logic/
+ & dyn_ss,dyn_ss_mask(maxres)
--- /dev/null
+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,-ntyp:ntyp,-ntyp:ntyp),
+ & v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp),
+ & v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp),
+ & vlor1sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp),
+ & vlor2sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp),
+ & vlor3sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp),
+ & 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,-ntyp:ntyp),isccortyp(-ntyp:ntyp),
+ & nsccortyp,
+ & nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)
+
--- /dev/null
+C Parameters of the SC rotamers (local) term
+ double precision sc_parmin
+ common/scrot/sc_parmin(maxsccoef,ntyp)
--- /dev/null
+ integer king,idint,idreal,idchar,is_done
+ parameter (king=0,idint=1105,idreal=1729,idchar=1597,is_done=1)
+ integer me,cg_rank,fg_rank,fg_rank1,nodes,Nprocs,nfgtasks,kolor,
+ & koniec(0:maxprocs-1),WhatsUp,ifinish(maxprocs-1),CG_COMM,FG_COMM,
+ & FG_COMM1,CONT_FROM_COMM,CONT_TO_COMM,lentyp(0:maxprocs-1),
+ & kolor1,key1,nfgtasks1,MyRank,
+ & max_gs_size
+ logical yourjob, finished, cgdone
+ common/setup/me,MyRank,cg_rank,fg_rank,fg_rank1,nodes,Nprocs,
+ & nfgtasks,nfgtasks1,
+ & max_gs_size,kolor,koniec,WhatsUp,ifinish,CG_COMM,FG_COMM,
+ & FG_COMM1,CONT_FROM_COMM,CONT_TO_COMM,lentyp
+ integer MPI_UYZ,MPI_UYZGRAD,MPI_MU,MPI_MAT1,MPI_MAT2,
+ & MPI_THET,MPI_GAM,
+ & MPI_ROTAT1(0:1),MPI_ROTAT2(0:1),MPI_ROTAT_OLD(0:1),
+ & MPI_PRECOMP11(0:1),MPI_PRECOMP12(0:1),MPI_PRECOMP22(0:1),
+ & MPI_PRECOMP23(0:1)
+ common /types/ MPI_UYZ,MPI_UYZGRAD,MPI_MU,MPI_MAT1,MPI_MAT2,
+ & MPI_THET,MPI_GAM,
+ & MPI_ROTAT1,MPI_ROTAT2,MPI_ROTAT_OLD,MPI_PRECOMP11,MPI_PRECOMP12,
+ & MPI_PRECOMP22,MPI_PRECOMP23
--- /dev/null
+ 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
--- /dev/null
+ integer ndih_constr,idih_constr(maxdih_constr),ntheta_constr,
+ & itheta_constr(maxdih_constr)
+ integer ndih_nconstr,idih_nconstr(maxdih_constr)
+ integer idihconstr_start,idihconstr_end,ithetaconstr_start,
+ & ithetaconstr_end
+ logical raw_psipred
+ double precision phi0(maxdih_constr),drange(maxdih_constr),
+ & ftors(maxdih_constr),theta_constr0(maxdih_constr),
+ & theta_drange(maxdih_constr),for_thet_constr(maxdih_constr),
+ & vpsipred(3,maxdih_constr),sdihed(2,maxdih_constr),
+ & phibound(2,maxres),wdihc
+ common /torcnstr/ phi0,drange,ftors,theta_constr0,theta_drange,
+ & for_thet_constr,vpsipred,sdihed,phibound,wdihc,
+ & ndih_constr,idih_constr,
+ & ndih_nconstr,idih_nconstr,idihconstr_start,idihconstr_end,
+ & ntheta_constr,itheta_constr,ithetaconstr_start,
+ & ithetaconstr_end,raw_psipred
--- /dev/null
+C Torsional constants of the rotation about virtual-bond dihedral angles
+ double precision v1,v2,vlor1,vlor2,vlor3,v0,v1_kcc,v2_kcc,
+ & v11_chyb,v21_chyb,v12_chyb,v22_chyb,v1bend_chyb
+ integer itortyp,ntortyp,nterm,nlor,nterm_old,nterm_kcc_Tb,
+ & nterm_kcc,itortyp_kcc,nbend_kcc_Tb
+ common/torsion/v0(-maxtor:maxtor,-maxtor:maxtor,2),
+ & v1(maxterm,-maxtor:maxtor,-maxtor:maxtor,2),
+ & v2(maxterm,-maxtor:maxtor,-maxtor:maxtor,2),
+ & vlor1(maxlor,-maxtor:maxtor,-maxtor:maxtor),
+ & vlor2(maxlor,maxtor,maxtor),vlor3(maxlor,maxtor,maxtor),
+ & v1_kcc(maxval_kcc,maxval_kcc,maxtor_kcc,
+ & -maxtor:maxtor,-maxtor:maxtor),
+ & v2_kcc(maxval_kcc,maxval_kcc,maxtor_kcc,
+ & -maxtor:maxtor,-maxtor:maxtor),
+ & v1bend_chyb(0:maxang_kcc,-maxtor:maxtor),
+ & itortyp(-ntyp1:ntyp1),ntortyp,
+ & itortyp_kcc(-ntyp1:ntyp1),
+ & nterm(-maxtor:maxtor,-maxtor:maxtor,2),
+ & nlor(-maxtor:maxtor,-maxtor:maxtor,2),
+ & nterm_kcc_Tb(-maxtor:maxtor,-maxtor:maxtor),
+ & nterm_kcc(-maxtor:maxtor,-maxtor:maxtor),
+ & nbend_kcc_Tb(-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:maxtor,-maxtor:maxtor,2),
+ &v1s(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2),
+ &v2c(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor,
+ & -maxtor:maxtor,2),
+ &v2s(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor,
+ & -maxtor:maxtor,2),
+ & ntermd_1(-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2),
+ & ntermd_2(-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2)
+C 9/18/99 - added Fourier coeffficients of the expansion of local energy
+C surface
+ double precision b1,b2,cc,dd,ee,ctilde,dtilde,b2tilde,b1tilde,
+ & b,bnew1,bnew2,ccold,ddold,ccnew,ddnew,eenew,e0new,gtb1,gtb2,
+ & eeold,gtcc,gtdd,gtee,
+ & bnew1tor,bnew2tor,ccnewtor,ddnewtor,eenewtor,e0newtor
+ integer nloctyp,iloctyp(-ntyp1:ntyp1),itype2loc(-ntyp1:ntyp1)
+ logical SPLIT_FOURIERTOR
+ common/fourier/ b1(2,maxres),b2(2,maxres),b(13,-ntyp:ntyp),
+ & bnew1(3,2,-ntyp:ntyp),bnew2(3,2,-ntyp:ntyp),
+ & ccnew(3,2,-ntyp:ntyp),ddnew(3,2,-ntyp:ntyp),
+ & bnew1tor(3,2,-ntyp:ntyp),bnew2tor(3,2,-ntyp:ntyp),
+ & ccnewtor(3,2,-ntyp:ntyp),ddnewtor(3,2,-ntyp:ntyp),
+ & ccold(2,2,-ntyp:ntyp),ddold(2,2,-ntyp:ntyp),
+ & cc(2,2,maxres),
+ & dd(2,2,maxres),eeold(2,2,-ntyp:ntyp),
+ & e0new(3,-ntyp:ntyp),eenew(2,2,2,-ntyp:ntyp),
+ & e0newtor(3,-ntyp:ntyp),eenewtor(2,2,2,-ntyp:ntyp),
+ & ee(2,2,maxres),
+ & ctilde(2,2,maxres),
+ & dtilde(2,2,maxres),b1tilde(2,maxres),
+ & b2tilde(2,maxres),
+ & gtb1(2,maxres),gtb2(2,maxres),gtCC(2,2,maxres),
+ & gtDD(2,2,maxres),gtEE(2,2,maxres),
+ & nloctyp,iloctyp,itype2loc,SPLIT_FOURIERTOR
--- /dev/null
+C Torsional constants of the rotation about virtual-bond dihedral angles
+ double precision v1,v2,vlor1,vlor2,vlor3,v0,v1_kcc,v2_kcc,
+ & v11_chyb,v21_chyb,v12_chyb,v22_chyb,v1bend_chyb
+ integer itortyp,ntortyp,nterm,nlor,nterm_old,nterm_kcc_Tb,
+ & nterm_kcc,itortyp_kcc,nbend_kcc_Tb
+ common/torsion/v0(-maxtor:maxtor,-maxtor:maxtor,2),
+ & v1(maxterm,-maxtor:maxtor,-maxtor:maxtor,2),
+ & v2(maxterm,-maxtor:maxtor,-maxtor:maxtor,2),
+ & vlor1(maxlor,-maxtor:maxtor,-maxtor:maxtor),
+ & vlor2(maxlor,maxtor,maxtor),vlor3(maxlor,maxtor,maxtor),
+ & v1_kcc(maxval_kcc,maxval_kcc,maxtor_kcc,
+ & -maxtor:maxtor,-maxtor:maxtor),
+ & v2_kcc(maxval_kcc,maxval_kcc,maxtor_kcc,
+ & -maxtor:maxtor,-maxtor:maxtor),
+ & v1bend_chyb(0:maxang_kcc,-maxtor:maxtor),
+ & itortyp(-ntyp1:ntyp1),ntortyp,
+ & itortyp_kcc(-ntyp1:ntyp1),
+ & nterm(-maxtor:maxtor,-maxtor:maxtor,2),
+ & nlor(-maxtor:maxtor,-maxtor:maxtor,2),
+ & nterm_kcc_Tb(-maxtor:maxtor,-maxtor:maxtor),
+ & nterm_kcc(-maxtor:maxtor,-maxtor:maxtor),
+ & nbend_kcc_Tb(-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:maxtor,-maxtor:maxtor,2),
+ &v1s(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2),
+ &v2c(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor,
+ & -maxtor:maxtor,2),
+ &v2s(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor,
+ & -maxtor:maxtor,2),
+ & ntermd_1(-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2),
+ & ntermd_2(-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2)
+C 9/18/99 - added Fourier coeffficients of the expansion of local energy
+C surface
+ double precision b1,b2,cc,dd,ee,ctilde,dtilde,b2tilde,b1tilde,
+ & b,bnew1,bnew2,ccold,ddold,ccnew,ddnew,eenew,e0new,gtb1,gtb2,
+ & eeold,gtcc,gtdd,gtee
+ integer nloctyp,iloctyp(-ntyp1:ntyp1),itype2loc(-ntyp1:ntyp1)
+ common/fourier/ b1(2,maxres),b2(2,maxres),b(13,-ntyp:ntyp),
+ & bnew1(3,2,-ntyp:ntyp),bnew2(3,2,-ntyp:ntyp),
+ & ccnew(3,2,-ntyp:ntyp),ddnew(3,2,-ntyp:ntyp),
+ & ccold(2,2,-ntyp:ntyp),ddold(2,2,-ntyp:ntyp),
+ & cc(2,2,maxres),
+ & dd(2,2,maxres),eeold(2,2,-ntyp:ntyp),
+ & e0new(3,-ntyp:ntyp),eenew(2,2,2,-ntyp:ntyp),
+ & ee(2,2,maxres),
+ & ctilde(2,2,maxres),
+ & dtilde(2,2,maxres),b1tilde(2,maxres),
+ & b2tilde(2,maxres),
+ & gtb1(2,maxres),gtb2(2,maxres),gtCC(2,2,maxres),
+ & gtDD(2,2,maxres),gtEE(2,2,maxres),
+ & nloctyp,iloctyp,itype2loc
--- /dev/null
+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,-maxtor:maxtor,2),
+ & v1(maxterm,-maxtor:maxtor,-maxtor:maxtor,2),
+ & v2(maxterm,-maxtor:maxtor,-maxtor:maxtor,2),
+ & vlor1(maxlor,-maxtor:maxtor,-maxtor:maxtor),
+ & vlor2(maxlor,maxtor,maxtor),vlor3(maxlor,maxtor,maxtor),
+ & itortyp(-ntyp:ntyp),ntortyp,
+ & nterm(-maxtor:maxtor,-maxtor:maxtor,2),
+ & nlor(-maxtor:maxtor,-maxtor:maxtor,2)
+ & ,nterm_old
+C 6/23/01 - constants for double torsionals
+ double precision v1c,v1s,v2c,v2s
+ integer ntermd_1,ntermd_2
+ common /torsiond/
+ &v1c(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2),
+ &v1s(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2),
+ &v2c(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor,
+ & -maxtor:maxtor,2),
+ &v2s(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor,
+ & -maxtor:maxtor,2),
+ & ntermd_1(-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2),
+ & ntermd_2(-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2)
+C 9/18/99 - added Fourier coeffficients of the expansion of local energy
+C surface
+ double precision b1,b2,cc,dd,ee,ctilde,dtilde,b2tilde,b1tilde
+ integer nloctyp
+ common/fourier/ b1(2,-maxtor:maxtor),b2(2,-maxtor:maxtor)
+ & ,cc(2,2,-maxtor:maxtor),
+ & dd(2,2,-maxtor:maxtor),ee(2,2,-maxtor:maxtor),
+ & ctilde(2,2,-maxtor:maxtor),
+ & dtilde(2,2,-maxtor:maxtor),b1tilde(2,-maxtor:maxtor),nloctyp
+ double precision b
+ common /fourier1/ b(13,0:maxtor)
--- /dev/null
+ common /vectors/ uy(3,maxres),uz(3,maxres),
+ & uygrad(3,3,2,maxres),uzgrad(3,3,2,maxres)
+
--- /dev/null
+ 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:ntyp,2),epscp_up(0:ntyp,2),rscp_low(0:ntyp,2),
+ & rscp_up(0:ntyp,2),epss_low(ntyp),epss_up(ntyp),epsp_low(nntyp),
+ & epsp_up(nntyp),
+ & xm(max_paropt,0:maxprot),xm1(max_paropt,0:maxprot),
+ & xm2(max_paropt,0:maxprot),
+ & imask(max_ene),nsingle_sc,npair_sc,ityp_ssc(ntyp),
+ & ityp_psc(2,nntyp),mask_elec(2,2,4),
+ & mask_fourier(13,3),
+ & mask_scp(0:ntyp,2,2),mod_other_params,mod_fourier(0:3),
+ & mod_elec,mod_scp,mod_side,indz(maxbatch+1,maxprot),iw(max_ene)
--- /dev/null
+ 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"
+ include "COMMON.TORCNSTR"
+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 Lipidic input file for parameters range 60-79
+ iliptranpar=60
+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_lip(i,j)=0.0D0
+ bb_lip(i,j)=0.0D0
+ aa_aq(i,j)=0.0D0
+ bb_aq(i,j)=0.0D0
+ augm(i,j)=0.0D0
+ sigma(i,j)=0.0D0
+ r0(i,j)=0.0D0
+ 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
+ do ichir1=-1,1
+ do ichir2=-1,1
+ athet(j,i,ichir1,ichir2)=0.0D0
+ bthet(j,i,ichir1,ichir2)=0.0D0
+ enddo
+ enddo
+ enddo
+ do j=0,3
+ polthet(j,i)=0.0D0
+ 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=-maxtor,maxtor
+ itortyp(i)=0
+ do iblock=1,2
+ do j=-maxtor,maxtor
+ do k=1,maxterm
+ v1(k,j,i,iblock)=0.0D0
+ v2(k,j,i,iblock)=0.0D0
+ enddo
+ enddo
+ enddo
+ enddo
+ do iblock=1,2
+ do i=-maxtor,maxtor
+ do j=-maxtor,maxtor
+ do k=-maxtor,maxtor
+ do l=1,maxtermd_1
+ v1c(1,l,i,j,k,iblock)=0.0D0
+ v1s(1,l,i,j,k,iblock)=0.0D0
+ v1c(2,l,i,j,k,iblock)=0.0D0
+ v1s(2,l,i,j,k,iblock)=0.0D0
+ enddo !l
+ do l=1,maxtermd_2
+ do m=1,maxtermd_2
+ v2c(m,l,i,j,k,iblock)=0.0D0
+ v2s(m,l,i,j,k,iblock)=0.0D0
+ enddo !m
+ enddo !l
+ enddo !k
+ enddo !j
+ enddo !i
+ enddo !iblock
+ do i=1,maxres
+ itype(i)=0
+ itel(i)=0
+ 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
+ dyn_ss_mask(i)=.false.
+ 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.SHIELD'
+ data restyp /
+ &'DD','DAU','DAI','DDB','DSM','DPR','DLY','DAR','DHI','DAS','DGL',
+ & 'DSG','DGN','DSN','DTH',
+ &'DYY','DAL','DTY','DTR','DVA','DLE','DIL','DPN','MED','DCY','ZER',
+ &'CYS','MET','PHE','ILE','LEU','VAL','TRP','TYR','ALA','GLY','THR',
+ &'SER','GLN','ASN','GLU','ASP','HIS','ARG','LYS','PRO','SME','DBZ',
+ &'AIB','ABU','D'/
+ data onelet /
+ &'z','z','z','z','z','p','k','r','h','d','e','n','q','s','t','g',
+ &'a','y','w','v','l','i','f','m','c','x',
+ &'C','M','F','I','L','V','W','Y','A','G','T',
+ &'S','Q','N','E','D','H','R','K','P','z','z','z','z','X'/
+ data potname /'LJ','LJK','BP','GB','GBV'/
+ data ename /
+ 1 "ESC-SC",
+ 2 "ESC-p",
+ 3 "Ep-p(el)",
+ 4 "ECORR4 ",
+ 5 "ECORR5 ",
+ 6 "ECORR6 ",
+ 7 "ECORR3 ",
+ 8 "ETURN3 ",
+ 9 "ETURN4 ",
+ @ "ETURN6 ",
+ 1 "Ebend",
+ 2 "ESCloc",
+ 3 "ETORS ",
+ 4 "ETORSD ",
+ 5 "Edist",
+ 6 "Epp(VDW)",
+ 7 "EVDW2_14",
+ 8 "Ebond",
+ 9 "ESCcor",
+ @ "EDIHC",
+ 1 "EVDW_T",
+ 2 "ELIPTRAN",
+ 3 "EAFM",
+ 4 "ETHETC",
+ 5 "ESHIELD",
+ 6 "ESAXS",
+ 7 "EHOMO",
+ 8 "EDFADIS",
+ 9 "EDFATOR",
+ @ "EDFANEI",
+ 1 "EDFABET"/
+ data wname /
+! 1 2 3 4 5 6 7
+ & "WSC ","WSCP ","WELEC","WCORR","WCORR5","WCORR6","WEL_LOC",
+! 8 9 10 11 12 13 14
+ & "WTURN3","WTURN4","WTURN6","WANG","WSCLOC","WTOR ","WTORD",
+! 15 16 17 18 19 20 21
+ & "WHPB ","WVDWPP","WSCP14","WBOND","WSCCOR","WDIHC","WSC",
+! 22 23 24 25 26 27 28
+ & "WLIPTRAN","WAFM","WTHETC","WSHIELD","WSAXS","WHOMO","WDFAD",
+! 29 30 31
+ & "WDFAT","WDFAN","WDFAB"/
+ data ww0 /
+ 1 1.0d0, ! WSC
+ 2 1.0d0, ! WSCP
+ 3 1.0d0, ! WELEC
+ 4 0.0d0, ! WCORR
+ 5 0.0d0, ! WCORR5
+ 6 0.0d0, ! WCORR6
+ 7 1.0d0, ! WEL_LOC
+ 8 1.0d0, ! WTURN3
+ 9 1.0d0, ! WTURN4
+ @ 0.0d0, ! WTURN6
+ 1 1.0d0, ! WANG
+ 2 1.0d0, ! WSCLOC
+ 3 1.0d0, ! WTOR
+ 4 1.0d0, ! WTORD
+ 5 1.0d0, ! WHPB
+ 6 1.0d0, ! WVDWPP
+ 7 0.4d0, ! WSCP14
+ 8 1.0d0, ! WBOND
+ 9 1.0d0, ! WSCCOR
+ @ 0.0d0, ! WDIHC
+ 1 0.0d0, ! WSC_T
+ 2 0.0d0, ! WLIPTRAN
+ 3 0.0d0, ! WAFM
+ 4 0.0d0, ! WTHETC
+ 5 0.0d0, ! WSHIELD
+ 6 0.0d0, ! WSAXS
+ 7 0.0d0, ! WHOMO
+ 8 0.0d0, ! WDFADIS
+ 9 0.0d0, ! WDFATOR
+ @ 0.0d0, ! WDFANEI
+ 1 0.0d0 ! WDFABET
+ & /
+#ifdef DFA
+#if defined(SCP14) && defined(SPLITELE)
+ data nprint_ene /31/
+ data print_order/1,2,18,3,16,17,11,12,13,14,4,5,6,7,8,9,10,21,19,
+ & 24,15,26,27,28,29,30,31,22,23,25,20/
+#elif defined(SCP14)
+ data nprint_ene /30/
+ data print_order/1,2,18,3,17,11,12,13,14,4,5,6,7,8,9,10,21,19,
+ & 24,15,26,27,28,29,30,31,22,23,25,20,0/
+#elif defined(SPLITELE)
+ data nprint_ene /30/
+ data print_order/1,2,3,16,17,11,12,13,14,4,5,6,7,8,9,10,21,19,
+ & 24,15,26,27,28,29,30,31,22,23,25,20,0/
+#else
+ data nprint_ene /29/
+ data print_order/1,2,3,16,17,11,12,13,14,4,5,6,7,8,9,10,21,19,
+ & 24,15,26,27,28,29,30,31,22,23,25,20,2*0/
+#endif
+#else
+#if defined(SCP14) && defined(SPLITELE)
+ data nprint_ene /27/
+ data print_order/1,2,18,3,16,17,11,12,13,14,4,5,6,7,8,9,10,21,19,
+ & 24,15,26,27,22,23,25,20,4*0/
+#elif defined(SCP14)
+ data nprint_ene /26/
+ data print_order/1,2,18,3,17,11,12,13,14,4,5,6,7,8,9,10,21,19,
+ & 24,15,26,27,22,23,25,20,5*0/
+#elif defined(SPLITELE)
+ data nprint_ene /26/
+ data print_order/1,2,3,16,17,11,12,13,14,4,5,6,7,8,9,10,21,19,
+ & 24,15,26,27,22,23,25,20,5*0/
+#else
+ data nprint_ene /25/
+ data print_order/1,2,3,16,17,11,12,13,14,4,5,6,7,8,9,10,21,19,
+ & 24,15,26,27,22,23,25,20,6*0/
+#endif
+#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'
+ include "COMMON.TORCNSTR"
+ logical scheck,lprint
+ 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.
+ if (dyn_ss) goto 10
+ 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
+ nint_gr(i)=1
+ istart(i,1)=i+2
+ iend(i,1)=nct
+ else if (jj.eq.nct) then
+ nint_gr(i)=1
+ istart(i,1)=i+1
+ iend(i,1)=nct-1
+ 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
+ else
+ nint_gr(i)=1
+ istart(i,1)=i+1
+ iend(i,1)=nct
+ ind_scint=int_scint+nct-i
+ endif
+ enddo
+ 12 continue
+ iatsc_s=nnt
+ iatsc_e=nct-1
+ 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
+ iatel_s=nnt
+ iatel_e=nct-3
+ do i=iatel_s,iatel_e
+ ielstart(i)=i+4
+ ielend(i)=nct-1
+ enddo
+ 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
+ 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
+ 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
+ loc_start=2
+ loc_end=nres-1
+ ithet_start=3
+ ithet_end=nres
+ iturn3_start=nnt
+ iturn3_end=nct-3
+ iturn4_start=nnt
+ iturn4_end=nct-4
+ iphi_start=nnt+3
+ iphi_end=nct
+ idihconstr_start=1
+ idihconstr_end=ndih_constr
+ ithetaconstr_start=1
+ ithetaconstr_end=ntheta_constr
+ itau_start=4
+ itau_end=nres
+ 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'
+ link_start=1
+ link_end=nhpb
+ link_start_peak=1
+ link_end_peak=npeak
+ write (iout,*) 'HPB_PARTITION',
+ & ' nhpb',nhpb,' link_start=',link_start,
+ & ' link_end',link_end,' link_start_peak',link_start_peak,
+ & ' link_end_peak',link_end_peak
+ return
+ end
+c------------------------------------------------------------------------------
+ subroutine homology_partition
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'DIMENSIONS.FREE'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.HOMOLOGY'
+ include 'COMMON.HOMRESTR'
+ include 'COMMON.INTERACT'
+cd write(iout,*)"homology_partition: lim_odl=",lim_odl,
+cd & " lim_dih",lim_dih
+ link_start_homo=1
+ link_end_homo=lim_odl
+ idihconstr_start_homo=nnt+3
+ idihconstr_end_homo=lim_dih+nnt-1+3
+ write (iout,*)
+ & ' lim_odl',lim_odl,' link_start=',link_start_homo,
+ & ' link_end',link_end_homo,' lim_dih',lim_dih,
+ & ' idihconstr_start_homo',idihconstr_start_homo,
+ & ' idihconstr_end_homo',idihconstr_end_homo
+ return
+ end
+
--- /dev/null
+ 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
--- /dev/null
+ 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
--- /dev/null
+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
--- /dev/null
+ integer function iperm(ires,ipermut)
+ implicit none
+ include "DIMENSIONS"
+ include "COMMON.CHAIN"
+ integer ipermut,ires,ii,iii
+ integer tperm
+ ii=ireschain(ires)
+ if (ii.eq.0) then
+ iperm=ires
+ else
+ iii=tabpermchain(ii,ipermut)
+ iperm=chain_border(1,iii)+ires-chain_border(1,ii)
+ endif
+ return
+ end
--- /dev/null
+ 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.HOMOLOGY"
+ 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,eliptran,esaxs,
+ & ehpb,ecorr,ecorr5,ecorr6,eello_turn4,eello_turn3,
+ & eturn6,eel_loc,edihcnstr,etors_d,estr,evdw2_14,esccor,tt,
+ & ehomology_constr,edfadis,edfator,edfanei,edfabet
+ 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),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)
+ eliptran=enetb(22,i,iparm)
+ esaxs=enetb(26,i,iparm)
+ ehomology_constr=enetb(27,i,iparm)
+ edfadis=enetb(28,i,iparm)
+ edfator=enetb(29,i,iparm)
+ edfanei=enetb(30,i,iparm)
+ edfabet=enetb(31,i,iparm)
+ if (homol_nset.gt.1)
+ & ehomology_constr=waga_homology(homol_nset)*ehomology_constr
+#ifdef SPLITELE
+ if (shield_mode.gt.0) then
+ etot=ft(1)*wsc*(evdw+ft(6)*evdw_t)+ft(1)*wscp*evdw2
+ & +ft(1)*welec*ees
+ & +ft(1)*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+wliptran*eliptran+wsaxs*esaxs
+ & +ehomology_constr
+ & +wdfa_dist*edfadis
+ & +wdfa_tor*edfator+wdfa_nei*edfanei+wdfa_beta*edfabet
+ else
+ 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+wliptran*eliptran+wsaxs*esaxs
+ & +ehomology_constr
+ & +wdfa_dist*edfadis
+ & +wdfa_tor*edfator+wdfa_nei*edfanei+wdfa_beta*edfabet
+ endif
+#else
+ if (shield_mode.gt.0) then
+ etot=ft(1)*wsc*(evdw+ft(6)*evdw_t)+ft(1)*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+wliptran*eliptran+wsaxs*esaxs
+ & +ehomology_constr
+ & +wdfa_dist*edfadis
+ & +wdfa_tor*edfator+wdfa_nei*edfanei+wdfa_beta*edfabet
+ 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+wliptran*eliptran+wsaxs*esaxs
+ & +ehomology_constr
+ & +wdfa_dist*edfadis
+ & +wdfa_tor*edfator+wdfa_nei*edfanei+wdfa_beta*edfabet
+ endif
+#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)
+ write (iout,*) "Before reading nlist",nlist
+ 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
--- /dev/null
+ 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,ipermmin,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,ipermmin
+ 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,ipermmin,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,ipermmin,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,ipermmin,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,ipermmin,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,ipermmin,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,ipermmin,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,ipermmin,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,ipermmin,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,ipermmin,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,ipermmin,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,ipermmin,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,ipermmin,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,ipermmin,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,ipermmin,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),ipermmin,iperm
+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) then
+ write (iout,'(80(1h*))')
+ write (iout,*) "ncont_match"
+ write (iout,*) "ipermmin",ipermmin
+ write (iout,'(80(1h*))')
+ endif
+ 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,
+ & ipermmin,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
+c write (iout,*) "i",i," icont",icont(1,i),icont(2,i)
+ 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,ipermmin,lprn)
+ 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,ipermmin,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),ipermmin,iperm
+ 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(iperm(j,ipermmin)).eq.isec_ref(j) .or.
+c & isecstr(j).eq.0 .and. isec_ref(j).eq.1 .or.
+ & isec_ref(j).eq.0 .and. isecstr(iperm(j,ipermmin)).eq.1)
+ & nsec_match=nsec_match+1
+ enddo
+ enddo
+ return
+ end
--- /dev/null
+ 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
--- /dev/null
+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
--- /dev/null
+ 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'
+ include 'COMMON.SAXS'
+ character*4 sequence(maxres)
+ integer rescode,tperm
+ double precision x(maxvar)
+ character*320 controlcard,ucase
+ dimension itype_pdb(maxres)
+ logical seq_comp
+ double precision secprob(3,maxdih_constr),phihel,phibet
+ call card_concat(controlcard,.true.)
+ 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.ntyp1 .or. itype(i+1).eq.ntyp1) then
+#else
+ if (itype(i).eq.ntyp1) then
+#endif
+ itel(i)=0
+#ifdef PROCOR
+ else if (iabs(itype(i+1)).ne.20) then
+#else
+ else if (iabs(itype(i)).ne.20) then
+#endif
+ itel(i)=1
+ else
+ itel(i)=2
+ endif
+ enddo
+ write (iout,*) "ITEL"
+ do i=1,nres-1
+ write (iout,*) i,itype(i),itel(i)
+ enddo
+ call read_bridge
+ nnt=1
+ nct=nres
+ call seq2chains(nres,itype,nchain,chain_length,chain_border,
+ & ireschain)
+ write(iout,*) "nres",nres," nchain",nchain
+ do i=1,nchain
+ write(iout,*)"chain",i,chain_length(i),chain_border(1,i),
+ & chain_border(2,i)
+ enddo
+ call chain_symmetry(nchain,nres,itype,chain_border,
+ & chain_length,npermchain,tabpermchain)
+ write(iout,*) "ireschain permutations"
+ do i=1,nres
+ write(iout,*) i,(tperm(ireschain(i),ii,tabpermchain),
+ & ii=1,npermchain)
+ enddo
+ write(iout,*) "residue permutations"
+ do i=1,nres
+ write(iout,*) i,(iperm(i,ii),ii=1,npermchain)
+ enddo
+
+ if (itype(1).eq.ntyp1) nnt=2
+ if (itype(nres).eq.ntyp1) nct=nct-1
+ write(iout,*) 'NNT=',NNT,' NCT=',NCT
+ if (with_dihed_constr) then
+
+ read (inp,*) ndih_constr
+ write (iout,*) "ndih_constr",ndih_constr
+ if (ndih_constr.gt.0) then
+ raw_psipred=.false.
+C read (inp,*) ftors
+C write (iout,*) 'FTORS',ftors
+ read (inp,*) (idih_constr(i),phi0(i),drange(i),ftors(i),
+ & i=1,ndih_constr)
+ write (iout,*)
+ & 'There are',ndih_constr,' restraints on gamma angles.'
+ do i=1,ndih_constr
+ write (iout,'(i5,3f8.3)') idih_constr(i),phi0(i),drange(i),
+ & ftors(i)
+ enddo
+ do i=1,ndih_constr
+ phi0(i)=deg2rad*phi0(i)
+ drange(i)=deg2rad*drange(i)
+ enddo
+ else if (ndih_constr.lt.0) then
+ raw_psipred=.true.
+ call card_concat(controlcard,.true.)
+ call reada(controlcard,"PHIHEL",phihel,50.0D0)
+ call reada(controlcard,"PHIBET",phibet,180.0D0)
+ call reada(controlcard,"SIGMAHEL",sigmahel,30.0d0)
+ call reada(controlcard,"SIGMABET",sigmabet,40.0d0)
+ call reada(controlcard,"WDIHC",wdihc,0.591d0)
+ write (iout,*) "Weight of the dihedral restraint term",wdihc
+ read(inp,'(9x,3f7.3)')
+ & (secprob(1,i),secprob(2,i),secprob(3,i),i=nnt,nct)
+ write (iout,*) "The secprob array"
+ do i=nnt,nct
+ write (iout,'(i5,3f8.3)') i,(secprob(j,i),j=1,3)
+ enddo
+ ndih_constr=0
+ do i=nnt+3,nct
+ if (itype(i-3).ne.ntyp1 .and. itype(i-2).ne.ntyp1
+ & .and. itype(i-1).ne.ntyp1 .and. itype(i).ne.ntyp1) then
+ ndih_constr=ndih_constr+1
+ idih_constr(ndih_constr)=i
+ sumv=0.0d0
+ do j=1,3
+ vpsipred(j,ndih_constr)=secprob(j,i-1)*secprob(j,i-2)
+ sumv=sumv+vpsipred(j,ndih_constr)
+ enddo
+ do j=1,3
+ vpsipred(j,ndih_constr)=vpsipred(j,ndih_constr)/sumv
+ enddo
+ phibound(1,ndih_constr)=phihel*deg2rad
+ phibound(2,ndih_constr)=phibet*deg2rad
+ sdihed(1,ndih_constr)=sigmahel*deg2rad
+ sdihed(2,ndih_constr)=sigmabet*deg2rad
+ endif
+ enddo
+ write (iout,*)
+ & 'There are',ndih_constr,
+ & ' bimodal restraints on gamma angles.'
+ do i=1,ndih_constr
+ write(iout,'(i5,1x,a4,i5,1h-,a4,i5,4f8.3,3f10.5)') i,
+ & restyp(itype(idih_constr(i)-2)),idih_constr(i)-2,
+ & restyp(itype(idih_constr(i)-1)),idih_constr(i)-1,
+ & phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,
+ & phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
+ & (vpsipred(j,i),j=1,3)
+ enddo
+
+ endif
+
+ endif
+ if (with_theta_constr) then
+C with_theta_constr is keyword allowing for occurance of theta constrains
+ read (inp,*) ntheta_constr
+C ntheta_constr is the number of theta constrains
+ if (ntheta_constr.gt.0) then
+C read (inp,*) ftors
+ read (inp,*) (itheta_constr(i),theta_constr0(i),
+ & theta_drange(i),for_thet_constr(i),
+ & i=1,ntheta_constr)
+C the above code reads from 1 to ntheta_constr
+C itheta_constr(i) residue i for which is theta_constr
+C theta_constr0 the global minimum value
+C theta_drange is range for which there is no energy penalty
+C for_thet_constr is the force constant for quartic energy penalty
+C E=k*x**4
+C if(me.eq.king.or..not.out1file)then
+ write (iout,*)
+ & 'There are',ntheta_constr,' constraints on phi angles.'
+ do i=1,ntheta_constr
+ write (iout,'(i5,3f8.3)') itheta_constr(i),theta_constr0(i),
+ & theta_drange(i),
+ & for_thet_constr(i)
+ enddo
+C endif
+ do i=1,ntheta_constr
+ theta_constr0(i)=deg2rad*theta_constr0(i)
+ theta_drange(i)=deg2rad*theta_drange(i)
+ enddo
+C if(me.eq.king.or..not.out1file)
+C & write (iout,*) 'FTORS',ftors
+C do i=1,ntheta_constr
+C ii = itheta_constr(i)
+C thetabound(1,ii) = phi0(i)-drange(i)
+C thetabound(2,ii) = phi0(i)+drange(i)
+C enddo
+ endif ! ntheta_constr.gt.0
+ endif! with_theta_constr
+ if (constr_homology.gt.0) then
+c write (iout,*) "About to call read_constr_homology"
+c call flush(iout)
+ call read_constr_homology
+c write (iout,*) "Exit read_constr_homology"
+c call flush(iout)
+ if (indpdb.gt.0 .or. pdbref) then
+ do i=1,2*nres
+ do j=1,3
+ c(j,i)=crefjlee(j,i)
+ cref(j,i)=crefjlee(j,i)
+ enddo
+ enddo
+ endif
+#ifdef DEBUG
+ write (iout,*) "Array C"
+ do i=1,nres
+ write (iout,'(i5,3f8.3,5x,3f8.3)') i,(c(j,i),j=1,3),
+ & (c(j,i+nres),j=1,3)
+ enddo
+ write (iout,*) "Array Cref"
+ do i=1,nres
+ write (iout,'(i5,3f8.3,5x,3f8.3)') i,(cref(j,i),j=1,3),
+ & (cref(j,i+nres),j=1,3)
+ enddo
+#endif
+#ifdef DEBUG
+ call int_from_cart1(.false.)
+ call sc_loc_geom(.false.)
+ do i=1,nres
+ thetaref(i)=theta(i)
+ phiref(i)=phi(i)
+ write (iout,*) i," phiref",phiref(i)," thetaref",thetaref(i)
+ 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=2,nres-1
+ 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
+#endif
+ else
+ homol_nset=0
+ endif
+
+ call setup_var
+ call init_int_table
+ if (ns.gt.0) then
+ write (iout,'(/a,i3,a)') 'The chain contains',ns,
+ & ' disulfide-bridging cysteines.'
+ write (iout,'(20i4)') (iss(i),i=1,ns)
+ if (dyn_ss) then
+ write(iout,*)"Running with dynamic disulfide-bond formation"
+ else
+ write (iout,'(/a/)') 'Pre-formed links are:'
+ do i=1,nss
+ i1=ihpb(i)-nres
+ 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
+ endif
+ write (iout,'(a)')
+ if (ns.gt.0.and.dyn_ss) then
+ do i=nss+1,nhpb
+ ihpb(i-nss)=ihpb(i)
+ jhpb(i-nss)=jhpb(i)
+ forcon(i-nss)=forcon(i)
+ dhpb(i-nss)=dhpb(i)
+ enddo
+ nhpb=nhpb-nss
+ nss=0
+ call hpb_partition
+ do i=1,ns
+ dyn_ss_mask(iss(i))=.true.
+ enddo
+ endif
+ write (iout,*) "calling read_saxs_consrtr",nsaxs
+ if (nsaxs.gt.0) call read_saxs_constr
+
+ return
+ end
+c-----------------------------------------------------------------------------
+ logical function seq_comp(itypea,itypeb,length)
+ implicit none
+ integer length,itypea(length),itypeb(length)
+ integer i
+ do i=1,length
+ if (itypea(i).ne.itypeb(i)) then
+ seq_comp=.false.
+ return
+ endif
+ enddo
+ seq_comp=.true.
+ return
+ end
+c-----------------------------------------------------------------------------
+ subroutine read_bridge
+C Read information about disulfide bridges.
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ 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(itype(iss(i))),i,
+ & ' can form a disulfide bridge?!!!'
+ write (*,'(2a,i3,a)')
+ & 'Do you REALLY think that the residue ',
+ & restyp(itype(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_saxs_constr
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'DIMENSIONS.ZSCOPT'
+ include 'DIMENSIONS.FREE'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.CONTROL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.SAXS'
+ double precision cm(3)
+c read(inp,*) nsaxs
+ write (iout,*) "Calling read_saxs nsaxs",nsaxs
+ call flush(iout)
+ if (saxs_mode.eq.0) then
+c SAXS distance distribution
+ do i=1,nsaxs
+ read(inp,*) distsaxs(i),Psaxs(i)
+ enddo
+ Cnorm = 0.0d0
+ do i=1,nsaxs
+ Cnorm = Cnorm + Psaxs(i)
+ enddo
+ write (iout,*) "Cnorm",Cnorm
+ do i=1,nsaxs
+ Psaxs(i)=Psaxs(i)/Cnorm
+ enddo
+ write (iout,*) "Normalized distance distribution from SAXS"
+ do i=1,nsaxs
+ write (iout,'(f8.2,e15.5)') distsaxs(i),Psaxs(i)
+ enddo
+ Wsaxs0=0.0d0
+ do i=1,nsaxs
+ Wsaxs0=Wsaxs0-Psaxs(i)*dlog(Psaxs(i))
+ enddo
+ write (iout,*) "Wsaxs0",Wsaxs0
+ else
+c SAXS "spheres".
+ do i=1,nsaxs
+ read (inp,'(30x,3f8.3)') (Csaxs(j,i),j=1,3)
+ enddo
+ do j=1,3
+ cm(j)=0.0d0
+ enddo
+ do i=1,nsaxs
+ do j=1,3
+ cm(j)=cm(j)+Csaxs(j,i)
+ enddo
+ enddo
+ do j=1,3
+ cm(j)=cm(j)/nsaxs
+ enddo
+ do i=1,nsaxs
+ do j=1,3
+ Csaxs(j,i)=Csaxs(j,i)-cm(j)
+ enddo
+ enddo
+ write (iout,*) "SAXS sphere coordinates"
+ do i=1,nsaxs
+ write (iout,'(i5,3f10.5)') i,(Csaxs(j,i),j=1,3)
+ enddo
+ endif
+ return
+ end
--- /dev/null
+ 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
--- /dev/null
+ 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
--- /dev/null
+ 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
--- /dev/null
+ subroutine oligomer
+ implicit none
+ include "DIMENSIONS"
+ include "COMMON.CHAIN"
+ include "COMMON.INTERACT"
+ include "COMMON.IOUNITS"
+ integer i,ii,ipi,ipj,ipmin,j,jmin,k,ix,iy,iz,
+ & ixmin,iymin,izmin,ir_start,ir_end
+ integer iper(maxchain),iaux
+ double precision dchain,dchainmin,cmchain(3,20)
+ cmchain=0.0d0
+ do i=1,nchain
+ ii=0
+ do j=chain_border(1,i),chain_border(2,i)
+ if (itype(j).eq.ntyp1) cycle
+ ii=ii+1
+ do k=1,3
+ cmchain(k,i)=cmchain(k,i)+c(k,j)
+ enddo
+ enddo
+ do k=1,3
+ cmchain(k,i)=cmchain(k,i)/ii
+ enddo
+ enddo
+ do i=1,nchain
+ iper(i)=i
+ enddo
+ do i=1,nchain-1
+ dchainmin=1.0d10
+ do j=i+1,nchain
+ ipi=iper(i)
+ ipj=iper(j)
+ do ix=-1,1
+ do iy=-1,1
+ do iz=-1,1
+ dchain=(cmchain(1,ipj)-cmchain(1,ipi)+ix*boxxsize)**2+
+ & (cmchain(2,ipj)-cmchain(2,ipi)+iy*boxysize)**2+
+ & (cmchain(3,ipj)-cmchain(3,ipi)+iz*boxzsize)**2
+c write (iout,*) "i",i," ipi",ipi," j",j," ipj",ipj," d",
+c & dsqrt(dchain)," dmin",dsqrt(dchainmin)," jmin",jmin
+ if (dchain.lt.dchainmin) then
+ dchainmin=dchain
+ ixmin=ix
+ iymin=iy
+ izmin=iz
+ jmin=j
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ if (ixmin.eq.0 .and. iymin.eq.0 .and. izmin.eq.0) cycle
+ ipj=iper(jmin)
+ cmchain(1,ipj)=cmchain(1,ipj)+ixmin*boxxsize
+ cmchain(2,ipj)=cmchain(2,ipj)+iymin*boxysize
+ cmchain(3,ipj)=cmchain(3,ipj)+izmin*boxzsize
+ ir_start=chain_border(1,ipj)
+ if (ir_start.gt.1) ir_start=ir_start-1
+ ir_end=chain_border(2,ipj)
+ if (ir_end.lt.nres) ir_end=ir_end+1
+ do k=ir_start,ir_end
+ c(1,k)=c(1,k)+ixmin*boxxsize
+ c(2,k)=c(2,k)+iymin*boxysize
+ c(3,k)=c(3,k)+izmin*boxzsize
+ c(1,k+nres)=c(1,k+nres)+ixmin*boxxsize
+ c(2,k+nres)=c(2,k+nres)+iymin*boxysize
+ c(3,k+nres)=c(3,k+nres)+izmin*boxzsize
+ enddo
+c write (iout,*) "jmin",jmin," ipj",ipj,
+c & " ixmin",ixmin," iymin",iymin," izmin",izmin
+ iaux=iper(i+1)
+ iper(i+1)=iper(jmin)
+ iper(jmin)=iaux
+ enddo
+ return
+ end
--- /dev/null
+ 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)
+c open (ibond,file=bondname,status='old')
+ call mygetenv('THETPAR',thetname)
+c open (ithep,file=thetname,status='old')
+ call mygetenv('ROTPAR',rotname)
+c open (irotam,file=rotname,status='old')
+ call mygetenv('TORPAR',torname)
+c open (itorp,file=torname,status='old')
+ call mygetenv('TORDPAR',tordname)
+c open (itordp,file=tordname,status='old')
+ call mygetenv('FOURIER',fouriername)
+c open (ifourier,file=fouriername,status='old')
+ call mygetenv('SCCORPAR',sccorname)
+c open (isccor,file=sccorname,status='old')
+ call mygetenv('ELEPAR',elename)
+c open (ielep,file=elename,status='old')
+ call mygetenv('SIDEPAR',sidename)
+c open (isidep,file=sidename,status='old')
+ call mygetenv('SIDEP',sidepname)
+ open (isidep1,file=sidepname,status="old")
+ call mygetenv('LIPTRANPAR',liptranname)
+ open (iliptranpar,file=liptranname,status='old',action='read')
+#ifndef OLDSCP
+C
+C 8/9/01 In the newest version SCp interaction constants are read from a file
+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,*) "Lipid-transfer parameter file : ",
+ & liptranname(:ilen(liptranname))
+ write (iout,'(80(1h-))')
+ write (iout,*)
+ return
+ end
+
--- /dev/null
+ 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'
+ include 'COMMON.SHIELD'
+ include 'COMMON.CONTROL'
+ include 'COMMON.LANGEVIN'
+ character*1 t1,t2,t3
+ character*1 onelett(4) /"G","A","P","D"/
+ character*1 toronelet(-2:2) /"p","a","G","A","P"/
+ logical lprint
+ dimension blower(3,3,maxlob)
+ character*800 controlcard
+ 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
+ character*6 res1
+ character*3 lancuch,ucase
+C write (iout,*) "KURWA"
+C
+C Body
+C
+ call getenv("PRINT_PARM",lancuch)
+ lprint = (ucase(lancuch).eq."YES" .or. ucase(lancuch).eq."Y")
+C Set LPRINT=.TRUE. for debugging
+ dwa16=2.0d0**(1.0d0/6.0d0)
+ 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),ww0(i))
+ write (iout,*) i,key(:ilen(key)),ww(i)
+ enddo
+ 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
+
+ write (iout,*) "iparm",iparm," myparm",myparm
+c If reading not own parameters, skip assignment
+ call reada(controlcard,"D0CM",d0cm,3.78d0)
+ call reada(controlcard,"AKCM",akcm,15.1d0)
+ call reada(controlcard,"AKTH",akth,11.0d0)
+ call reada(controlcard,"AKCT",akct,12.0d0)
+ call reada(controlcard,"V1SS",v1ss,-1.08d0)
+ call reada(controlcard,"V2SS",v2ss,7.61d0)
+ call reada(controlcard,"V3SS",v3ss,13.7d0)
+ call reada(controlcard,"EBR",ebr,-5.50D0)
+ call reada(controlcard,"DTRISS",dtriss,1.0D0)
+ call reada(controlcard,"ATRISS",atriss,0.3D0)
+ call reada(controlcard,"BTRISS",btriss,0.02D0)
+ call reada(controlcard,"CTRISS",ctriss,1.0D0)
+ dyn_ss=(index(controlcard,'DYN_SS').gt.0)
+C do i=1,maxres
+C dyn_ss_mask(i)=.false.
+C enddo
+C ebr=-12.0D0
+c
+c Old arbitrary potential - commented out.
+c
+c dbr= 4.20D0
+c fbr= 3.30D0
+c
+c Constants of the disulfide-bond potential determined based on the RHF/6-31G**
+c energy surface of diethyl disulfide.
+c A. Liwo and U. Kozlowska, 11/24/03
+c
+ D0CM = 3.78d0
+ AKCM = 15.1d0
+ AKTH = 11.0d0
+ AKCT = 12.0d0
+ V1SS =-1.08d0
+ V2SS = 7.61d0
+ V3SS = 13.7d0
+
+ do i=1,maxres-1
+ do j=i+1,maxres
+ dyn_ssbond_ij(i,j)=1.0d300
+ enddo
+ enddo
+ call reada(controlcard,"HT",Ht,0.0D0)
+C if (dyn_ss) then
+C ss_depth=ebr/wsc-0.25*eps(1,1)
+C write(iout,*) HT,wsc,eps(1,1),'KURWA'
+C Ht=Ht/wsc-0.25*eps(1,1)
+
+C akcm=akcm*whpb/wsc
+C akth=akth*whpb/wsc
+C akct=akct*whpb/wsc
+C v1ss=v1ss*whpb/wsc
+C v2ss=v2ss*whpb/wsc
+C v3ss=v3ss*whpb/wsc
+C else
+C ss_depth=ebr/whpb-0.25*eps(1,1)*wsc/whpb
+C endif
+
+ if (iparm.eq.myparm .or. .not.separate_parset) then
+
+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)
+ wbond=ww(18)
+ wsccor=ww(19)
+ whpb=ww(15)
+ wstrain=ww(15)
+ wliptran=ww(22)
+ wshield=ww(25)
+ wsaxs=ww(26)
+c write (iout,*) "PARMREAD: wsaxs",wsaxs
+ wdfa_dist=ww(28)
+ wdfa_tor=ww(29)
+ wdfa_nei=ww(30)
+ wdfa_beta=ww(31)
+c write(iout,*)"PARMREAD: wdfa_dist",wdfa_dist," wdfa_tor",wdfa_tor,
+c & " wdfa_nei",wdfa_nei," wdfa_beta",wdfa_beta
+ endif
+
+#ifdef DFA
+C Juyong:READ init_vars
+C Initialize variables!
+C Juyong:READ read_info
+C READ fragment information!!
+C both routines should be in dfa.F file!!
+ write (iout,*) "Before initializing DFA",wdfa_dist,wdfa_tor,
+ & wdfa_nei,wdfa_beta
+ if (.not. (wdfa_dist.eq.0.0 .and. wdfa_tor.eq.0.0 .and.
+ & wdfa_nei.eq.0.0 .and. wdfa_beta.eq.0.0)) then
+ write (iout,*) "Calling init_dfa_vars"
+ call flush(iout)
+ call init_dfa_vars
+ write (iout,*) 'init_dfa_vars finished!'
+ call flush(iout)
+ call read_dfa_info
+ write (iout,*) 'read_dfa_info finished!'
+ call flush(iout)
+ endif
+#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)
+ write (iout,*) "tor_mode",tor_mode
+ call flush(iout)
+ if (tor_mode.eq.0)
+ & open (itordp,file=tordname_t,status='old')
+ rewind(itordp)
+ call reads(controlcard,"SCCORPAR",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=121,err=121) vbldp0,vbldpdum,akp,mp,ip,pstok
+ do i=1,ntyp
+ nbondterm(i)=1
+ read (ibond,*,end=121,err=121) vbldsc0(1,i),aksc(1,i),
+ & msc(i),isc(i),restok(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=121,err=121) ijunk,vbldp0,vbldpdum,akp,rjunk,
+ & mp,ip,pstok
+ do i=1,ntyp
+ read (ibond,*,end=121,err=121) nbondterm(i),(vbldsc0(j,i),
+ & aksc(j,i),abond0(j,i),j=1,nbondterm(i)),msc(i),isc(i),restok(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
+c write (iout,*) "iliptranpar",iliptranpar
+c write (iout,*) "liptranname ",liptranname
+ read(iliptranpar,*,end=1161,err=1161) pepliptran
+ do i=1,ntyp
+ read(iliptranpar,*,end=1161,err=1161) liptranene(i)
+ enddo
+ rewind iliptranpar
+ if (lprint) then
+ write (iout,'(/a)') "Water-lipid transfer parameters"
+ write (iout,'(a3,3x,f10.5)') 'p',pepliptran
+ do i=1,ntyp
+ write (iout,'(a3,3x,f10.5)') restyp(i),liptranene(i)
+ 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,1,1),j=1,2),
+ & (bthet(j,i,1,1),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
+ do i=1,ntyp
+ athet(1,i,1,-1)=athet(1,i,1,1)
+ athet(2,i,1,-1)=athet(2,i,1,1)
+ bthet(1,i,1,-1)=-bthet(1,i,1,1)
+ bthet(2,i,1,-1)=-bthet(2,i,1,1)
+ athet(1,i,-1,1)=-athet(1,i,1,1)
+ athet(2,i,-1,1)=-athet(2,i,1,1)
+ bthet(1,i,-1,1)=bthet(1,i,1,1)
+ bthet(2,i,-1,1)=bthet(2,i,1,1)
+ enddo
+ do i=-ntyp,-1
+ a0thet(i)=a0thet(-i)
+ athet(1,i,-1,-1)=athet(1,-i,1,1)
+ athet(2,i,-1,-1)=-athet(2,-i,1,1)
+ bthet(1,i,-1,-1)=bthet(1,-i,1,1)
+ bthet(2,i,-1,-1)=-bthet(2,-i,1,1)
+ athet(1,i,-1,1)=athet(1,-i,1,1)
+ athet(2,i,-1,1)=-athet(2,-i,1,1)
+ bthet(1,i,-1,1)=-bthet(1,-i,1,1)
+ bthet(2,i,-1,1)=bthet(2,-i,1,1)
+ athet(1,i,1,-1)=-athet(1,-i,1,1)
+ athet(2,i,1,-1)=athet(2,-i,1,1)
+ bthet(1,i,1,-1)=bthet(1,-i,1,1)
+ bthet(2,i,1,-1)=-bthet(2,-i,1,1)
+ theta0(i)=theta0(-i)
+ sig0(i)=sig0(-i)
+ sigc0(i)=sigc0(-i)
+ do j=0,3
+ polthet(j,i)=polthet(j,-i)
+ enddo
+ do j=1,3
+ gthet(j,i)=gthet(j,-i)
+ enddo
+ enddo
+ close (ithep)
+ if (lprint) then
+c write (iout,'(a)')
+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,1,1),j=1,2),
+ & (10*bthet(j,i,1,1),j=1,2)
+ enddo
+ write (iout,'(/a/9x,5a/79(1h-))')
+ & 'Parameters of the expression for sigma(theta_c):',
+ & ' 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
+ IF (tor_mode.eq.0) THEN
+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=-ntyp1,-1
+ ithetyp(i)=-ithetyp(-i)
+ enddo
+ do iblock=1,2
+ do i=-maxthetyp,maxthetyp
+ do j=-maxthetyp,maxthetyp
+ do k=-maxthetyp,maxthetyp
+ aa0thet(i,j,k,iblock)=0.0d0
+ do l=1,ntheterm
+ aathet(l,i,j,k,iblock)=0.0d0
+ enddo
+ do l=1,ntheterm2
+ do m=1,nsingle
+ bbthet(m,l,i,j,k,iblock)=0.0d0
+ ccthet(m,l,i,j,k,iblock)=0.0d0
+ ddthet(m,l,i,j,k,iblock)=0.0d0
+ eethet(m,l,i,j,k,iblock)=0.0d0
+ enddo
+ enddo
+ do l=1,ntheterm3
+ do m=1,ndouble
+ do mm=1,ndouble
+ ffthet(mm,m,l,i,j,k,iblock)=0.0d0
+ ggthet(mm,m,l,i,j,k,iblock)=0.0d0
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+C write (iout,*) "KURWA1"
+ do iblock=1,2
+ do i=0,nthetyp
+ do j=-nthetyp,nthetyp
+ do k=-nthetyp,nthetyp
+ read (ithep,'(6a)',end=111,err=111) res1
+ write(iout,*) res1,i,j,k
+ read (ithep,*,end=111,err=111) aa0thet(i,j,k,iblock)
+ read (ithep,*,end=111,err=111)(aathet(l,i,j,k,iblock),
+ & l=1,ntheterm)
+ read (ithep,*,end=111,err=111)
+ & ((bbthet(lll,ll,i,j,k,iblock),lll=1,nsingle),
+ & (ccthet(lll,ll,i,j,k,iblock),lll=1,nsingle),
+ & (ddthet(lll,ll,i,j,k,iblock),lll=1,nsingle),
+ & (eethet(lll,ll,i,j,k,iblock),lll=1,nsingle)
+ & ,ll=1,ntheterm2)
+ read (ithep,*,end=111,err=111)
+ & (((ffthet(llll,lll,ll,i,j,k,iblock),
+ & ffthet(lll,llll,ll,i,j,k,iblock),
+ & ggthet(llll,lll,ll,i,j,k,iblock)
+ & ,ggthet(lll,llll,ll,i,j,k,iblock),
+ & llll=1,lll-1),lll=2,ndouble),ll=1,ntheterm3)
+ enddo
+ enddo
+ enddo
+C write(iout,*) "KURWA1.1"
+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,iblock)=0.0d0
+ aathet(l,nthetyp+1,i,j,iblock)=0.0d0
+ enddo
+ aa0thet(i,j,nthetyp+1,iblock)=0.0d0
+ aa0thet(nthetyp+1,i,j,iblock)=0.0d0
+ enddo
+ do l=1,ntheterm
+ aathet(l,nthetyp+1,i,nthetyp+1,iblock)=0.0d0
+ enddo
+ aa0thet(nthetyp+1,i,nthetyp+1,iblock)=0.0d0
+ enddo
+ enddo
+C write(iout,*) "KURWA1.5"
+C Substitution for D aminoacids from symmetry.
+ do iblock=1,2
+ do i=-nthetyp,0
+ do j=-nthetyp,nthetyp
+ do k=-nthetyp,nthetyp
+ aa0thet(i,j,k,iblock)=aa0thet(-i,-j,-k,iblock)
+ do l=1,ntheterm
+ aathet(l,i,j,k,iblock)=aathet(l,-i,-j,-k,iblock)
+ enddo
+ do ll=1,ntheterm2
+ do lll=1,nsingle
+ bbthet(lll,ll,i,j,k,iblock)=bbthet(lll,ll,-i,-j,-k,iblock)
+ ccthet(lll,ll,i,j,k,iblock)=-ccthet(lll,ll,-i,-j,-k,iblock)
+ ddthet(lll,ll,i,j,k,iblock)=ddthet(lll,ll,-i,-j,-k,iblock)
+ eethet(lll,ll,i,j,k,iblock)=-eethet(lll,ll,-i,-j,-k,iblock)
+ enddo
+ enddo
+ do ll=1,ntheterm3
+ do lll=2,ndouble
+ do llll=1,lll-1
+ ffthet(llll,lll,ll,i,j,k,iblock)=
+ & ffthet(llll,lll,ll,-i,-j,-k,iblock)
+ ffthet(lll,llll,ll,i,j,k,iblock)=
+ & ffthet(lll,llll,ll,-i,-j,-k,iblock)
+ ggthet(llll,lll,ll,i,j,k,iblock)=
+ & -ggthet(llll,lll,ll,-i,-j,-k,iblock)
+ ggthet(lll,llll,ll,i,j,k,iblock)=
+ & -ggthet(lll,llll,ll,-i,-j,-k,iblock)
+ enddo !ll
+ enddo !lll
+ enddo !llll
+ enddo !k
+ enddo !j
+ enddo !i
+ enddo !iblock
+
+C
+C Control printout of the coefficients of virtual-bond-angle potentials
+C
+ if (lprint) then
+ write (iout,'(//a)') 'Parameter of virtual-bond-angle potential'
+ do iblock=1,2
+ 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,iblock)
+ write (iout,'(i2,1pe15.5)')
+ & (l,aathet(l,i,j,k,iblock),l=1,ntheterm)
+ do l=1,ntheterm2
+ write (iout,'(//2h m,4(9x,a,3h[m,i1,1h]))')
+ & "b",l,"c",l,"d",l,"e",l
+ do m=1,nsingle
+ write (iout,'(i2,4(1pe15.5))') m,
+ & bbthet(m,l,i,j,k,iblock),ccthet(m,l,i,j,k,iblock),
+ & ddthet(m,l,i,j,k,iblock),eethet(m,l,i,j,k,iblock)
+ enddo
+ enddo
+ do l=1,ntheterm3
+ 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,iblock),
+ & ffthet(m,n,l,i,j,k,iblock),
+ & ggthet(n,m,l,i,j,k,iblock),
+ & ggthet(m,n,l,i,j,k,iblock)
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ call flush(iout)
+ endif
+
+ ELSE
+
+C here will be the apropriate recalibrating for D-aminoacid
+ read (ithep,*,end=111,err=111) nthetyp
+ do i=-nthetyp+1,nthetyp-1
+ read (ithep,*,end=111,err=111) nbend_kcc_Tb(i)
+ do j=0,nbend_kcc_Tb(i)
+ read (ithep,*,end=111,err=111) ijunk,v1bend_chyb(j,i)
+ enddo
+ enddo
+ if (lprint) then
+ write (iout,'(/a)')
+ & "Parameters of the valence-only potentials"
+ do i=-nthetyp+1,nthetyp-1
+ write (iout,'(2a)') "Type ",toronelet(i)
+ do k=0,nbend_kcc_Tb(i)
+ write(iout,'(i5,f15.5)') k,v1bend_chyb(k,i)
+ enddo
+ enddo
+ endif
+
+ ENDIF ! TOR_MODE
+
+ close(ithep)
+#endif
+C write(iout,*) 'KURWA2'
+#ifdef CRYST_SC
+C
+C Read the parameters of the probability distribution/energy expression
+C of the side chains.
+C
+ do i=1,ntyp
+cc write (iout,*) "tu dochodze",i
+ read (irotam,'(3x,i3,f8.3)') 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)
+ censc(1,1,-i)=censc(1,1,i)
+ censc(2,1,-i)=censc(2,1,i)
+ censc(3,1,-i)=-censc(3,1,i)
+ do j=2,nlob(i)
+ read (irotam,*,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)
+ censc(1,j,-i)=censc(1,j,i)
+ censc(2,j,-i)=censc(2,j,i)
+ censc(3,j,-i)=-censc(3,j,i)
+C BSC is amplitude of Gaussian
+ enddo
+ do j=1,nlob(i)
+ do k=1,3
+ 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
+ if (((k.eq.3).and.(l.ne.3))
+ & .or.((l.eq.3).and.(k.ne.3))) then
+ gaussc(k,l,j,-i)=-akl
+ gaussc(l,k,j,-i)=-akl
+ else
+ gaussc(k,l,j,-i)=akl
+ gaussc(l,k,j,-i)=akl
+ endif
+ enddo
+ enddo
+ enddo
+ 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)
+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
+ SPLIT_FOURIERTOR = nloctyp.lt.0
+ nloctyp = iabs(nloctyp)
+#ifdef NEWCORR
+ read (ifourier,*,end=115,err=115) (itype2loc(i),i=1,ntyp)
+ read (ifourier,*,end=115,err=115) (iloctyp(i),i=0,nloctyp-1)
+ itype2loc(ntyp1)=nloctyp
+ iloctyp(nloctyp)=ntyp1
+ do i=1,ntyp1
+ itype2loc(-i)=-itype2loc(i)
+ enddo
+#else
+ iloctyp(0)=10
+ iloctyp(1)=9
+ iloctyp(2)=20
+ iloctyp(3)=ntyp1
+#endif
+ do i=1,nloctyp
+ iloctyp(-i)=-iloctyp(i)
+ enddo
+c write (iout,*) "itype2loc",(itype2loc(i),i=1,ntyp1)
+c write (iout,*) "nloctyp",nloctyp,
+c & " iloctyp",(iloctyp(i),i=0,nloctyp)
+#ifdef NEWCORR
+ do i=0,nloctyp-1
+c write (iout,*) "NEWCORR",i
+ read (ifourier,*,end=115,err=115)
+ do ii=1,3
+ do j=1,2
+ read (ifourier,*,end=115,err=115) bnew1(ii,j,i)
+ enddo
+ enddo
+c write (iout,*) "NEWCORR BNEW1"
+c write (iout,*) ((bnew1(ii,j,i),ii=1,3),j=1,2)
+ do ii=1,3
+ do j=1,2
+ read (ifourier,*,end=115,err=115) bnew2(ii,j,i)
+ enddo
+ enddo
+c write (iout,*) "NEWCORR BNEW2"
+c write (iout,*) ((bnew2(ii,j,i),ii=1,3),j=1,2)
+ do kk=1,3
+ read (ifourier,*,end=115,err=115) ccnew(kk,1,i)
+ read (ifourier,*,end=115,err=115) ccnew(kk,2,i)
+ enddo
+c write (iout,*) "NEWCORR CCNEW"
+c write (iout,*) ((ccnew(ii,j,i),ii=1,3),j=1,2)
+ do kk=1,3
+ read (ifourier,*,end=115,err=115) ddnew(kk,1,i)
+ read (ifourier,*,end=115,err=115) ddnew(kk,2,i)
+ enddo
+c write (iout,*) "NEWCORR DDNEW"
+c write (iout,*) ((ddnew(ii,j,i),ii=1,3),j=1,2)
+ do ii=1,2
+ do jj=1,2
+ do kk=1,2
+ read (ifourier,*,end=115,err=115) eenew(ii,jj,kk,i)
+ enddo
+ enddo
+ enddo
+c write (iout,*) "NEWCORR EENEW1"
+c write(iout,*)(((eenew(ii,jj,kk,i),kk=1,2),jj=1,2),ii=1,2)
+ do ii=1,3
+ read (ifourier,*,end=115,err=115) e0new(ii,i)
+ enddo
+c write (iout,*) (e0new(ii,i),ii=1,3)
+ enddo
+c write (iout,*) "NEWCORR EENEW"
+ do i=0,nloctyp-1
+ do ii=1,3
+ ccnew(ii,1,i)=ccnew(ii,1,i)/2
+ ccnew(ii,2,i)=ccnew(ii,2,i)/2
+ ddnew(ii,1,i)=ddnew(ii,1,i)/2
+ ddnew(ii,2,i)=ddnew(ii,2,i)/2
+ enddo
+ enddo
+ do i=1,nloctyp-1
+ do ii=1,3
+ bnew1(ii,1,-i)= bnew1(ii,1,i)
+ bnew1(ii,2,-i)=-bnew1(ii,2,i)
+ bnew2(ii,1,-i)= bnew2(ii,1,i)
+ bnew2(ii,2,-i)=-bnew2(ii,2,i)
+ enddo
+ do ii=1,3
+c ccnew(ii,1,i)=ccnew(ii,1,i)/2
+c ccnew(ii,2,i)=ccnew(ii,2,i)/2
+c ddnew(ii,1,i)=ddnew(ii,1,i)/2
+c ddnew(ii,2,i)=ddnew(ii,2,i)/2
+ ccnew(ii,1,-i)=ccnew(ii,1,i)
+ ccnew(ii,2,-i)=-ccnew(ii,2,i)
+ ddnew(ii,1,-i)=ddnew(ii,1,i)
+ ddnew(ii,2,-i)=-ddnew(ii,2,i)
+ enddo
+ e0new(1,-i)= e0new(1,i)
+ e0new(2,-i)=-e0new(2,i)
+ e0new(3,-i)=-e0new(3,i)
+ do kk=1,2
+ eenew(kk,1,1,-i)= eenew(kk,1,1,i)
+ eenew(kk,1,2,-i)=-eenew(kk,1,2,i)
+ eenew(kk,2,1,-i)=-eenew(kk,2,1,i)
+ eenew(kk,2,2,-i)= eenew(kk,2,2,i)
+ enddo
+ enddo
+ if (lprint) then
+ write (iout,'(a)') "Coefficients of the multibody terms"
+ do i=-nloctyp+1,nloctyp-1
+ write (iout,*) "Type: ",onelet(iloctyp(i))
+ write (iout,*) "Coefficients of the expansion of B1"
+ do j=1,2
+ write (iout,'(3hB1(,i1,1h),3f10.5)') j,(bnew1(k,j,i),k=1,3)
+ enddo
+ write (iout,*) "Coefficients of the expansion of B2"
+ do j=1,2
+ write (iout,'(3hB2(,i1,1h),3f10.5)') j,(bnew2(k,j,i),k=1,3)
+ enddo
+ write (iout,*) "Coefficients of the expansion of C"
+ write (iout,'(3hC11,3f10.5)') (ccnew(j,1,i),j=1,3)
+ write (iout,'(3hC12,3f10.5)') (ccnew(j,2,i),j=1,3)
+ write (iout,*) "Coefficients of the expansion of D"
+ write (iout,'(3hD11,3f10.5)') (ddnew(j,1,i),j=1,3)
+ write (iout,'(3hD12,3f10.5)') (ddnew(j,2,i),j=1,3)
+ write (iout,*) "Coefficients of the expansion of E"
+ write (iout,'(2hE0,3f10.5)') (e0new(j,i),j=1,3)
+ do j=1,2
+ do k=1,2
+ write (iout,'(1hE,2i1,2f10.5)') j,k,(eenew(l,j,k,i),l=1,2)
+ enddo
+ enddo
+ enddo
+ endif
+ IF (SPLIT_FOURIERTOR) THEN
+ do i=0,nloctyp-1
+c write (iout,*) "NEWCORR TOR",i
+ read (ifourier,*,end=115,err=115)
+ do ii=1,3
+ do j=1,2
+ read (ifourier,*,end=115,err=115) bnew1tor(ii,j,i)
+ enddo
+ enddo
+c write (iout,*) "NEWCORR BNEW1 TOR"
+c write (iout,*) ((bnew1tor(ii,j,i),ii=1,3),j=1,2)
+ do ii=1,3
+ do j=1,2
+ read (ifourier,*,end=115,err=115) bnew2tor(ii,j,i)
+ enddo
+ enddo
+c write (iout,*) "NEWCORR BNEW2 TOR"
+c write (iout,*) ((bnew2tor(ii,j,i),ii=1,3),j=1,2)
+ do kk=1,3
+ read (ifourier,*,end=115,err=115) ccnewtor(kk,1,i)
+ read (ifourier,*,end=115,err=115) ccnewtor(kk,2,i)
+ enddo
+c write (iout,*) "NEWCORR CCNEW TOR"
+c write (iout,*) ((ccnew(ii,j,i),ii=1,3),j=1,2)
+ do kk=1,3
+ read (ifourier,*,end=115,err=115) ddnewtor(kk,1,i)
+ read (ifourier,*,end=115,err=115) ddnewtor(kk,2,i)
+ enddo
+c write (iout,*) "NEWCORR DDNEW TOR"
+c write (iout,*) ((ddnewtor(ii,j,i),ii=1,3),j=1,2)
+ do ii=1,2
+ do jj=1,2
+ do kk=1,2
+ read (ifourier,*,end=115,err=115) eenewtor(ii,jj,kk,i)
+ enddo
+ enddo
+ enddo
+c write (iout,*) "NEWCORR EENEW1 TOR"
+c write(iout,*)(((eenewtor(ii,jj,kk,i),kk=1,2),jj=1,2),ii=1,2)
+ do ii=1,3
+ read (ifourier,*,end=115,err=115) e0newtor(ii,i)
+ enddo
+c write (iout,*) (e0newtor(ii,i),ii=1,3)
+ enddo
+c write (iout,*) "NEWCORR EENEW TOR"
+ do i=0,nloctyp-1
+ do ii=1,3
+ ccnewtor(ii,1,i)=ccnewtor(ii,1,i)/2
+ ccnewtor(ii,2,i)=ccnewtor(ii,2,i)/2
+ ddnewtor(ii,1,i)=ddnewtor(ii,1,i)/2
+ ddnewtor(ii,2,i)=ddnewtor(ii,2,i)/2
+ enddo
+ enddo
+ do i=1,nloctyp-1
+ do ii=1,3
+ bnew1tor(ii,1,-i)= bnew1tor(ii,1,i)
+ bnew1tor(ii,2,-i)=-bnew1tor(ii,2,i)
+ bnew2tor(ii,1,-i)= bnew2tor(ii,1,i)
+ bnew2tor(ii,2,-i)=-bnew2tor(ii,2,i)
+ enddo
+ do ii=1,3
+ ccnewtor(ii,1,-i)=ccnewtor(ii,1,i)
+ ccnewtor(ii,2,-i)=-ccnewtor(ii,2,i)
+ ddnewtor(ii,1,-i)=ddnewtor(ii,1,i)
+ ddnewtor(ii,2,-i)=-ddnewtor(ii,2,i)
+ enddo
+ e0newtor(1,-i)= e0newtor(1,i)
+ e0newtor(2,-i)=-e0newtor(2,i)
+ e0newtor(3,-i)=-e0newtor(3,i)
+ do kk=1,2
+ eenewtor(kk,1,1,-i)= eenewtor(kk,1,1,i)
+ eenewtor(kk,1,2,-i)=-eenewtor(kk,1,2,i)
+ eenewtor(kk,2,1,-i)=-eenewtor(kk,2,1,i)
+ eenewtor(kk,2,2,-i)= eenewtor(kk,2,2,i)
+ enddo
+ enddo
+ if (lprint) then
+ write (iout,'(a)')
+ & "Single-body coefficients of the torsional potentials"
+ do i=-nloctyp+1,nloctyp-1
+ write (iout,*) "Type: ",onelet(iloctyp(i))
+ write (iout,*) "Coefficients of the expansion of B1tor"
+ do j=1,2
+ write (iout,'(3hB1(,i1,1h),3f10.5)')
+ & j,(bnew1tor(k,j,i),k=1,3)
+ enddo
+ write (iout,*) "Coefficients of the expansion of B2tor"
+ do j=1,2
+ write (iout,'(3hB2(,i1,1h),3f10.5)')
+ & j,(bnew2tor(k,j,i),k=1,3)
+ enddo
+ write (iout,*) "Coefficients of the expansion of Ctor"
+ write (iout,'(3hC11,3f10.5)') (ccnewtor(j,1,i),j=1,3)
+ write (iout,'(3hC12,3f10.5)') (ccnewtor(j,2,i),j=1,3)
+ write (iout,*) "Coefficients of the expansion of Dtor"
+ write (iout,'(3hD11,3f10.5)') (ddnewtor(j,1,i),j=1,3)
+ write (iout,'(3hD12,3f10.5)') (ddnewtor(j,2,i),j=1,3)
+ write (iout,*) "Coefficients of the expansion of Etor"
+ write (iout,'(2hE0,3f10.5)') (e0newtor(j,i),j=1,3)
+ do j=1,2
+ do k=1,2
+ write (iout,'(1hE,2i1,2f10.5)')
+ & j,k,(eenewtor(l,j,k,i),l=1,2)
+ enddo
+ enddo
+ enddo
+ endif
+ ELSE
+ do i=-nloctyp+1,nloctyp-1
+ do ii=1,3
+ do j=1,2
+ bnew1tor(ii,j,i)=bnew1(ii,j,i)
+ enddo
+ enddo
+ do ii=1,3
+ do j=1,2
+ bnew2tor(ii,j,i)=bnew2(ii,j,i)
+ enddo
+ enddo
+ do ii=1,3
+ ccnewtor(ii,1,i)=ccnew(ii,1,i)
+ ccnewtor(ii,2,i)=ccnew(ii,2,i)
+ ddnewtor(ii,1,i)=ddnew(ii,1,i)
+ ddnewtor(ii,2,i)=ddnew(ii,2,i)
+ enddo
+ enddo
+ ENDIF !SPLIT_FOURIER_TOR
+#else
+ if (lprint)
+ & write (iout,*) "Coefficients of the expansion of Eloc(l1,l2)"
+ do i=0,nloctyp-1
+ read (ifourier,*,end=115,err=115)
+ read (ifourier,*,end=115,err=115) (b(ii,i),ii=1,13)
+ if (lprint) then
+ write (iout,*) 'Type ',onelet(iloctyp(i))
+ write (iout,'(a,i2,a,f10.5)') ('b(',ii,')=',b(ii,i),ii=1,13)
+ endif
+ if (i.gt.0) then
+ b(2,-i)= b(2,i)
+ b(3,-i)= b(3,i)
+ b(4,-i)=-b(4,i)
+ b(5,-i)=-b(5,i)
+ endif
+c B1(1,i) = b(3)
+c B1(2,i) = b(5)
+c B1(1,-i) = b(3)
+c B1(2,-i) = -b(5)
+c b1(1,i)=0.0d0
+c b1(2,i)=0.0d0
+c B1tilde(1,i) = b(3)
+c B1tilde(2,i) =-b(5)
+c B1tilde(1,-i) =-b(3)
+c B1tilde(2,-i) =b(5)
+c b1tilde(1,i)=0.0d0
+c b1tilde(2,i)=0.0d0
+c B2(1,i) = b(2)
+c B2(2,i) = b(4)
+c B2(1,-i) =b(2)
+c B2(2,-i) =-b(4)
+cc B1tilde(1,i) = b(3,i)
+cc B1tilde(2,i) =-b(5,i)
+C B1tilde(1,-i) =-b(3,i)
+C B1tilde(2,-i) =b(5,i)
+cc b1tilde(1,i)=0.0d0
+cc b1tilde(2,i)=0.0d0
+cc B2(1,i) = b(2,i)
+cc B2(2,i) = b(4,i)
+C B2(1,-i) =b(2,i)
+C B2(2,-i) =-b(4,i)
+
+c b2(1,i)=0.0d0
+c b2(2,i)=0.0d0
+ CCold(1,1,i)= b(7,i)
+ CCold(2,2,i)=-b(7,i)
+ CCold(2,1,i)= b(9,i)
+ CCold(1,2,i)= b(9,i)
+ CCold(1,1,-i)= b(7,i)
+ CCold(2,2,-i)=-b(7,i)
+ CCold(2,1,-i)=-b(9,i)
+ CCold(1,2,-i)=-b(9,i)
+c CC(1,1,i)=0.0d0
+c CC(2,2,i)=0.0d0
+c CC(2,1,i)=0.0d0
+c CC(1,2,i)=0.0d0
+c Ctilde(1,1,i)= CCold(1,1,i)
+c Ctilde(1,2,i)= CCold(1,2,i)
+c Ctilde(2,1,i)=-CCold(2,1,i)
+c Ctilde(2,2,i)=-CCold(2,2,i)
+
+c Ctilde(1,1,i)=0.0d0
+c Ctilde(1,2,i)=0.0d0
+c Ctilde(2,1,i)=0.0d0
+c Ctilde(2,2,i)=0.0d0
+ DDold(1,1,i)= b(6,i)
+ DDold(2,2,i)=-b(6,i)
+ DDold(2,1,i)= b(8,i)
+ DDold(1,2,i)= b(8,i)
+ DDold(1,1,-i)= b(6,i)
+ DDold(2,2,-i)=-b(6,i)
+ DDold(2,1,-i)=-b(8,i)
+ DDold(1,2,-i)=-b(8,i)
+c DD(1,1,i)=0.0d0
+c DD(2,2,i)=0.0d0
+c DD(2,1,i)=0.0d0
+c DD(1,2,i)=0.0d0
+c Dtilde(1,1,i)= DD(1,1,i)
+c Dtilde(1,2,i)= DD(1,2,i)
+c Dtilde(2,1,i)=-DD(2,1,i)
+c Dtilde(2,2,i)=-DD(2,2,i)
+
+c Dtilde(1,1,i)=0.0d0
+c Dtilde(1,2,i)=0.0d0
+c Dtilde(2,1,i)=0.0d0
+c Dtilde(2,2,i)=0.0d0
+ 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)
+ write(iout,*) "TU DOCHODZE"
+ print *,"JESTEM"
+c ee(1,1,i)=1.0d0
+c ee(2,2,i)=1.0d0
+c ee(2,1,i)=0.0d0
+c ee(1,2,i)=0.0d0
+c ee(2,1,i)=ee(1,2,i)
+ enddo
+ if (lprint) then
+ write (iout,*)
+ write (iout,*)
+ &"Coefficients of the cumulants (independent of valence angles)"
+ do i=-nloctyp+1,nloctyp-1
+ write (iout,*) 'Type ',onelet(iloctyp(i))
+ write (iout,*) 'B1'
+ write(iout,'(2f10.5)') B(3,i),B(5,i)
+ write (iout,*) 'B2'
+ write(iout,'(2f10.5)') B(2,i),B(4,i)
+ write (iout,*) 'CC'
+ do j=1,2
+ write (iout,'(2f10.5)') CCold(j,1,i),CCold(j,2,i)
+ enddo
+ write(iout,*) 'DD'
+ do j=1,2
+ write (iout,'(2f10.5)') DDold(j,1,i),DDold(j,2,i)
+ enddo
+ write(iout,*) 'EE'
+ do j=1,2
+ write (iout,'(2f10.5)') EEold(j,1,i),EEold(j,2,i)
+ enddo
+ enddo
+ endif
+#endif
+C write (iout,*) 'KURWAKURWA'
+#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
+ IF (TOR_MODE.eq.0) THEN
+
+ read (itorp,*,end=113,err=113) ntortyp
+ read (itorp,*,end=113,err=113) (itortyp(i),i=1,ntyp)
+ do i=1,ntyp1
+ itype2loc(i)=itortyp(i)
+ enddo
+ write (iout,*) 'ntortyp',ntortyp
+ do i=1,ntyp1
+ itype2loc(-i)=-itype2loc(i)
+ enddo
+ itortyp(ntyp1)=ntortyp
+ do iblock=1,2
+ do i=-ntyp,-1
+ itortyp(i)=-itortyp(-i)
+ enddo
+c write (iout,*) 'ntortyp',ntortyp
+ do i=0,ntortyp-1
+ do j=-ntortyp+1,ntortyp-1
+ read (itorp,*,end=113,err=113) nterm(i,j,iblock),
+ & nlor(i,j,iblock)
+ nterm(-i,-j,iblock)=nterm(i,j,iblock)
+ nlor(-i,-j,iblock)=nlor(i,j,iblock)
+ v0ij=0.0d0
+ si=-1.0d0
+ do k=1,nterm(i,j,iblock)
+ read (itorp,*,end=113,err=113) kk,v1(k,i,j,iblock),
+ & v2(k,i,j,iblock)
+ v1(k,-i,-j,iblock)=v1(k,i,j,iblock)
+ v2(k,-i,-j,iblock)=-v2(k,i,j,iblock)
+ v0ij=v0ij+si*v1(k,i,j,iblock)
+ si=-si
+ enddo
+ do k=1,nlor(i,j,iblock)
+ 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,iblock)=v0ij
+ v0(-i,-j,iblock)=v0ij
+ enddo
+ enddo
+ enddo
+ close (itorp)
+ if (lprint) then
+ write (iout,'(/a/)') 'Torsional constants:'
+ do i=1,ntortyp
+ do j=1,ntortyp
+ write (iout,*) 'ityp',i,' jtyp',j
+ write (iout,*) 'Fourier constants'
+ do k=1,nterm(i,j,iblock)
+ write (iout,'(2(1pe15.5))') v1(k,i,j,iblock),
+ & v2(k,i,j,iblock)
+ enddo
+ write (iout,*) 'Lorenz constants'
+ do k=1,nlor(i,j,iblock)
+ 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 iblock=1,2
+ do i=0,ntortyp-1
+ do j=-ntortyp+1,ntortyp-1
+ do k=-ntortyp+1,ntortyp-1
+ read (itordp,'(3a1)',end=114,err=114) t1,t2,t3
+c write (iout,*) "OK onelett",
+c & i,j,k,t1,t2,t3
+
+ if (t1.ne.toronelet(i) .or. t2.ne.toronelet(j)
+ & .or. t3.ne.toronelet(k)) then
+ write (iout,*) "Error in double torsional parameter file",
+ & i,j,k,t1,t2,t3
+#ifdef MPI
+ call MPI_Finalize(Ierror)
+#endif
+ stop "Error in double torsional parameter file"
+ endif
+ read (itordp,*,end=114,err=114) ntermd_1(i,j,k,iblock),
+ & ntermd_2(i,j,k,iblock)
+ ntermd_1(-i,-j,-k,iblock)=ntermd_1(i,j,k,iblock)
+ ntermd_2(-i,-j,-k,iblock)=ntermd_2(i,j,k,iblock)
+ read (itordp,*,end=114,err=114) (v1c(1,l,i,j,k,iblock),l=1,
+ & ntermd_1(i,j,k,iblock))
+ read (itordp,*,end=114,err=114) (v1s(1,l,i,j,k,iblock),l=1,
+ & ntermd_1(i,j,k,iblock))
+ read (itordp,*,end=114,err=114) (v1c(2,l,i,j,k,iblock),l=1,
+ & ntermd_1(i,j,k,iblock))
+ read (itordp,*,end=114,err=114) (v1s(2,l,i,j,k,iblock),l=1,
+ & ntermd_1(i,j,k,iblock))
+C Martix of D parameters for one dimesional foureir series
+ do l=1,ntermd_1(i,j,k,iblock)
+ v1c(1,l,-i,-j,-k,iblock)=v1c(1,l,i,j,k,iblock)
+ v1s(1,l,-i,-j,-k,iblock)=-v1s(1,l,i,j,k,iblock)
+ v1c(2,l,-i,-j,-k,iblock)=v1c(2,l,i,j,k,iblock)
+ v1s(2,l,-i,-j,-k,iblock)=-v1s(2,l,i,j,k,iblock)
+c write(iout,*) "whcodze" ,
+c & v1s(2,l,-i,-j,-k,iblock),v1s(2,l,i,j,k,iblock)
+ enddo
+ read (itordp,*,end=114,err=114) ((v2c(l,m,i,j,k,iblock),
+ & v2c(m,l,i,j,k,iblock),v2s(l,m,i,j,k,iblock),
+ & v2s(m,l,i,j,k,iblock),
+ & m=1,l-1),l=1,ntermd_2(i,j,k,iblock))
+C Martix of D parameters for two dimesional fourier series
+ do l=1,ntermd_2(i,j,k,iblock)
+ do m=1,l-1
+ v2c(l,m,-i,-j,-k,iblock)=v2c(l,m,i,j,k,iblock)
+ v2c(m,l,-i,-j,-k,iblock)=v2c(m,l,i,j,k,iblock)
+ v2s(l,m,-i,-j,-k,iblock)=-v2s(l,m,i,j,k,iblock)
+ v2s(m,l,-i,-j,-k,iblock)=-v2s(m,l,i,j,k,iblock)
+ enddo!m
+ enddo!l
+ enddo!k
+ enddo!j
+ enddo!i
+ enddo!iblock
+ if (lprint) then
+ write (iout,*)
+ write (iout,*) 'Constants for double torsionals'
+ do iblock=1,2
+ do i=0,ntortyp-1
+ do j=-ntortyp+1,ntortyp-1
+ do k=-ntortyp+1,ntortyp-1
+ write (iout,*) 'ityp',i,' jtyp',j,' ktyp',k,
+ & ' nsingle',ntermd_1(i,j,k,iblock),
+ & ' ndouble',ntermd_2(i,j,k,iblock)
+ write (iout,*)
+ write (iout,*) 'Single angles:'
+ do l=1,ntermd_1(i,j,k,iblock)
+ write (iout,'(i5,2f10.5,5x,2f10.5,5x,2f10.5)') l,
+ & v1c(1,l,i,j,k,iblock),v1s(1,l,i,j,k,iblock),
+ & v1c(2,l,i,j,k,iblock),v1s(2,l,i,j,k,iblock),
+ & v1s(1,l,-i,-j,-k,iblock),v1s(2,l,-i,-j,-k,iblock)
+ enddo
+ write (iout,*)
+ write (iout,*) 'Pairs of angles:'
+ write (iout,'(3x,20i10)') (l,l=1,ntermd_2(i,j,k,iblock))
+ do l=1,ntermd_2(i,j,k,iblock)
+ write (iout,'(i5,20f10.5)')
+ & l,(v2c(l,m,i,j,k,iblock),m=1,ntermd_2(i,j,k,iblock))
+ enddo
+ write (iout,*)
+ write (iout,'(3x,20i10)') (l,l=1,ntermd_2(i,j,k,iblock))
+ do l=1,ntermd_2(i,j,k,iblock)
+ write (iout,'(i5,20f10.5)')
+ & l,(v2s(l,m,i,j,k,iblock),m=1,ntermd_2(i,j,k,iblock)),
+ & (v2s(l,m,-i,-j,-k,iblock),m=1,ntermd_2(i,j,k,iblock))
+ enddo
+ write (iout,*)
+ enddo
+ enddo
+ enddo
+ enddo
+ endif
+
+ ELSE IF (TOR_MODE.eq.1) THEN
+
+C read valence-torsional parameters
+ read (itorp,*,end=113,err=113) ntortyp
+ nkcctyp=ntortyp
+ write (iout,*) "Valence-torsional parameters read in ntortyp",
+ & ntortyp
+ read (itorp,*,end=113,err=113) (itortyp(i),i=1,ntyp)
+ write (iout,*) "itortyp_kcc",(itortyp(i),i=1,ntyp)
+ do i=-ntyp,-1
+ itortyp(i)=-itortyp(-i)
+ enddo
+ do i=-ntortyp+1,ntortyp-1
+ do j=-ntortyp+1,ntortyp-1
+C first we read the cos and sin gamma parameters
+ read (itorp,'(13x,a)',end=113,err=113) string
+ write (iout,*) i,j,string
+ read (itorp,*,end=113,err=113)
+ & nterm_kcc(j,i),nterm_kcc_Tb(j,i)
+C read (itorkcc,*,end=121,err=121) nterm_kcc_Tb(j,i)
+ do k=1,nterm_kcc(j,i)
+ do l=1,nterm_kcc_Tb(j,i)
+ do ll=1,nterm_kcc_Tb(j,i)
+ read (itorp,*,end=113,err=113) ii,jj,kk,
+ & v1_kcc(ll,l,k,j,i),v2_kcc(ll,l,k,j,i)
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+
+ ELSE
+c AL 4/8/16: Calculate coefficients from one-body parameters
+ ntortyp=nloctyp
+ do i=-ntyp1,ntyp1
+ itortyp(i)=itype2loc(i)
+ enddo
+ if (lprint) write (iout,*)
+ &"Val-tor parameters calculated from cumulant coefficients ntortyp"
+ & ,ntortyp
+ do i=-ntortyp+1,ntortyp-1
+ do j=-ntortyp+1,ntortyp-1
+ nterm_kcc(j,i)=2
+ nterm_kcc_Tb(j,i)=3
+ do k=1,nterm_kcc_Tb(j,i)
+ do l=1,nterm_kcc_Tb(j,i)
+ v1_kcc(k,l,1,i,j)=bnew1tor(k,1,i)*bnew2tor(l,1,j)
+ & +bnew1tor(k,2,i)*bnew2tor(l,2,j)
+ v2_kcc(k,l,1,i,j)=bnew1tor(k,1,i)*bnew2tor(l,2,j)
+ & +bnew1tor(k,2,i)*bnew2tor(l,1,j)
+ enddo
+ enddo
+ do k=1,nterm_kcc_Tb(j,i)
+ do l=1,nterm_kcc_Tb(j,i)
+#ifdef CORRCD
+ v1_kcc(k,l,2,i,j)=-(ccnewtor(k,1,i)*ddnewtor(l,1,j)
+ & -ccnewtor(k,2,i)*ddnewtor(l,2,j))
+ v2_kcc(k,l,2,i,j)=-(ccnewtor(k,2,i)*ddnewtor(l,1,j)
+ & +ccnewtor(k,1,i)*ddnewtor(l,2,j))
+#else
+ v1_kcc(k,l,2,i,j)=-0.25*(ccnewtor(k,1,i)*ddnewtor(l,1,j)
+ & -ccnewtor(k,2,i)*ddnewtor(l,2,j))
+ v2_kcc(k,l,2,i,j)=-0.25*(ccnewtor(k,2,i)*ddnewtor(l,1,j)
+ & +ccnewtor(k,1,i)*ddnewtor(l,2,j))
+#endif
+ enddo
+ enddo
+cf(theta,gamma)=-(b21(theta)*b11(theta)+b12(theta)*b22(theta))*cos(gamma)-(b22(theta)*b11(theta)+b21(theta)*b12(theta))*sin(gamma)+(c11(theta)*d11(theta)-c12(theta)*d12(theta))*cos(2*gamma)+(c12(theta)*d11(theta)+c11(theta)*d12(theta))*sin(2*gamma)
+ enddo
+ enddo
+
+ ENDIF ! TOR_MODE
+
+ if (tor_mode.gt.0 .and. lprint) then
+c Print valence-torsional parameters
+ write (iout,'(/a)')
+ & "Parameters of the valence-torsional potentials"
+ do i=-ntortyp+1,ntortyp-1
+ do j=-ntortyp+1,ntortyp-1
+ write (iout,'(3a)') "Type ",toronelet(i),toronelet(j)
+ write (iout,'(3a5,2a15)') "itor","ival","jval","v_kcc","v2_kcc"
+ do k=1,nterm_kcc(j,i)
+ do l=1,nterm_kcc_Tb(j,i)
+ do ll=1,nterm_kcc_Tb(j,i)
+ write (iout,'(3i5,2f15.4)')
+ & k,l-1,ll-1,v1_kcc(ll,l,k,j,i),v2_kcc(ll,l,k,j,i)
+ enddo
+ enddo
+ 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)
+ do i=-ntyp,-1
+ isccortyp(i)=-isccortyp(-i)
+ enddo
+ iscprol=isccortyp(20)
+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)
+c write (iout,*) nterm_sccor(i,j)
+ v0ijsccor=0.0d0
+ v0ijsccor1=0.0d0
+ v0ijsccor2=0.0d0
+ v0ijsccor3=0.0d0
+ si=-1.0d0
+ nterm_sccor(-i,j)=nterm_sccor(i,j)
+ nterm_sccor(-i,-j)=nterm_sccor(i,j)
+ nterm_sccor(i,-j)=nterm_sccor(i,j)
+c write (iout,*) nterm_sccor(i,j),nterm_sccor(-i,j),
+c & nterm_sccor(-i,-j),nterm_sccor(i,-j)
+ do k=1,nterm_sccor(i,j)
+ read (isccor,*,end=119,err=119) kk,v1sccor(k,l,i,j)
+ & ,v2sccor(k,l,i,j)
+ if (j.eq.iscprol) then
+ if (i.eq.isccortyp(10)) then
+ v1sccor(k,l,i,-j)=v1sccor(k,l,i,j)
+ v2sccor(k,l,i,-j)=-v2sccor(k,l,i,j)
+ else
+ v1sccor(k,l,i,-j)=v1sccor(k,l,i,j)*0.5d0
+ & +v2sccor(k,l,i,j)*dsqrt(0.75d0)
+ v2sccor(k,l,i,-j)=-v2sccor(k,l,i,j)*0.5d0
+ & +v1sccor(k,l,i,j)*dsqrt(0.75d0)
+ v1sccor(k,l,-i,-j)=v1sccor(k,l,i,j)
+ v2sccor(k,l,-i,-j)=-v2sccor(k,l,i,j)
+ v1sccor(k,l,-i,j)=v1sccor(k,l,i,-j)
+ v2sccor(k,l,-i,j)=-v2sccor(k,l,i,-j)
+ endif
+ else
+ if (i.eq.isccortyp(10)) then
+ v1sccor(k,l,i,-j)=v1sccor(k,l,i,j)
+ v2sccor(k,l,i,-j)=-v2sccor(k,l,i,j)
+ else
+ if (j.eq.isccortyp(10)) then
+ v1sccor(k,l,-i,j)=v1sccor(k,l,i,j)
+ v2sccor(k,l,-i,j)=-v2sccor(k,l,i,j)
+ else
+ v1sccor(k,l,i,-j)=-v1sccor(k,l,i,j)
+ v2sccor(k,l,i,-j)=-v2sccor(k,l,i,j)
+ v1sccor(k,l,-i,-j)=v1sccor(k,l,i,j)
+ v2sccor(k,l,-i,-j)=-v2sccor(k,l,i,j)
+ v1sccor(k,l,-i,j)=v1sccor(k,l,i,-j)
+ v2sccor(k,l,-i,j)=-v2sccor(k,l,i,-j)
+ endif
+ endif
+ endif
+ v0ijsccor=v0ijsccor+si*v1sccor(k,l,i,j)
+ v0ijsccor1=v0ijsccor+si*v1sccor(k,l,-i,j)
+ v0ijsccor2=v0ijsccor+si*v1sccor(k,l,i,-j)
+ v0ijsccor3=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(l,i,j)=v0ijsccor
+ v0sccor(l,-i,j)=v0ijsccor1
+ v0sccor(l,i,-j)=v0ijsccor2
+ v0sccor(l,-i,-j)=v0ijsccor3
+ enddo
+ enddo
+ enddo
+ close (isccor)
+ if (lprint) then
+ write (iout,'(/a/)') 'Torsional constants of SCCORR:'
+ do l=1,maxinter
+ 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)
+ 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
+ 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.5) 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) 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 50
+C----------------------- LJK potential --------------------------------
+ 20 read (isidep,*,end=117,err=117)((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 50
+C---------------------- GB or BP potential -----------------------------
+ 30 do i=1,ntyp
+ read (isidep,*,end=117,err=117)(eps(i,j),j=i,ntyp)
+ enddo
+ read (isidep,*,end=117,err=117)(sigma0(i),i=1,ntyp)
+ read (isidep,*,end=117,err=117)(sigii(i),i=1,ntyp)
+ read (isidep,*,end=117,err=117)(chip(i),i=1,ntyp)
+ read (isidep,*,end=117,err=117)(alp(i),i=1,ntyp)
+ do i=1,ntyp
+ read (isidep,*,end=117,err=117)(epslip(i,j),j=i,ntyp)
+C write(iout,*) "WARNING!!",i,ntyp
+ if (lprint) write(iout,*) "epslip", i, (epslip(i,j),j=i,ntyp)
+C do j=1,ntyp
+C epslip(i,j)=epslip(i,j)+0.05d0
+C enddo
+ enddo
+C For the GB potential convert sigma'**2 into chi'
+ if (ipot.eq.4) then
+ do i=1,ntyp
+ chip(i)=(chip(i)-1.0D0)/(chip(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 50
+C--------------------- GBV potential -----------------------------------
+ 40 read (isidep,*,end=117,err=117)((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
+ 50 continue
+ close (isidep)
+C-----------------------------------------------------------------------
+C Calculate the "working" parameters of SC interactions.
+ do i=2,ntyp
+ do j=1,i-1
+ eps(i,j)=eps(j,i)
+ epslip(i,j)=epslip(j,i)
+ enddo
+ enddo
+ do i=1,ntyp
+ 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
+ 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)
+ epsijlip=epslip(i,j)
+ if (ipot.eq.1 .or. ipot.eq.3 .or. ipot.eq.4) 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_aq(i,j)=epsij*rrij*rrij
+ bb_aq(i,j)=-sigeps*epsij*rrij
+ aa_aq(j,i)=aa_aq(i,j)
+ bb_aq(j,i)=bb_aq(i,j)
+ sigeps=dsign(1.0D0,epsijlip)
+ epsijlip=dabs(epsijlip)
+ aa_lip(i,j)=epsijlip*rrij*rrij
+ bb_lip(i,j)=-sigeps*epsijlip*rrij
+ aa_lip(j,i)=aa_lip(i,j)
+ bb_lip(j,i)=bb_lip(i,j)
+ if (ipot.gt.2) then
+ sigt1sq=sigma0(i)**2
+ sigt2sq=sigma0(j)**2
+ sigii1=sigii(i)
+ 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
+ write (iout,'(2(a3,2x),3(1pe10.3),5(0pf8.3))')
+ & restyp(i),restyp(j),aa_aq(i,j),bb_aq(i,j),augm(i,j),
+ & sigma(i,j),r0(i,j),chi(i,j),chi(j,i)
+ endif
+ enddo
+ 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,'(/a)') "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
+C ebr=-12.0D0
+c
+c Old arbitrary potential - commented out.
+c
+c dbr= 4.20D0
+c fbr= 3.30D0
+c
+c Constants of the disulfide-bond potential determined based on the RHF/6-31G**
+c energy surface of diethyl disulfide.
+c A. Liwo and U. Kozlowska, 11/24/03
+c
+C D0CM = 3.78d0
+C AKCM = 15.1d0
+C AKTH = 11.0d0
+C AKCT = 12.0d0
+C V1SS =-1.08d0
+C V2SS = 7.61d0
+C V3SS = 13.7d0
+ if (dyn_ss)
+ & write (iout,*) 'Dynamic formation/breaking of disulfides'
+ if (dyn_ss) then
+ ss_depth=ebr/wsc-0.25*eps(1,1)
+C write(iout,*) akcm,whpb,wsc,'KURWA'
+ Ht=Ht/wsc-0.25*eps(1,1)
+
+ akcm=akcm*whpb/wsc
+ akth=akth*whpb/wsc
+ akct=akct*whpb/wsc
+ v1ss=v1ss*whpb/wsc
+ v2ss=v2ss*whpb/wsc
+ v3ss=v3ss*whpb/wsc
+ else
+ ss_depth=ebr/whpb-0.25*eps(1,1)*wsc/whpb
+ endif
+
+C if (lprint) then
+ 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
+ write (iout,'(a)') "Parameters of the 'trisulfide' potential"
+ write(iout,*) "ATRISS",atriss
+ write(iout,*) "BTRISS",btriss
+ write(iout,*) "CTRISS",ctriss
+ write(iout,*) "DTRISS",dtriss
+ endif
+C endif
+ if (shield_mode.gt.0) then
+ pi=3.141592d0
+C VSolvSphere the volume of solving sphere
+C print *,pi,"pi"
+C rpp(1,1) is the energy r0 for peptide group contact and will be used for it
+C there will be no distinction between proline peptide group and normal peptide
+C group in case of shielding parameters
+ VSolvSphere=4.0/3.0*pi*rpp(1,1)**3
+ VSolvSphere_div=VSolvSphere-4.0/3.0*pi*(rpp(1,1)/2.0)**3
+ write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
+ & VSolvSphere_div
+C long axis of side chain
+ do i=1,ntyp
+ long_r_sidechain(i)=vbldsc0(1,i)
+ short_r_sidechain(i)=sigma0(i)
+ enddo
+ buff_shield=1.0d0
+ endif
+ return
+ 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
+ 1161 write (iout,*) "Error reading lipid 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"
+ goto 999
+ 121 write (iout,*) "Error reading bond parameters"
+ 999 continue
+#ifdef MPI
+ call MPI_Finalize(Ierror)
+#endif
+ stop
+ return
+ end
--- /dev/null
+ 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'
+ include 'COMMON.SHIELD'
+ include 'COMMON.CONTROL'
+ character*1 t1,t2,t3
+ character*1 onelett(4) /"G","A","P","D"/
+ character*1 toronelet(-2:2) /"p","a","G","A","P"/
+ logical lprint
+ dimension blower(3,3,maxlob)
+ character*800 controlcard
+ 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
+ character*6 res1
+ character*3 lancuch,ucase
+C write (iout,*) "KURWA"
+C
+C Body
+C
+ call getenv("PRINT_PARM",lancuch)
+ lprint = (ucase(lancuch).eq."YES" .or. ucase(lancuch).eq."Y")
+ write (iout,*) "lprint ",lprint
+C Set LPRINT=.TRUE. for debugging
+ dwa16=2.0d0**(1.0d0/6.0d0)
+ 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
+ call reada(controlcard,"D0CM",d0cm,3.78d0)
+ call reada(controlcard,"AKCM",akcm,15.1d0)
+ call reada(controlcard,"AKTH",akth,11.0d0)
+ call reada(controlcard,"AKCT",akct,12.0d0)
+ call reada(controlcard,"V1SS",v1ss,-1.08d0)
+ call reada(controlcard,"V2SS",v2ss,7.61d0)
+ call reada(controlcard,"V3SS",v3ss,13.7d0)
+ call reada(controlcard,"EBR",ebr,-5.50D0)
+ call reada(controlcard,"DTRISS",dtriss,1.0D0)
+ call reada(controlcard,"ATRISS",atriss,0.3D0)
+ call reada(controlcard,"BTRISS",btriss,0.02D0)
+ call reada(controlcard,"CTRISS",ctriss,1.0D0)
+ dyn_ss=(index(controlcard,'DYN_SS').gt.0)
+ write(iout,*) "ATRISS",atriss
+ write(iout,*) "BTRISS",btriss
+ write(iout,*) "CTRISS",ctriss
+ write(iout,*) "DTRISS",dtriss
+
+C do i=1,maxres
+C dyn_ss_mask(i)=.false.
+C enddo
+C ebr=-12.0D0
+c
+c Old arbitrary potential - commented out.
+c
+c dbr= 4.20D0
+c fbr= 3.30D0
+c
+c Constants of the disulfide-bond potential determined based on the RHF/6-31G**
+c energy surface of diethyl disulfide.
+c A. Liwo and U. Kozlowska, 11/24/03
+c
+ D0CM = 3.78d0
+ AKCM = 15.1d0
+ AKTH = 11.0d0
+ AKCT = 12.0d0
+ V1SS =-1.08d0
+ V2SS = 7.61d0
+ V3SS = 13.7d0
+
+ do i=1,maxres-1
+ do j=i+1,maxres
+ dyn_ssbond_ij(i,j)=1.0d300
+ enddo
+ enddo
+ call reada(controlcard,"HT",Ht,0.0D0)
+C if (dyn_ss) then
+C ss_depth=ebr/wsc-0.25*eps(1,1)
+C write(iout,*) HT,wsc,eps(1,1),'KURWA'
+C Ht=Ht/wsc-0.25*eps(1,1)
+
+C akcm=akcm*whpb/wsc
+C akth=akth*whpb/wsc
+C akct=akct*whpb/wsc
+C v1ss=v1ss*whpb/wsc
+C v2ss=v2ss*whpb/wsc
+C v3ss=v3ss*whpb/wsc
+C else
+C ss_depth=ebr/whpb-0.25*eps(1,1)*wsc/whpb
+C endif
+
+ if (iparm.eq.myparm .or. .not.separate_parset) then
+
+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)
+ wbond=ww(18)
+ wsccor=ww(19)
+ whpb=ww(15)
+ wstrain=ww(15)
+ wliptran=ww(22)
+ wshield=ww(25)
+ 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)
+ write (iout,*) "tor_mode",tor_mode
+ call flush(iout)
+ if (tor_mode.eq.0)
+ & open (itordp,file=tordname_t,status='old')
+ rewind(itordp)
+ call reads(controlcard,"SCCORPAR",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=121,err=121) vbldp0,vbldpdum,akp
+ do i=1,ntyp
+ nbondterm(i)=1
+ read (ibond,*,end=121,err=121) 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=121,err=121) ijunk,vbldp0,vbldpdum,akp,rjunk
+ do i=1,ntyp
+ read (ibond,*,end=121,err=121) 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
+ write (iout,*) "iliptranpar",iliptranpar
+ write (iout,*) "liptranname ",liptranname
+ read(iliptranpar,*,end=1161,err=1161) pepliptran
+ write (iout,*) "pepliptran",pepliptran
+ do i=1,ntyp
+ read(iliptranpar,*,end=1161,err=1161) liptranene(i)
+ write (iout,*) i,liptranene(i)
+ enddo
+ rewind iliptranpar
+#ifdef CRYST_THETA
+C
+C Read the parameters of the probability distribution/energy expression
+C of the virtual-bond valence angles theta
+C
+ do i=1,ntyp
+ read (ithep,*,end=111,err=111) a0thet(i),(athet(j,i,1,1),j=1,2),
+ & (bthet(j,i,1,1),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
+ do i=1,ntyp
+ athet(1,i,1,-1)=athet(1,i,1,1)
+ athet(2,i,1,-1)=athet(2,i,1,1)
+ bthet(1,i,1,-1)=-bthet(1,i,1,1)
+ bthet(2,i,1,-1)=-bthet(2,i,1,1)
+ athet(1,i,-1,1)=-athet(1,i,1,1)
+ athet(2,i,-1,1)=-athet(2,i,1,1)
+ bthet(1,i,-1,1)=bthet(1,i,1,1)
+ bthet(2,i,-1,1)=bthet(2,i,1,1)
+ enddo
+ do i=-ntyp,-1
+ a0thet(i)=a0thet(-i)
+ athet(1,i,-1,-1)=athet(1,-i,1,1)
+ athet(2,i,-1,-1)=-athet(2,-i,1,1)
+ bthet(1,i,-1,-1)=bthet(1,-i,1,1)
+ bthet(2,i,-1,-1)=-bthet(2,-i,1,1)
+ athet(1,i,-1,1)=athet(1,-i,1,1)
+ athet(2,i,-1,1)=-athet(2,-i,1,1)
+ bthet(1,i,-1,1)=-bthet(1,-i,1,1)
+ bthet(2,i,-1,1)=bthet(2,-i,1,1)
+ athet(1,i,1,-1)=-athet(1,-i,1,1)
+ athet(2,i,1,-1)=athet(2,-i,1,1)
+ bthet(1,i,1,-1)=bthet(1,-i,1,1)
+ bthet(2,i,1,-1)=-bthet(2,-i,1,1)
+ theta0(i)=theta0(-i)
+ sig0(i)=sig0(-i)
+ sigc0(i)=sigc0(-i)
+ do j=0,3
+ polthet(j,i)=polthet(j,-i)
+ enddo
+ do j=1,3
+ gthet(j,i)=gthet(j,-i)
+ enddo
+ enddo
+ close (ithep)
+ if (lprint) then
+c write (iout,'(a)')
+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,1,1),j=1,2),
+ & (10*bthet(j,i,1,1),j=1,2)
+ enddo
+ write (iout,'(/a/9x,5a/79(1h-))')
+ & 'Parameters of the expression for sigma(theta_c):',
+ & ' 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
+ IF (tor_mode.eq.0) THEN
+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=-ntyp1,-1
+ ithetyp(i)=-ithetyp(-i)
+ enddo
+ do iblock=1,2
+ do i=-maxthetyp,maxthetyp
+ do j=-maxthetyp,maxthetyp
+ do k=-maxthetyp,maxthetyp
+ aa0thet(i,j,k,iblock)=0.0d0
+ do l=1,ntheterm
+ aathet(l,i,j,k,iblock)=0.0d0
+ enddo
+ do l=1,ntheterm2
+ do m=1,nsingle
+ bbthet(m,l,i,j,k,iblock)=0.0d0
+ ccthet(m,l,i,j,k,iblock)=0.0d0
+ ddthet(m,l,i,j,k,iblock)=0.0d0
+ eethet(m,l,i,j,k,iblock)=0.0d0
+ enddo
+ enddo
+ do l=1,ntheterm3
+ do m=1,ndouble
+ do mm=1,ndouble
+ ffthet(mm,m,l,i,j,k,iblock)=0.0d0
+ ggthet(mm,m,l,i,j,k,iblock)=0.0d0
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+C write (iout,*) "KURWA1"
+ do iblock=1,2
+ do i=0,nthetyp
+ do j=-nthetyp,nthetyp
+ do k=-nthetyp,nthetyp
+ read (ithep,'(6a)',end=111,err=111) res1
+ write(iout,*) res1,i,j,k
+ read (ithep,*,end=111,err=111) aa0thet(i,j,k,iblock)
+ read (ithep,*,end=111,err=111)(aathet(l,i,j,k,iblock),
+ & l=1,ntheterm)
+ read (ithep,*,end=111,err=111)
+ & ((bbthet(lll,ll,i,j,k,iblock),lll=1,nsingle),
+ & (ccthet(lll,ll,i,j,k,iblock),lll=1,nsingle),
+ & (ddthet(lll,ll,i,j,k,iblock),lll=1,nsingle),
+ & (eethet(lll,ll,i,j,k,iblock),lll=1,nsingle)
+ & ,ll=1,ntheterm2)
+ read (ithep,*,end=111,err=111)
+ & (((ffthet(llll,lll,ll,i,j,k,iblock),
+ & ffthet(lll,llll,ll,i,j,k,iblock),
+ & ggthet(llll,lll,ll,i,j,k,iblock)
+ & ,ggthet(lll,llll,ll,i,j,k,iblock),
+ & llll=1,lll-1),lll=2,ndouble),ll=1,ntheterm3)
+ enddo
+ enddo
+ enddo
+C write(iout,*) "KURWA1.1"
+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,iblock)=0.0d0
+ aathet(l,nthetyp+1,i,j,iblock)=0.0d0
+ enddo
+ aa0thet(i,j,nthetyp+1,iblock)=0.0d0
+ aa0thet(nthetyp+1,i,j,iblock)=0.0d0
+ enddo
+ do l=1,ntheterm
+ aathet(l,nthetyp+1,i,nthetyp+1,iblock)=0.0d0
+ enddo
+ aa0thet(nthetyp+1,i,nthetyp+1,iblock)=0.0d0
+ enddo
+ enddo
+C write(iout,*) "KURWA1.5"
+C Substitution for D aminoacids from symmetry.
+ do iblock=1,2
+ do i=-nthetyp,0
+ do j=-nthetyp,nthetyp
+ do k=-nthetyp,nthetyp
+ aa0thet(i,j,k,iblock)=aa0thet(-i,-j,-k,iblock)
+ do l=1,ntheterm
+ aathet(l,i,j,k,iblock)=aathet(l,-i,-j,-k,iblock)
+ enddo
+ do ll=1,ntheterm2
+ do lll=1,nsingle
+ bbthet(lll,ll,i,j,k,iblock)=bbthet(lll,ll,-i,-j,-k,iblock)
+ ccthet(lll,ll,i,j,k,iblock)=-ccthet(lll,ll,-i,-j,-k,iblock)
+ ddthet(lll,ll,i,j,k,iblock)=ddthet(lll,ll,-i,-j,-k,iblock)
+ eethet(lll,ll,i,j,k,iblock)=-eethet(lll,ll,-i,-j,-k,iblock)
+ enddo
+ enddo
+ do ll=1,ntheterm3
+ do lll=2,ndouble
+ do llll=1,lll-1
+ ffthet(llll,lll,ll,i,j,k,iblock)=
+ & ffthet(llll,lll,ll,-i,-j,-k,iblock)
+ ffthet(lll,llll,ll,i,j,k,iblock)=
+ & ffthet(lll,llll,ll,-i,-j,-k,iblock)
+ ggthet(llll,lll,ll,i,j,k,iblock)=
+ & -ggthet(llll,lll,ll,-i,-j,-k,iblock)
+ ggthet(lll,llll,ll,i,j,k,iblock)=
+ & -ggthet(lll,llll,ll,-i,-j,-k,iblock)
+ enddo !ll
+ enddo !lll
+ enddo !llll
+ enddo !k
+ enddo !j
+ enddo !i
+ enddo !iblock
+
+C
+C Control printout of the coefficients of virtual-bond-angle potentials
+C
+ if (lprint) then
+ write (iout,'(//a)') 'Parameter of virtual-bond-angle potential'
+ do iblock=1,2
+ 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,iblock)
+ write (iout,'(i2,1pe15.5)')
+ & (l,aathet(l,i,j,k,iblock),l=1,ntheterm)
+ do l=1,ntheterm2
+ write (iout,'(//2h m,4(9x,a,3h[m,i1,1h]))')
+ & "b",l,"c",l,"d",l,"e",l
+ do m=1,nsingle
+ write (iout,'(i2,4(1pe15.5))') m,
+ & bbthet(m,l,i,j,k,iblock),ccthet(m,l,i,j,k,iblock),
+ & ddthet(m,l,i,j,k,iblock),eethet(m,l,i,j,k,iblock)
+ enddo
+ enddo
+ do l=1,ntheterm3
+ 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,iblock),
+ & ffthet(m,n,l,i,j,k,iblock),
+ & ggthet(n,m,l,i,j,k,iblock),
+ & ggthet(m,n,l,i,j,k,iblock)
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ call flush(iout)
+ endif
+
+ ELSE
+
+C here will be the apropriate recalibrating for D-aminoacid
+ read (ithep,*,end=111,err=111) nthetyp
+ do i=-nthetyp+1,nthetyp-1
+ read (ithep,*,end=111,err=111) nbend_kcc_Tb(i)
+ do j=0,nbend_kcc_Tb(i)
+ read (ithep,*,end=111,err=111) ijunk,v1bend_chyb(j,i)
+ enddo
+ enddo
+ if (lprint) then
+ write (iout,'(a)')
+ & "Parameters of the valence-only potentials"
+ do i=-nthetyp+1,nthetyp-1
+ write (iout,'(2a)') "Type ",toronelet(i)
+ do k=0,nbend_kcc_Tb(i)
+ write(iout,'(i5,f15.5)') k,v1bend_chyb(k,i)
+ enddo
+ enddo
+ endif
+
+ ENDIF ! TOR_MODE
+
+ close(ithep)
+#endif
+C write(iout,*) 'KURWA2'
+#ifdef CRYST_SC
+C
+C Read the parameters of the probability distribution/energy expression
+C of the side chains.
+C
+ do i=1,ntyp
+cc write (iout,*) "tu dochodze",i
+ read (irotam,'(3x,i3,f8.3)') 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)
+ censc(1,1,-i)=censc(1,1,i)
+ censc(2,1,-i)=censc(2,1,i)
+ censc(3,1,-i)=-censc(3,1,i)
+ do j=2,nlob(i)
+ read (irotam,*,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)
+ censc(1,j,-i)=censc(1,j,i)
+ censc(2,j,-i)=censc(2,j,i)
+ censc(3,j,-i)=-censc(3,j,i)
+C BSC is amplitude of Gaussian
+ enddo
+ do j=1,nlob(i)
+ do k=1,3
+ 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
+ if (((k.eq.3).and.(l.ne.3))
+ & .or.((l.eq.3).and.(k.ne.3))) then
+ gaussc(k,l,j,-i)=-akl
+ gaussc(l,k,j,-i)=-akl
+ else
+ gaussc(k,l,j,-i)=akl
+ gaussc(l,k,j,-i)=akl
+ endif
+ enddo
+ enddo
+ enddo
+ 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)
+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
+#ifdef NEWCORR
+ read (ifourier,*,end=115,err=115) (itype2loc(i),i=1,ntyp)
+ read (ifourier,*,end=115,err=115) (iloctyp(i),i=0,nloctyp-1)
+ itype2loc(ntyp1)=nloctyp
+ iloctyp(nloctyp)=ntyp1
+ do i=1,ntyp1
+ itype2loc(-i)=-itype2loc(i)
+ enddo
+#else
+ iloctyp(0)=10
+ iloctyp(1)=9
+ iloctyp(2)=20
+ iloctyp(3)=ntyp1
+#endif
+ do i=1,nloctyp
+ iloctyp(-i)=-iloctyp(i)
+ enddo
+c write (iout,*) "itype2loc",(itype2loc(i),i=1,ntyp1)
+c write (iout,*) "nloctyp",nloctyp,
+c & " iloctyp",(iloctyp(i),i=0,nloctyp)
+#ifdef NEWCORR
+ do i=0,nloctyp-1
+c write (iout,*) "NEWCORR",i
+ read (ifourier,*,end=115,err=115)
+ do ii=1,3
+ do j=1,2
+ read (ifourier,*,end=115,err=115) bnew1(ii,j,i)
+ enddo
+ enddo
+c write (iout,*) "NEWCORR BNEW1"
+c write (iout,*) ((bnew1(ii,j,i),ii=1,3),j=1,2)
+ do ii=1,3
+ do j=1,2
+ read (ifourier,*,end=115,err=115) bnew2(ii,j,i)
+ enddo
+ enddo
+c write (iout,*) "NEWCORR BNEW2"
+c write (iout,*) ((bnew2(ii,j,i),ii=1,3),j=1,2)
+ do kk=1,3
+ read (ifourier,*,end=115,err=115) ccnew(kk,1,i)
+ read (ifourier,*,end=115,err=115) ccnew(kk,2,i)
+ enddo
+c write (iout,*) "NEWCORR CCNEW"
+c write (iout,*) ((ccnew(ii,j,i),ii=1,3),j=1,2)
+ do kk=1,3
+ read (ifourier,*,end=115,err=115) ddnew(kk,1,i)
+ read (ifourier,*,end=115,err=115) ddnew(kk,2,i)
+ enddo
+c write (iout,*) "NEWCORR DDNEW"
+c write (iout,*) ((ddnew(ii,j,i),ii=1,3),j=1,2)
+ do ii=1,2
+ do jj=1,2
+ do kk=1,2
+ read (ifourier,*,end=115,err=115) eenew(ii,jj,kk,i)
+ enddo
+ enddo
+ enddo
+c write (iout,*) "NEWCORR EENEW1"
+c write(iout,*)(((eenew(ii,jj,kk,i),kk=1,2),jj=1,2),ii=1,2)
+ do ii=1,3
+ read (ifourier,*,end=115,err=115) e0new(ii,i)
+ enddo
+c write (iout,*) (e0new(ii,i),ii=1,3)
+ enddo
+c write (iout,*) "NEWCORR EENEW"
+ do i=0,nloctyp-1
+ do ii=1,3
+ ccnew(ii,1,i)=ccnew(ii,1,i)/2
+ ccnew(ii,2,i)=ccnew(ii,2,i)/2
+ ddnew(ii,1,i)=ddnew(ii,1,i)/2
+ ddnew(ii,2,i)=ddnew(ii,2,i)/2
+ enddo
+ enddo
+ do i=1,nloctyp-1
+ do ii=1,3
+ bnew1(ii,1,-i)= bnew1(ii,1,i)
+ bnew1(ii,2,-i)=-bnew1(ii,2,i)
+ bnew2(ii,1,-i)= bnew2(ii,1,i)
+ bnew2(ii,2,-i)=-bnew2(ii,2,i)
+ enddo
+ do ii=1,3
+c ccnew(ii,1,i)=ccnew(ii,1,i)/2
+c ccnew(ii,2,i)=ccnew(ii,2,i)/2
+c ddnew(ii,1,i)=ddnew(ii,1,i)/2
+c ddnew(ii,2,i)=ddnew(ii,2,i)/2
+ ccnew(ii,1,-i)=ccnew(ii,1,i)
+ ccnew(ii,2,-i)=-ccnew(ii,2,i)
+ ddnew(ii,1,-i)=ddnew(ii,1,i)
+ ddnew(ii,2,-i)=-ddnew(ii,2,i)
+ enddo
+ e0new(1,-i)= e0new(1,i)
+ e0new(2,-i)=-e0new(2,i)
+ e0new(3,-i)=-e0new(3,i)
+ do kk=1,2
+ eenew(kk,1,1,-i)= eenew(kk,1,1,i)
+ eenew(kk,1,2,-i)=-eenew(kk,1,2,i)
+ eenew(kk,2,1,-i)=-eenew(kk,2,1,i)
+ eenew(kk,2,2,-i)= eenew(kk,2,2,i)
+ enddo
+ enddo
+ if (lprint) then
+ write (iout,'(a)') "Coefficients of the multibody terms"
+ do i=-nloctyp+1,nloctyp-1
+ write (iout,*) "Type: ",onelet(iloctyp(i))
+ write (iout,*) "Coefficients of the expansion of B1"
+ do j=1,2
+ write (iout,'(3hB1(,i1,1h),3f10.5)') j,(bnew1(k,j,i),k=1,3)
+ enddo
+ write (iout,*) "Coefficients of the expansion of B2"
+ do j=1,2
+ write (iout,'(3hB2(,i1,1h),3f10.5)') j,(bnew2(k,j,i),k=1,3)
+ enddo
+ write (iout,*) "Coefficients of the expansion of C"
+ write (iout,'(3hC11,3f10.5)') (ccnew(j,1,i),j=1,3)
+ write (iout,'(3hC12,3f10.5)') (ccnew(j,2,i),j=1,3)
+ write (iout,*) "Coefficients of the expansion of D"
+ write (iout,'(3hD11,3f10.5)') (ddnew(j,1,i),j=1,3)
+ write (iout,'(3hD12,3f10.5)') (ddnew(j,2,i),j=1,3)
+ write (iout,*) "Coefficients of the expansion of E"
+ write (iout,'(2hE0,3f10.5)') (e0new(j,i),j=1,3)
+ do j=1,2
+ do k=1,2
+ write (iout,'(1hE,2i1,2f10.5)') j,k,(eenew(l,j,k,i),l=1,2)
+ enddo
+ enddo
+ enddo
+ endif
+#else
+ if (lprint)
+ & write (iout,*) "Coefficients of the expansion of Eloc(l1,l2)"
+ do i=0,nloctyp-1
+ read (ifourier,*,end=115,err=115)
+ read (ifourier,*,end=115,err=115) (b(ii,i),ii=1,13)
+ if (lprint) then
+ write (iout,*) 'Type ',onelet(iloctyp(i))
+ write (iout,'(a,i2,a,f10.5)') ('b(',ii,')=',b(ii,i),ii=1,13)
+ endif
+ if (i.gt.0) then
+ b(2,-i)= b(2,i)
+ b(3,-i)= b(3,i)
+ b(4,-i)=-b(4,i)
+ b(5,-i)=-b(5,i)
+ endif
+c B1(1,i) = b(3)
+c B1(2,i) = b(5)
+c B1(1,-i) = b(3)
+c B1(2,-i) = -b(5)
+c b1(1,i)=0.0d0
+c b1(2,i)=0.0d0
+c B1tilde(1,i) = b(3)
+c B1tilde(2,i) =-b(5)
+c B1tilde(1,-i) =-b(3)
+c B1tilde(2,-i) =b(5)
+c b1tilde(1,i)=0.0d0
+c b1tilde(2,i)=0.0d0
+c B2(1,i) = b(2)
+c B2(2,i) = b(4)
+c B2(1,-i) =b(2)
+c B2(2,-i) =-b(4)
+cc B1tilde(1,i) = b(3,i)
+cc B1tilde(2,i) =-b(5,i)
+C B1tilde(1,-i) =-b(3,i)
+C B1tilde(2,-i) =b(5,i)
+cc b1tilde(1,i)=0.0d0
+cc b1tilde(2,i)=0.0d0
+cc B2(1,i) = b(2,i)
+cc B2(2,i) = b(4,i)
+C B2(1,-i) =b(2,i)
+C B2(2,-i) =-b(4,i)
+
+c b2(1,i)=0.0d0
+c b2(2,i)=0.0d0
+ CCold(1,1,i)= b(7,i)
+ CCold(2,2,i)=-b(7,i)
+ CCold(2,1,i)= b(9,i)
+ CCold(1,2,i)= b(9,i)
+ CCold(1,1,-i)= b(7,i)
+ CCold(2,2,-i)=-b(7,i)
+ CCold(2,1,-i)=-b(9,i)
+ CCold(1,2,-i)=-b(9,i)
+c CC(1,1,i)=0.0d0
+c CC(2,2,i)=0.0d0
+c CC(2,1,i)=0.0d0
+c CC(1,2,i)=0.0d0
+c Ctilde(1,1,i)= CCold(1,1,i)
+c Ctilde(1,2,i)= CCold(1,2,i)
+c Ctilde(2,1,i)=-CCold(2,1,i)
+c Ctilde(2,2,i)=-CCold(2,2,i)
+
+c Ctilde(1,1,i)=0.0d0
+c Ctilde(1,2,i)=0.0d0
+c Ctilde(2,1,i)=0.0d0
+c Ctilde(2,2,i)=0.0d0
+ DDold(1,1,i)= b(6,i)
+ DDold(2,2,i)=-b(6,i)
+ DDold(2,1,i)= b(8,i)
+ DDold(1,2,i)= b(8,i)
+ DDold(1,1,-i)= b(6,i)
+ DDold(2,2,-i)=-b(6,i)
+ DDold(2,1,-i)=-b(8,i)
+ DDold(1,2,-i)=-b(8,i)
+c DD(1,1,i)=0.0d0
+c DD(2,2,i)=0.0d0
+c DD(2,1,i)=0.0d0
+c DD(1,2,i)=0.0d0
+c Dtilde(1,1,i)= DD(1,1,i)
+c Dtilde(1,2,i)= DD(1,2,i)
+c Dtilde(2,1,i)=-DD(2,1,i)
+c Dtilde(2,2,i)=-DD(2,2,i)
+
+c Dtilde(1,1,i)=0.0d0
+c Dtilde(1,2,i)=0.0d0
+c Dtilde(2,1,i)=0.0d0
+c Dtilde(2,2,i)=0.0d0
+ 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)
+ write(iout,*) "TU DOCHODZE"
+ print *,"JESTEM"
+c ee(1,1,i)=1.0d0
+c ee(2,2,i)=1.0d0
+c ee(2,1,i)=0.0d0
+c ee(1,2,i)=0.0d0
+c ee(2,1,i)=ee(1,2,i)
+ enddo
+ if (lprint) then
+ write (iout,*)
+ write (iout,*)
+ &"Coefficients of the cumulants (independent of valence angles)"
+ do i=-nloctyp+1,nloctyp-1
+ write (iout,*) 'Type ',onelet(iloctyp(i))
+ write (iout,*) 'B1'
+ write(iout,'(2f10.5)') B(3,i),B(5,i)
+ write (iout,*) 'B2'
+ write(iout,'(2f10.5)') B(2,i),B(4,i)
+ write (iout,*) 'CC'
+ do j=1,2
+ write (iout,'(2f10.5)') CCold(j,1,i),CCold(j,2,i)
+ enddo
+ write(iout,*) 'DD'
+ do j=1,2
+ write (iout,'(2f10.5)') DDold(j,1,i),DDold(j,2,i)
+ enddo
+ write(iout,*) 'EE'
+ do j=1,2
+ write (iout,'(2f10.5)') EEold(j,1,i),EEold(j,2,i)
+ enddo
+ enddo
+ endif
+#endif
+C write (iout,*) 'KURWAKURWA'
+#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
+ IF (TOR_MODE.eq.0) THEN
+
+ read (itorp,*,end=113,err=113) ntortyp
+ read (itorp,*,end=113,err=113) (itortyp(i),i=1,ntyp)
+ do i=1,ntyp1
+ itype2loc(i)=itortyp(i)
+ enddo
+ write (iout,*) 'ntortyp',ntortyp
+ do i=1,ntyp1
+ itype2loc(-i)=-itype2loc(i)
+ enddo
+ itortyp(ntyp1)=ntortyp
+ do iblock=1,2
+ do i=-ntyp,-1
+ itortyp(i)=-itortyp(-i)
+ enddo
+c write (iout,*) 'ntortyp',ntortyp
+ do i=0,ntortyp-1
+ do j=-ntortyp+1,ntortyp-1
+ read (itorp,*,end=113,err=113) nterm(i,j,iblock),
+ & nlor(i,j,iblock)
+ nterm(-i,-j,iblock)=nterm(i,j,iblock)
+ nlor(-i,-j,iblock)=nlor(i,j,iblock)
+ v0ij=0.0d0
+ si=-1.0d0
+ do k=1,nterm(i,j,iblock)
+ read (itorp,*,end=113,err=113) kk,v1(k,i,j,iblock),
+ & v2(k,i,j,iblock)
+ v1(k,-i,-j,iblock)=v1(k,i,j,iblock)
+ v2(k,-i,-j,iblock)=-v2(k,i,j,iblock)
+ v0ij=v0ij+si*v1(k,i,j,iblock)
+ si=-si
+ enddo
+ do k=1,nlor(i,j,iblock)
+ 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,iblock)=v0ij
+ v0(-i,-j,iblock)=v0ij
+ enddo
+ enddo
+ enddo
+ close (itorp)
+ if (lprint) then
+ write (iout,'(/a/)') 'Torsional constants:'
+ do i=1,ntortyp
+ do j=1,ntortyp
+ write (iout,*) 'ityp',i,' jtyp',j
+ write (iout,*) 'Fourier constants'
+ do k=1,nterm(i,j,iblock)
+ write (iout,'(2(1pe15.5))') v1(k,i,j,iblock),
+ & v2(k,i,j,iblock)
+ enddo
+ write (iout,*) 'Lorenz constants'
+ do k=1,nlor(i,j,iblock)
+ 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 iblock=1,2
+ do i=0,ntortyp-1
+ do j=-ntortyp+1,ntortyp-1
+ do k=-ntortyp+1,ntortyp-1
+ read (itordp,'(3a1)',end=114,err=114) t1,t2,t3
+c write (iout,*) "OK onelett",
+c & i,j,k,t1,t2,t3
+
+ if (t1.ne.toronelet(i) .or. t2.ne.toronelet(j)
+ & .or. t3.ne.toronelet(k)) then
+ write (iout,*) "Error in double torsional parameter file",
+ & i,j,k,t1,t2,t3
+#ifdef MPI
+ call MPI_Finalize(Ierror)
+#endif
+ stop "Error in double torsional parameter file"
+ endif
+ read (itordp,*,end=114,err=114) ntermd_1(i,j,k,iblock),
+ & ntermd_2(i,j,k,iblock)
+ ntermd_1(-i,-j,-k,iblock)=ntermd_1(i,j,k,iblock)
+ ntermd_2(-i,-j,-k,iblock)=ntermd_2(i,j,k,iblock)
+ read (itordp,*,end=114,err=114) (v1c(1,l,i,j,k,iblock),l=1,
+ & ntermd_1(i,j,k,iblock))
+ read (itordp,*,end=114,err=114) (v1s(1,l,i,j,k,iblock),l=1,
+ & ntermd_1(i,j,k,iblock))
+ read (itordp,*,end=114,err=114) (v1c(2,l,i,j,k,iblock),l=1,
+ & ntermd_1(i,j,k,iblock))
+ read (itordp,*,end=114,err=114) (v1s(2,l,i,j,k,iblock),l=1,
+ & ntermd_1(i,j,k,iblock))
+C Martix of D parameters for one dimesional foureir series
+ do l=1,ntermd_1(i,j,k,iblock)
+ v1c(1,l,-i,-j,-k,iblock)=v1c(1,l,i,j,k,iblock)
+ v1s(1,l,-i,-j,-k,iblock)=-v1s(1,l,i,j,k,iblock)
+ v1c(2,l,-i,-j,-k,iblock)=v1c(2,l,i,j,k,iblock)
+ v1s(2,l,-i,-j,-k,iblock)=-v1s(2,l,i,j,k,iblock)
+c write(iout,*) "whcodze" ,
+c & v1s(2,l,-i,-j,-k,iblock),v1s(2,l,i,j,k,iblock)
+ enddo
+ read (itordp,*,end=114,err=114) ((v2c(l,m,i,j,k,iblock),
+ & v2c(m,l,i,j,k,iblock),v2s(l,m,i,j,k,iblock),
+ & v2s(m,l,i,j,k,iblock),
+ & m=1,l-1),l=1,ntermd_2(i,j,k,iblock))
+C Martix of D parameters for two dimesional fourier series
+ do l=1,ntermd_2(i,j,k,iblock)
+ do m=1,l-1
+ v2c(l,m,-i,-j,-k,iblock)=v2c(l,m,i,j,k,iblock)
+ v2c(m,l,-i,-j,-k,iblock)=v2c(m,l,i,j,k,iblock)
+ v2s(l,m,-i,-j,-k,iblock)=-v2s(l,m,i,j,k,iblock)
+ v2s(m,l,-i,-j,-k,iblock)=-v2s(m,l,i,j,k,iblock)
+ enddo!m
+ enddo!l
+ enddo!k
+ enddo!j
+ enddo!i
+ enddo!iblock
+ if (lprint) then
+ write (iout,*)
+ write (iout,*) 'Constants for double torsionals'
+ do iblock=1,2
+ do i=0,ntortyp-1
+ do j=-ntortyp+1,ntortyp-1
+ do k=-ntortyp+1,ntortyp-1
+ write (iout,*) 'ityp',i,' jtyp',j,' ktyp',k,
+ & ' nsingle',ntermd_1(i,j,k,iblock),
+ & ' ndouble',ntermd_2(i,j,k,iblock)
+ write (iout,*)
+ write (iout,*) 'Single angles:'
+ do l=1,ntermd_1(i,j,k,iblock)
+ write (iout,'(i5,2f10.5,5x,2f10.5,5x,2f10.5)') l,
+ & v1c(1,l,i,j,k,iblock),v1s(1,l,i,j,k,iblock),
+ & v1c(2,l,i,j,k,iblock),v1s(2,l,i,j,k,iblock),
+ & v1s(1,l,-i,-j,-k,iblock),v1s(2,l,-i,-j,-k,iblock)
+ enddo
+ write (iout,*)
+ write (iout,*) 'Pairs of angles:'
+ write (iout,'(3x,20i10)') (l,l=1,ntermd_2(i,j,k,iblock))
+ do l=1,ntermd_2(i,j,k,iblock)
+ write (iout,'(i5,20f10.5)')
+ & l,(v2c(l,m,i,j,k,iblock),m=1,ntermd_2(i,j,k,iblock))
+ enddo
+ write (iout,*)
+ write (iout,'(3x,20i10)') (l,l=1,ntermd_2(i,j,k,iblock))
+ do l=1,ntermd_2(i,j,k,iblock)
+ write (iout,'(i5,20f10.5)')
+ & l,(v2s(l,m,i,j,k,iblock),m=1,ntermd_2(i,j,k,iblock)),
+ & (v2s(l,m,-i,-j,-k,iblock),m=1,ntermd_2(i,j,k,iblock))
+ enddo
+ write (iout,*)
+ enddo
+ enddo
+ enddo
+ enddo
+ endif
+
+ ELSE IF (TOR_MODE.eq.1) THEN
+
+C read valence-torsional parameters
+ read (itorp,*,end=113,err=113) ntortyp
+ nkcctyp=ntortyp
+ write (iout,*) "Valence-torsional parameters read in ntortyp",
+ & ntortyp
+ read (itorp,*,end=113,err=113) (itortyp(i),i=1,ntyp)
+ write (iout,*) "itortyp_kcc",(itortyp(i),i=1,ntyp)
+ do i=-ntyp,-1
+ itortyp(i)=-itortyp(-i)
+ enddo
+ do i=-ntortyp+1,ntortyp-1
+ do j=-ntortyp+1,ntortyp-1
+C first we read the cos and sin gamma parameters
+ read (itorp,'(13x,a)',end=113,err=113) string
+ write (iout,*) i,j,string
+ read (itorp,*,end=113,err=113)
+ & nterm_kcc(j,i),nterm_kcc_Tb(j,i)
+C read (itorkcc,*,end=121,err=121) nterm_kcc_Tb(j,i)
+ do k=1,nterm_kcc(j,i)
+ do l=1,nterm_kcc_Tb(j,i)
+ do ll=1,nterm_kcc_Tb(j,i)
+ read (itorp,*,end=113,err=113) ii,jj,kk,
+ & v1_kcc(ll,l,k,j,i),v2_kcc(ll,l,k,j,i)
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+
+ ELSE
+c AL 4/8/16: Calculate coefficients from one-body parameters
+ ntortyp=nloctyp
+ do i=-ntyp1,ntyp1
+ itortyp(i)=itype2loc(i)
+ enddo
+ write (iout,*)
+ &"Val-tor parameters calculated from cumulant coefficients ntortyp"
+ & ,ntortyp
+ do i=-ntortyp+1,ntortyp-1
+ do j=-ntortyp+1,ntortyp-1
+ nterm_kcc(j,i)=2
+ nterm_kcc_Tb(j,i)=3
+ do k=1,nterm_kcc_Tb(j,i)
+ do l=1,nterm_kcc_Tb(j,i)
+ v1_kcc(k,l,1,i,j)=bnew1(k,1,i)*bnew2(l,1,j)
+ & +bnew1(k,2,i)*bnew2(l,2,j)
+ v2_kcc(k,l,1,i,j)=bnew1(k,1,i)*bnew2(l,2,j)
+ & +bnew1(k,2,i)*bnew2(l,1,j)
+ enddo
+ enddo
+ do k=1,nterm_kcc_Tb(j,i)
+ do l=1,nterm_kcc_Tb(j,i)
+ v1_kcc(k,l,2,i,j)=-0.25*(ccnew(k,1,i)*ddnew(l,1,j)
+ & -ccnew(k,2,i)*ddnew(l,2,j))
+ v2_kcc(k,l,2,i,j)=-0.25*(ccnew(k,2,i)*ddnew(l,1,j)
+ & +ccnew(k,1,i)*ddnew(l,2,j))
+ enddo
+ enddo
+cf(theta,gamma)=-(b21(theta)*b11(theta)+b12(theta)*b22(theta))*cos(gamma)-(b22(theta)*b11(theta)+b21(theta)*b12(theta))*sin(gamma)+(c11(theta)*d11(theta)-c12(theta)*d12(theta))*cos(2*gamma)+(c12(theta)*d11(theta)+c11(theta)*d12(theta))*sin(2*gamma)
+ enddo
+ enddo
+
+ ENDIF ! TOR_MODE
+
+ if (tor_mode.gt.0 .and. lprint) then
+c Print valence-torsional parameters
+ write (iout,'(a)')
+ & "Parameters of the valence-torsional potentials"
+ do i=-ntortyp+1,ntortyp-1
+ do j=-ntortyp+1,ntortyp-1
+ write (iout,'(3a)') "Type ",toronelet(i),toronelet(j)
+ write (iout,'(3a5,2a15)') "itor","ival","jval","v_kcc","v2_kcc"
+ do k=1,nterm_kcc(j,i)
+ do l=1,nterm_kcc_Tb(j,i)
+ do ll=1,nterm_kcc_Tb(j,i)
+ write (iout,'(3i5,2f15.4)')
+ & k,l-1,ll-1,v1_kcc(ll,l,k,j,i),v2_kcc(ll,l,k,j,i)
+ enddo
+ enddo
+ 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)
+ do i=-ntyp,-1
+ isccortyp(i)=-isccortyp(-i)
+ enddo
+ iscprol=isccortyp(20)
+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)
+c write (iout,*) nterm_sccor(i,j)
+ v0ijsccor=0.0d0
+ v0ijsccor1=0.0d0
+ v0ijsccor2=0.0d0
+ v0ijsccor3=0.0d0
+ si=-1.0d0
+ nterm_sccor(-i,j)=nterm_sccor(i,j)
+ nterm_sccor(-i,-j)=nterm_sccor(i,j)
+ nterm_sccor(i,-j)=nterm_sccor(i,j)
+c write (iout,*) nterm_sccor(i,j),nterm_sccor(-i,j),
+c & nterm_sccor(-i,-j),nterm_sccor(i,-j)
+ do k=1,nterm_sccor(i,j)
+ read (isccor,*,end=119,err=119) kk,v1sccor(k,l,i,j)
+ & ,v2sccor(k,l,i,j)
+ if (j.eq.iscprol) then
+ if (i.eq.isccortyp(10)) then
+ v1sccor(k,l,i,-j)=v1sccor(k,l,i,j)
+ v2sccor(k,l,i,-j)=-v2sccor(k,l,i,j)
+ else
+ v1sccor(k,l,i,-j)=v1sccor(k,l,i,j)*0.5d0
+ & +v2sccor(k,l,i,j)*dsqrt(0.75d0)
+ v2sccor(k,l,i,-j)=-v2sccor(k,l,i,j)*0.5d0
+ & +v1sccor(k,l,i,j)*dsqrt(0.75d0)
+ v1sccor(k,l,-i,-j)=v1sccor(k,l,i,j)
+ v2sccor(k,l,-i,-j)=-v2sccor(k,l,i,j)
+ v1sccor(k,l,-i,j)=v1sccor(k,l,i,-j)
+ v2sccor(k,l,-i,j)=-v2sccor(k,l,i,-j)
+ endif
+ else
+ if (i.eq.isccortyp(10)) then
+ v1sccor(k,l,i,-j)=v1sccor(k,l,i,j)
+ v2sccor(k,l,i,-j)=-v2sccor(k,l,i,j)
+ else
+ if (j.eq.isccortyp(10)) then
+ v1sccor(k,l,-i,j)=v1sccor(k,l,i,j)
+ v2sccor(k,l,-i,j)=-v2sccor(k,l,i,j)
+ else
+ v1sccor(k,l,i,-j)=-v1sccor(k,l,i,j)
+ v2sccor(k,l,i,-j)=-v2sccor(k,l,i,j)
+ v1sccor(k,l,-i,-j)=v1sccor(k,l,i,j)
+ v2sccor(k,l,-i,-j)=-v2sccor(k,l,i,j)
+ v1sccor(k,l,-i,j)=v1sccor(k,l,i,-j)
+ v2sccor(k,l,-i,j)=-v2sccor(k,l,i,-j)
+ endif
+ endif
+ endif
+ v0ijsccor=v0ijsccor+si*v1sccor(k,l,i,j)
+ v0ijsccor1=v0ijsccor+si*v1sccor(k,l,-i,j)
+ v0ijsccor2=v0ijsccor+si*v1sccor(k,l,i,-j)
+ v0ijsccor3=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(l,i,j)=v0ijsccor
+ v0sccor(l,-i,j)=v0ijsccor1
+ v0sccor(l,i,-j)=v0ijsccor2
+ v0sccor(l,-i,-j)=v0ijsccor3
+ enddo
+ enddo
+ enddo
+ close (isccor)
+ if (lprint) then
+ write (iout,'(/a/)') 'Torsional constants of SCCORR:'
+ do l=1,maxinter
+ 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)
+ 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
+ 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
+ lprint=.true.
+ if (lprint) write(iout,'(2i3,4(1pe15.4))')i,j,app(i,j),bpp(i,j),
+ & ael6(i,j),ael3(i,j)
+ lprint=.false.
+ enddo
+ enddo
+C
+C Read side-chain interaction parameters.
+C
+ read (isidep,*,end=117,err=117) ipot,expon
+ if (ipot.lt.1 .or. ipot.gt.5) 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) 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 50
+C----------------------- LJK potential --------------------------------
+ 20 read (isidep,*,end=117,err=117)((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 50
+C---------------------- GB or BP potential -----------------------------
+ 30 do i=1,ntyp
+ read (isidep,*,end=117,err=117)(eps(i,j),j=i,ntyp)
+ enddo
+ read (isidep,*,end=117,err=117)(sigma0(i),i=1,ntyp)
+ read (isidep,*,end=117,err=117)(sigii(i),i=1,ntyp)
+ read (isidep,*,end=117,err=117)(chip(i),i=1,ntyp)
+ read (isidep,*,end=117,err=117)(alp(i),i=1,ntyp)
+ do i=1,ntyp
+ read (isidep,*,end=117,err=117)(epslip(i,j),j=i,ntyp)
+C write(iout,*) "WARNING!!",i,ntyp
+ write(iout,*) "epslip", i, (epslip(i,j),j=i,ntyp)
+C do j=1,ntyp
+C epslip(i,j)=epslip(i,j)+0.05d0
+C enddo
+ enddo
+C For the GB potential convert sigma'**2 into chi'
+ if (ipot.eq.4) then
+ do i=1,ntyp
+ chip(i)=(chip(i)-1.0D0)/(chip(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 50
+C--------------------- GBV potential -----------------------------------
+ 40 read (isidep,*,end=117,err=117)((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
+ 50 continue
+ close (isidep)
+C-----------------------------------------------------------------------
+C Calculate the "working" parameters of SC interactions.
+ do i=2,ntyp
+ do j=1,i-1
+ eps(i,j)=eps(j,i)
+ epslip(i,j)=epslip(j,i)
+ enddo
+ enddo
+ do i=1,ntyp
+ 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
+ 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)
+ epsijlip=epslip(i,j)
+ if (ipot.eq.1 .or. ipot.eq.3 .or. ipot.eq.4) 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_aq(i,j)=epsij*rrij*rrij
+ bb_aq(i,j)=-sigeps*epsij*rrij
+ aa_aq(j,i)=aa_aq(i,j)
+ bb_aq(j,i)=bb_aq(i,j)
+ sigeps=dsign(1.0D0,epsijlip)
+ epsijlip=dabs(epsijlip)
+ aa_lip(i,j)=epsijlip*rrij*rrij
+ bb_lip(i,j)=-sigeps*epsijlip*rrij
+ aa_lip(j,i)=aa_lip(i,j)
+ bb_lip(j,i)=bb_lip(i,j)
+ if (ipot.gt.2) then
+ sigt1sq=sigma0(i)**2
+ sigt2sq=sigma0(j)**2
+ sigii1=sigii(i)
+ 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
+ write (iout,'(2(a3,2x),3(1pe10.3),5(0pf8.3))')
+ & restyp(i),restyp(j),aa_aq(i,j),bb_aq(i,j),augm(i,j),
+ & sigma(i,j),r0(i,j),chi(i,j),chi(j,i)
+ endif
+ enddo
+ 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
+C ebr=-12.0D0
+c
+c Old arbitrary potential - commented out.
+c
+c dbr= 4.20D0
+c fbr= 3.30D0
+c
+c Constants of the disulfide-bond potential determined based on the RHF/6-31G**
+c energy surface of diethyl disulfide.
+c A. Liwo and U. Kozlowska, 11/24/03
+c
+C D0CM = 3.78d0
+C AKCM = 15.1d0
+C AKTH = 11.0d0
+C AKCT = 12.0d0
+C V1SS =-1.08d0
+C V2SS = 7.61d0
+C V3SS = 13.7d0
+ write (iout,*) dyn_ss,'dyndyn'
+ if (dyn_ss) then
+ ss_depth=ebr/wsc-0.25*eps(1,1)
+C write(iout,*) akcm,whpb,wsc,'KURWA'
+ Ht=Ht/wsc-0.25*eps(1,1)
+
+ akcm=akcm*whpb/wsc
+ akth=akth*whpb/wsc
+ akct=akct*whpb/wsc
+ v1ss=v1ss*whpb/wsc
+ v2ss=v2ss*whpb/wsc
+ v3ss=v3ss*whpb/wsc
+ else
+ ss_depth=ebr/whpb-0.25*eps(1,1)*wsc/whpb
+ endif
+
+C if (lprint) then
+ write (iout,'(/a)') "Disulfide bridge parameters:"
+ write (iout,'(a,f10.2)') 'S-S bridge energy: ',ebr
+ write (iout,'(2(a,f10.2))') 'd0cm:',d0cm,' akcm:',akcm
+ write (iout,'(2(a,f10.2))') 'akth:',akth,' akct:',akct
+ write (iout,'(3(a,f10.2))') 'v1ss:',v1ss,' v2ss:',v2ss,
+ & ' v3ss:',v3ss
+C endif
+ if (shield_mode.gt.0) then
+ pi=3.141592d0
+C VSolvSphere the volume of solving sphere
+C print *,pi,"pi"
+C rpp(1,1) is the energy r0 for peptide group contact and will be used for it
+C there will be no distinction between proline peptide group and normal peptide
+C group in case of shielding parameters
+ VSolvSphere=4.0/3.0*pi*rpp(1,1)**3
+ VSolvSphere_div=VSolvSphere-4.0/3.0*pi*(rpp(1,1)/2.0)**3
+ write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
+ & VSolvSphere_div
+C long axis of side chain
+ do i=1,ntyp
+ long_r_sidechain(i)=vbldsc0(1,i)
+ short_r_sidechain(i)=sigma0(i)
+ enddo
+ buff_shield=1.0d0
+ endif
+ return
+ 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
+ 1161 write (iout,*) "Error reading lipid 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"
+ goto 999
+ 121 write (iout,*) "Error reading bond parameters"
+ 999 continue
+#ifdef MPI
+ call MPI_Finalize(Ierror)
+#endif
+ stop
+ return
+ end
--- /dev/null
+ subroutine permut(isym,nperm,tabperm)
+c integer maxperm,maxsym
+c parameter (maxperm=3628800)
+c parameter (maxsym=10)
+ include "DIMENSIONS"
+ integer n,a,tabperm
+ logical nextp
+ external nextp
+ dimension a(isym),tabperm(maxchain,maxperm)
+ n=isym
+ nperm=1
+ if (n.eq.1) then
+ tabperm(1,1)=1
+ return
+ endif
+ do i=2,n
+ nperm=nperm*i
+ enddo
+ kkk=0
+ do i=1,n
+ a(i)=i
+ enddo
+ 10 continue
+c print '(i3,2x,100i3)',kkk+1,(a(i),i=1,n)
+ kkk=kkk+1
+ do i=1,n
+ tabperm(i,kkk)=a(i)
+ enddo
+ if(nextp(n,a)) go to 10
+ return
+ end
+
+ function nextp(n,a)
+ integer n,a,i,j,k,t
+ logical nextp
+ dimension a(n)
+ i=n-1
+ 10 if(a(i).lt.a(i+1)) go to 20
+ i=i-1
+ if(i.eq.0) go to 20
+ go to 10
+ 20 j=i+1
+ k=n
+ 30 t=a(j)
+ a(j)=a(k)
+ a(k)=t
+ j=j+1
+ k=k-1
+ if(j.lt.k) go to 30
+ j=i
+ if(j.ne.0) go to 40
+ nextp=.false.
+ return
+ 40 j=j+1
+ if(a(j).lt.a(i)) go to 40
+ t=a(i)
+ a(i)=a(j)
+ a(j)=t
+ nextp=.true.
+ return
+ end
--- /dev/null
+ 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
--- /dev/null
+ 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
--- /dev/null
+ 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
--- /dev/null
+#include <stdlib.h>
+#include <stdio.h>
+#include <math.h>
+
+#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;
+
+if (sscanf(buf,"%d",&j) != EOF)
+ *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
--- /dev/null
+ 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.ntyp1) then
+ dsc_inv(i)=0.0d0
+ else
+ dsc_inv(i)=1.0d0/dsc(i)
+ endif
+ enddo
+ return
+ end
--- /dev/null
+ double precision function qwolynes(ilevel,jfrag,kkk)
+ implicit none
+ include 'DIMENSIONS'
+ include 'DIMENSIONS.ZSCOPT'
+ include 'DIMENSIONS.COMPAR'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.COMPAR'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTROL'
+ integer ilevel,jfrag,kkk
+ integer i,j,jl,k,l,il,kl,nl,np,ip,kp
+ integer nsep /3/
+ integer iperm
+ 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
+c write (iout,*) "qwolynes: permutation",kkk
+ qq = 0.0d0
+ if (ilevel.eq.0) then
+ if (lprn) write (iout,*) "Q computed for whole molecule"
+ nl=0
+ do il=nnt+nsep,nct
+ if (itype(il).eq.ntyp1) cycle
+ do jl=nnt,il-nsep
+ if (itype(jl).eq.ntyp1) cycle
+ 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(iperm(il,kkk),iperm(jl,kkk))
+ 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(iperm(il,kkk)+nres,iperm(jl,kkk)+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 (itype(il).eq.ntyp1.or.itype(jl).eq.ntyp1) cycle
+ 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(iperm(il,kkk),iperm(jl,kkk))
+ 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(iperm(il,kkk)+nres,
+ & iperm(iperm(jl,kkk),kkk)+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)
+ if (itype(il).eq.ntyp1) cycle
+ do k=1,i-1
+ kp=ipiece(k,jfrag,ilevel)
+ do l=1,nlist_frag(kp)
+ kl=list_frag(l,kp)
+ if (itype(kl).eq.ntyp1) cycle
+ 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(iperm(il,kkk),iperm(kl,kkk))
+ 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(iperm(il,kkk)+nres,iperm(kl,kkk)+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
--- /dev/null
+ subroutine read_constr_homology
+
+ include 'DIMENSIONS'
+ include 'DIMENSIONS.ZSCOPT'
+ include 'DIMENSIONS.FREE'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.SETUP'
+ include 'COMMON.CONTROL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.INTERACT'
+ include 'COMMON.NAMES'
+ include 'COMMON.HOMRESTR'
+ include 'COMMON.HOMOLOGY'
+c
+c For new homol impl
+c
+ include 'COMMON.VAR'
+c include 'include_unres/COMMON.VAR'
+c
+
+c double precision odl_temp,sigma_odl_temp,waga_theta,waga_d,
+c & dist_cut
+c common /przechowalnia/ odl_temp(maxres,maxres,max_template),
+c & sigma_odl_temp(maxres,maxres,max_template)
+ character*2 kic2
+ character*24 model_ki_dist, model_ki_angle
+ character*500 controlcard
+ integer ki, i, j, k, l, ii_in_use(maxdim),i_tmp,idomain_tmp
+ integer idomain(max_template,maxres)
+ logical lprn /.true./
+ integer ilen
+ external ilen
+ logical liiflag
+c
+c FP - Nov. 2014 Temporary specifications for new vars
+c
+ double precision rescore_tmp,x12,y12,z12,rescore2_tmp
+ double precision, dimension (max_template,maxres) :: rescore
+ double precision, dimension (max_template,maxres) :: rescore2
+ character*24 tpl_k_rescore
+c -----------------------------------------------------------------
+c Reading multiple PDB ref structures and calculation of retraints
+c not using pre-computed ones stored in files model_ki_{dist,angle}
+c FP (Nov., 2014)
+c -----------------------------------------------------------------
+c
+c
+c Alternative: reading from input
+ call card_concat(controlcard,.true.)
+ call reada(controlcard,"HOMOL_DIST",waga_dist,1.0d0)
+ call reada(controlcard,"HOMOL_ANGLE",waga_angle,1.0d0)
+ call reada(controlcard,"HOMOL_THETA",waga_theta,1.0d0) ! new
+ call reada(controlcard,"HOMOL_SCD",waga_d,1.0d0) ! new
+ call reada(controlcard,'DIST_CUT',dist_cut,5.0d0) ! for diff ways of calc sigma
+ call reada(controlcard,'DIST2_CUT',dist2_cut,9999.0d0)
+ call readi(controlcard,"HOMOL_NSET",homol_nset,1)
+ read2sigma=(index(controlcard,'READ2SIGMA').gt.0)
+ call readi(controlcard,"IHSET",ihset,1)
+ if (homol_nset.gt.1)then
+ call card_concat(controlcard,.true.)
+ read(controlcard,*) (waga_homology(i),i=1,homol_nset)
+c if(me.eq.king .or. .not. out1file .and. fg_rank.eq.0) then
+c write(iout,*) "iset homology_weight "
+c do i=1,homol_nset
+c write(iout,*) i,waga_homology(i)
+c enddo
+c endif
+ iset=mod(kolor,homol_nset)+1
+ else
+ iset=1
+ waga_homology(1)=1.0
+ endif
+c write(iout,*) "waga_homology(",iset,")",waga_homology(iset)
+
+cd write (iout,*) "nnt",nnt," nct",nct
+cd call flush(iout)
+
+
+ lim_odl=0
+ lim_dih=0
+c
+c New
+c
+ lim_theta=0
+ lim_xx=0
+c
+c Reading HM global scores (prob not required)
+c
+ do i = nnt,nct
+ do k=1,constr_homology
+ idomain(k,i)=0
+ enddo
+ enddo
+c open (4,file="HMscore")
+c do k=1,constr_homology
+c read (4,*,end=521) hmscore_tmp
+c hmscore(k)=hmscore_tmp ! Another transformation can be used
+c write(*,*) "Model", k, ":", hmscore(k)
+c enddo
+c521 continue
+
+ ii=0
+ do i = nnt,nct-2
+ do j=i+2,nct
+ ii=ii+1
+ ii_in_use(ii)=0
+ enddo
+ enddo
+c write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
+
+ if (read_homol_frag) then
+ call read_klapaucjusz
+ else
+
+ do k=1,constr_homology
+
+ read(inp,'(a)') pdbfile
+c Next stament causes error upon compilation (?)
+c if(me.eq.king.or. .not. out1file)
+c write (iout,'(2a)') 'PDB data will be read from file ',
+c & pdbfile(:ilen(pdbfile))
+ write (iout,'(a,5x,a)') 'HOMOL: Opening PDB file',
+ & pdbfile(:ilen(pdbfile))
+ open(ipdbin,file=pdbfile,status='old',err=33)
+ goto 34
+ 33 write (iout,'(a,5x,a)') 'Error opening PDB file',
+ & pdbfile(:ilen(pdbfile))
+ stop
+ 34 continue
+c print *,'Begin reading pdb data'
+c
+c Files containing res sim or local scores (former containing sigmas)
+c
+
+ write(kic2,'(bz,i2.2)') k
+
+ tpl_k_rescore="template"//kic2//".sco"
+
+ unres_pdb=.false.
+ if (read2sigma) then
+ call readpdb_template(k)
+ else
+ call readpdb
+ endif
+
+c call readpdb
+ do i=1,2*nres
+ do j=1,3
+ crefjlee(j,i)=c(j,i)
+ enddo
+ enddo
+#ifdef DEBUG
+ do i=1,nres
+ write (iout,'(i5,3f8.3,5x,3f8.3)') i,(crefjlee(j,i),j=1,3),
+ & (crefjlee(j,i+nres),j=1,3)
+ enddo
+ write (iout,*) "read_constr_homology: after reading pdb file"
+ call flush(iout)
+#endif
+
+c
+c Distance restraints
+c
+c ... --> odl(k,ii)
+C Copy the coordinates from reference coordinates (?)
+ do i=1,2*nres
+ do j=1,3
+ c(j,i)=cref(j,i)
+c write (iout,*) "c(",j,i,") =",c(j,i)
+ enddo
+ enddo
+c
+c From read_dist_constr (commented out 25/11/2014 <-> res sim)
+c
+c write(iout,*) "tpl_k_rescore - ",tpl_k_rescore
+ open (ientin,file=tpl_k_rescore,status='old')
+ if (nnt.gt.1) rescore(k,1)=0.0d0
+ do irec=nnt,nct ! loop for reading res sim
+ if (read2sigma) then
+ read (ientin,*,end=1401) i_tmp,rescore2_tmp,rescore_tmp,
+ & idomain_tmp
+ i_tmp=i_tmp+nnt-1
+ idomain(k,i_tmp)=idomain_tmp
+ rescore(k,i_tmp)=rescore_tmp
+ rescore2(k,i_tmp)=rescore2_tmp
+ write(iout,'(a7,i5,2f10.5,i5)') "rescore",
+ & i_tmp,rescore2_tmp,rescore_tmp,
+ & idomain_tmp
+ else
+ idomain(k,irec)=1
+ read (ientin,*,end=1401) rescore_tmp
+
+c rescore(k,irec)=rescore_tmp+1.0d0 ! to avoid 0 values
+ rescore(k,irec)=0.5d0*(rescore_tmp+0.5d0) ! alt transf to reduce scores
+c write(iout,*) "rescore(",k,irec,") =",rescore(k,irec)
+ endif
+ enddo
+ 1401 continue
+ close (ientin)
+ if (waga_dist.ne.0.0d0) then
+ ii=0
+ do i = nnt,nct-2
+ do j=i+2,nct
+
+ x12=c(1,i)-c(1,j)
+ y12=c(2,i)-c(2,j)
+ z12=c(3,i)-c(3,j)
+ distal=dsqrt(x12*x12+y12*y12+z12*z12)
+c write (iout,*) k,i,j,distal,dist2_cut
+
+ if (idomain(k,i).eq.idomain(k,j).and.idomain(k,i).ne.0
+ & .and. distal.le.dist2_cut ) then
+
+ ii=ii+1
+ ii_in_use(ii)=1
+ l_homo(k,ii)=.true.
+
+c write (iout,*) "k",k
+c write (iout,*) "i",i," j",j," constr_homology",
+c & constr_homology
+ ires_homo(ii)=i
+ jres_homo(ii)=j
+ odl(k,ii)=distal
+ if (read2sigma) then
+ sigma_odl(k,ii)=0
+ do ik=i,j
+ sigma_odl(k,ii)=sigma_odl(k,ii)+rescore2(k,ik)
+ enddo
+ sigma_odl(k,ii)=sigma_odl(k,ii)/(j-i+1)
+ if (odl(k,ii).gt.dist_cut) sigma_odl(k,ii) =
+ & sigma_odl(k,ii)*dexp(0.5d0*(odl(k,ii)/dist_cut)**2-0.5d0)
+ else
+ if (odl(k,ii).le.dist_cut) then
+ sigma_odl(k,ii)=rescore(k,i)+rescore(k,j)
+ else
+#ifdef OLDSIGMA
+ sigma_odl(k,ii)=(rescore(k,i)+rescore(k,j))*
+ & dexp(0.5d0*(odl(k,ii)/dist_cut)**2)
+#else
+ sigma_odl(k,ii)=(rescore(k,i)+rescore(k,j))*
+ & dexp(0.5d0*(odl(k,ii)/dist_cut)**2-0.5d0)
+#endif
+ endif
+ endif
+ sigma_odl(k,ii)=1.0d0/(sigma_odl(k,ii)*sigma_odl(k,ii))
+ else
+ ii=ii+1
+ l_homo(k,ii)=.false.
+ endif
+ enddo
+ enddo
+ lim_odl=ii
+ endif
+c
+c Theta, dihedral and SC retraints
+c
+ if (waga_angle.gt.0.0d0) then
+c open (ientin,file=tpl_k_sigma_dih,status='old')
+c do irec=1,maxres-3 ! loop for reading sigma_dih
+c read (ientin,*,end=1402) i,j,ki,l,sigma_dih(k,i+nnt-1) ! j,ki,l what for?
+c if (i+nnt-1.gt.lim_dih) lim_dih=i+nnt-1 ! right?
+c sigma_dih(k,i+nnt-1)=sigma_dih(k,i+nnt-1)* ! not inverse because of use of res. similarity
+c & sigma_dih(k,i+nnt-1)
+c enddo
+c1402 continue
+c close (ientin)
+ do i = nnt+3,nct
+ if (idomain(k,i).eq.0) then
+ sigma_dih(k,i)=0.0
+ cycle
+ endif
+ dih(k,i)=phiref(i) ! right?
+c read (ientin,*) sigma_dih(k,i) ! original variant
+c write (iout,*) "dih(",k,i,") =",dih(k,i)
+c write(iout,*) "rescore(",k,i,") =",rescore(k,i),
+c & "rescore(",k,i-1,") =",rescore(k,i-1),
+c & "rescore(",k,i-2,") =",rescore(k,i-2),
+c & "rescore(",k,i-3,") =",rescore(k,i-3)
+
+ sigma_dih(k,i)=(rescore(k,i)+rescore(k,i-1)+
+ & rescore(k,i-2)+rescore(k,i-3))/4.0
+c if (read2sigma) sigma_dih(k,i)=sigma_dih(k,i)/4.0
+c write (iout,*) "Raw sigmas for dihedral angle restraints"
+c write (iout,'(i5,10(2f8.2,4x))') i,sigma_dih(k,i)
+c sigma_dih(k,i)=hmscore(k)*rescore(k,i)*rescore(k,i-1)*
+c rescore(k,i-2)*rescore(k,i-3) ! right expression ?
+c Instead of res sim other local measure of b/b str reliability possible
+ if (sigma_dih(k,i).ne.0)
+ & sigma_dih(k,i)=1.0d0/(sigma_dih(k,i)*sigma_dih(k,i))
+c sigma_dih(k,i)=sigma_dih(k,i)*sigma_dih(k,i)
+ enddo
+ lim_dih=nct-nnt-2
+ endif
+
+ if (waga_theta.gt.0.0d0) then
+c open (ientin,file=tpl_k_sigma_theta,status='old')
+c do irec=1,maxres-2 ! loop for reading sigma_theta, right bounds?
+c read (ientin,*,end=1403) i,j,ki,sigma_theta(k,i+nnt-1) ! j,ki what for?
+c sigma_theta(k,i+nnt-1)=sigma_theta(k,i+nnt-1)* ! not inverse because of use of res. similarity
+c & sigma_theta(k,i+nnt-1)
+c enddo
+c1403 continue
+c close (ientin)
+
+ do i = nnt+2,nct ! right? without parallel.
+c do i = i=1,nres ! alternative for bounds acc to readpdb?
+c do i=ithet_start,ithet_end ! with FG parallel.
+ if (idomain(k,i).eq.0) then
+ sigma_theta(k,i)=0.0
+ cycle
+ endif
+ thetatpl(k,i)=thetaref(i)
+c write (iout,*) "thetatpl(",k,i,") =",thetatpl(k,i)
+c write(iout,*) "rescore(",k,i,") =",rescore(k,i),
+c & "rescore(",k,i-1,") =",rescore(k,i-1),
+c & "rescore(",k,i-2,") =",rescore(k,i-2)
+c read (ientin,*) sigma_theta(k,i) ! 1st variant
+ sigma_theta(k,i)=(rescore(k,i)+rescore(k,i-1)+
+ & rescore(k,i-2))/3.0
+c if (read2sigma) sigma_theta(k,i)=sigma_theta(k,i)/3.0
+ if (sigma_theta(k,i).ne.0)
+ & sigma_theta(k,i)=1.0d0/(sigma_theta(k,i)*sigma_theta(k,i))
+
+c sigma_theta(k,i)=hmscore(k)*rescore(k,i)*rescore(k,i-1)*
+c rescore(k,i-2) ! right expression ?
+c sigma_theta(k,i)=sigma_theta(k,i)*sigma_theta(k,i)
+ enddo
+ endif
+
+ if (waga_d.gt.0.0d0) then
+c open (ientin,file=tpl_k_sigma_d,status='old')
+c do irec=1,maxres-1 ! loop for reading sigma_theta, right bounds?
+c read (ientin,*,end=1404) i,j,sigma_d(k,i+nnt-1) ! j,ki what for?
+c sigma_d(k,i+nnt-1)=sigma_d(k,i+nnt-1)* ! not inverse because of use of res. similarity
+c & sigma_d(k,i+nnt-1)
+c enddo
+c1404 continue
+
+ do i = nnt,nct ! right? without parallel.
+c do i=2,nres-1 ! alternative for bounds acc to readpdb?
+c do i=loc_start,loc_end ! with FG parallel.
+ if (itype(i).eq.10) cycle
+ if (idomain(k,i).eq.0 ) then
+ sigma_d(k,i)=0.0
+ cycle
+ endif
+ xxtpl(k,i)=xxref(i)
+ yytpl(k,i)=yyref(i)
+ zztpl(k,i)=zzref(i)
+c write (iout,*) "xxtpl(",k,i,") =",xxtpl(k,i)
+c write (iout,*) "yytpl(",k,i,") =",yytpl(k,i)
+c write (iout,*) "zztpl(",k,i,") =",zztpl(k,i)
+c write(iout,*) "rescore(",k,i,") =",rescore(k,i)
+ sigma_d(k,i)=rescore(k,i) ! right expression ?
+ if (sigma_d(k,i).ne.0)
+ & sigma_d(k,i)=1.0d0/(sigma_d(k,i)*sigma_d(k,i))
+
+c sigma_d(k,i)=hmscore(k)*rescore(k,i) ! right expression ?
+c sigma_d(k,i)=sigma_d(k,i)*sigma_d(k,i)
+c read (ientin,*) sigma_d(k,i) ! 1st variant
+ enddo
+ endif
+ enddo
+c
+c remove distance restraints not used in any model from the list
+c shift data in all arrays
+c
+ if (waga_dist.ne.0.0d0) then
+ ii=0
+ liiflag=.true.
+ do i=nnt,nct-2
+ do j=i+2,nct
+ ii=ii+1
+ if (ii_in_use(ii).eq.0.and.liiflag) then
+ liiflag=.false.
+ iistart=ii
+ endif
+ if (ii_in_use(ii).ne.0.and..not.liiflag.or.
+ & .not.liiflag.and.ii.eq.lim_odl) then
+ if (ii.eq.lim_odl) then
+ iishift=ii-iistart+1
+ else
+ iishift=ii-iistart
+ endif
+ liiflag=.true.
+ do ki=iistart,lim_odl-iishift
+ ires_homo(ki)=ires_homo(ki+iishift)
+ jres_homo(ki)=jres_homo(ki+iishift)
+ ii_in_use(ki)=ii_in_use(ki+iishift)
+ do k=1,constr_homology
+ odl(k,ki)=odl(k,ki+iishift)
+ sigma_odl(k,ki)=sigma_odl(k,ki+iishift)
+ l_homo(k,ki)=l_homo(k,ki+iishift)
+ enddo
+ enddo
+ ii=ii-iishift
+ lim_odl=lim_odl-iishift
+ endif
+ enddo
+ enddo
+ endif
+
+ endif ! .not. klapaucjusz
+
+ if (constr_homology.gt.0) call homology_partition
+ if (constr_homology.gt.0) call init_int_table
+cd write (iout,*) "homology_partition: lim_theta= ",lim_theta,
+cd & "lim_xx=",lim_xx
+c write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
+c write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
+c
+c Print restraints
+c
+ if (.not.lprn) return
+cd write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
+c if(me.eq.king .or. .not. out1file .and. fg_rank.eq.0) then
+ write (iout,*) "Distance restraints from templates"
+ do ii=1,lim_odl
+ write(iout,'(3i5,100(2f8.2,1x,l1,4x))')
+ & ii,ires_homo(ii),jres_homo(ii),
+ & (odl(ki,ii),1.0d0/dsqrt(sigma_odl(ki,ii)),l_homo(ki,ii),
+ & ki=1,constr_homology)
+ enddo
+ write (iout,*) "Dihedral angle restraints from templates"
+ do i=nnt+3,nct
+ write (iout,'(i5,a4,100(2f8.2,4x))') i,restyp(itype(i)),
+ & (rad2deg*dih(ki,i),
+ & rad2deg/dsqrt(sigma_dih(ki,i)),ki=1,constr_homology)
+ enddo
+ write (iout,*) "Virtual-bond angle restraints from templates"
+ do i=nnt+2,nct
+ write (iout,'(i5,a4,100(2f8.2,4x))') i,restyp(itype(i)),
+ & (rad2deg*thetatpl(ki,i),
+ & rad2deg/dsqrt(sigma_theta(ki,i)),ki=1,constr_homology)
+ enddo
+ write (iout,*) "SC restraints from templates"
+ do i=nnt,nct
+ write(iout,'(i5,100(4f8.2,4x))') i,
+ & (xxtpl(ki,i),yytpl(ki,i),zztpl(ki,i),
+ & 1.0d0/dsqrt(sigma_d(ki,i)),ki=1,constr_homology)
+ enddo
+c endif
+c -----------------------------------------------------------------
+ return
+ end
+c----------------------------------------------------------------------
+ subroutine read_klapaucjusz
+
+ include 'DIMENSIONS'
+ include 'DIMENSIONS.ZSCOPT'
+ include 'DIMENSIONS.FREE'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.SETUP'
+ include 'COMMON.CONTROL'
+ include 'COMMON.HOMOLOGY'
+ include 'COMMON.CHAIN'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.INTERACT'
+ include 'COMMON.NAMES'
+ include 'COMMON.HOMRESTR'
+ character*256 fragfile
+ integer ninclust(maxclust),inclust(max_template,maxclust),
+ & nresclust(maxclust),iresclust(maxres,maxclust)
+
+ character*2 kic2
+ character*24 model_ki_dist, model_ki_angle
+ character*500 controlcard
+ integer ki, i, j, k, l, ii_in_use(maxdim),i_tmp,idomain_tmp
+ integer idomain(max_template,maxres)
+ logical lprn /.true./
+ integer ilen
+ external ilen
+ logical liiflag
+c
+c
+ double precision rescore_tmp,x12,y12,z12,rescore2_tmp
+ double precision, dimension (max_template,maxres) :: rescore
+ double precision, dimension (max_template,maxres) :: rescore2
+ character*24 tpl_k_rescore
+
+c
+c For new homol impl
+c
+ include 'COMMON.VAR'
+c
+ call getenv("FRAGFILE",fragfile)
+ open(ientin,file=fragfile,status="old",err=10)
+ read(ientin,*) constr_homology,nclust
+ l_homo = .false.
+ sigma_theta=0.0
+ sigma_d=0.0
+ sigma_dih=0.0
+c Read pdb files
+ do k=1,constr_homology
+ read(ientin,'(a)') pdbfile
+ write (iout,'(a,5x,a)') 'KLAPAUCJUSZ: Opening PDB file',
+ & pdbfile(:ilen(pdbfile))
+ open(ipdbin,file=pdbfile,status='old',err=33)
+ goto 34
+ 33 write (iout,'(a,5x,a)') 'Error opening PDB file',
+ & pdbfile(:ilen(pdbfile))
+ stop
+ 34 continue
+ unres_pdb=.false.
+ call readpdb_template(k)
+c do i=1,2*nres
+c do j=1,3
+c chomo(j,i,k)=c(j,i)
+c enddo
+c enddo
+ do i=1,nres
+ rescore(k,i)=0.2d0
+ rescore2(k,i)=1.0d0
+ enddo
+ enddo
+c Read clusters
+ do i=1,nclust
+ read(ientin,*) ninclust(i),nresclust(i)
+ read(ientin,*) (inclust(k,i),k=1,ninclust(i))
+ read(ientin,*) (iresclust(k,i),k=1,nresclust(i))
+ enddo
+c
+c Loop over clusters
+c
+ do l=1,nclust
+ do ll = 1,ninclust(l)
+
+ k = inclust(ll,l)
+ do i=1,nres
+ idomain(k,i)=0
+ enddo
+ do i=1,nresclust(l)
+ if (nnt.gt.1) then
+ idomain(k,iresclust(i,l)+1) = 1
+ else
+ idomain(k,iresclust(i,l)) = 1
+ endif
+ enddo
+c
+c Distance restraints
+c
+c ... --> odl(k,ii)
+C Copy the coordinates from reference coordinates (?)
+ do i=1,2*nres
+ do j=1,3
+ c(j,i)=chomo(j,i,k)
+c write (iout,*) "c(",j,i,") =",c(j,i)
+ enddo
+ enddo
+ call int_from_cart(.true.,.false.)
+ call sc_loc_geom(.false.)
+ do i=1,nres
+ thetaref(i)=theta(i)
+ phiref(i)=phi(i)
+ enddo
+ if (waga_dist.ne.0.0d0) then
+ ii=0
+ do i = nnt,nct-2
+ do j=i+2,nct
+
+ x12=c(1,i)-c(1,j)
+ y12=c(2,i)-c(2,j)
+ z12=c(3,i)-c(3,j)
+ distal=dsqrt(x12*x12+y12*y12+z12*z12)
+c write (iout,*) k,i,j,distal,dist2_cut
+
+ if (idomain(k,i).eq.idomain(k,j).and.idomain(k,i).ne.0
+ & .and. distal.le.dist2_cut ) then
+
+ ii=ii+1
+ ii_in_use(ii)=1
+ l_homo(k,ii)=.true.
+
+c write (iout,*) "k",k
+c write (iout,*) "i",i," j",j," constr_homology",
+c & constr_homology
+ ires_homo(ii)=i
+ jres_homo(ii)=j
+ odl(k,ii)=distal
+ if (read2sigma) then
+ sigma_odl(k,ii)=0
+ do ik=i,j
+ sigma_odl(k,ii)=sigma_odl(k,ii)+rescore2(k,ik)
+ enddo
+ sigma_odl(k,ii)=sigma_odl(k,ii)/(j-i+1)
+ if (odl(k,ii).gt.dist_cut) sigma_odl(k,ii) =
+ & sigma_odl(k,ii)*dexp(0.5d0*(odl(k,ii)/dist_cut)**2-0.5d0)
+ else
+ if (odl(k,ii).le.dist_cut) then
+ sigma_odl(k,ii)=rescore(k,i)+rescore(k,j)
+ else
+#ifdef OLDSIGMA
+ sigma_odl(k,ii)=(rescore(k,i)+rescore(k,j))*
+ & dexp(0.5d0*(odl(k,ii)/dist_cut)**2)
+#else
+ sigma_odl(k,ii)=(rescore(k,i)+rescore(k,j))*
+ & dexp(0.5d0*(odl(k,ii)/dist_cut)**2-0.5d0)
+#endif
+ endif
+ endif
+ sigma_odl(k,ii)=1.0d0/(sigma_odl(k,ii)*sigma_odl(k,ii))
+ else
+ ii=ii+1
+c l_homo(k,ii)=.false.
+ endif
+ enddo
+ enddo
+ lim_odl=ii
+ endif
+c
+c Theta, dihedral and SC retraints
+c
+ if (waga_angle.gt.0.0d0) then
+ do i = nnt+3,nct
+ if (idomain(k,i).eq.0) then
+c sigma_dih(k,i)=0.0
+ cycle
+ endif
+ dih(k,i)=phiref(i)
+ sigma_dih(k,i)=(rescore(k,i)+rescore(k,i-1)+
+ & rescore(k,i-2)+rescore(k,i-3))/4.0
+c write (iout,*) "k",k," l",l," i",i," rescore",rescore(k,i),
+c & " sigma_dihed",sigma_dih(k,i)
+ if (sigma_dih(k,i).ne.0)
+ & sigma_dih(k,i)=1.0d0/(sigma_dih(k,i)*sigma_dih(k,i))
+ enddo
+ lim_dih=nct-nnt-2
+ endif
+
+ if (waga_theta.gt.0.0d0) then
+ do i = nnt+2,nct
+ if (idomain(k,i).eq.0) then
+c sigma_theta(k,i)=0.0
+ cycle
+ endif
+ thetatpl(k,i)=thetaref(i)
+ sigma_theta(k,i)=(rescore(k,i)+rescore(k,i-1)+
+ & rescore(k,i-2))/3.0
+ if (sigma_theta(k,i).ne.0)
+ & sigma_theta(k,i)=1.0d0/(sigma_theta(k,i)*sigma_theta(k,i))
+ enddo
+ endif
+
+ if (waga_d.gt.0.0d0) then
+ do i = nnt,nct
+ if (itype(i).eq.10) cycle
+ if (idomain(k,i).eq.0 ) then
+c sigma_d(k,i)=0.0
+ cycle
+ endif
+ xxtpl(k,i)=xxref(i)
+ yytpl(k,i)=yyref(i)
+ zztpl(k,i)=zzref(i)
+ sigma_d(k,i)=rescore(k,i)
+ if (sigma_d(k,i).ne.0)
+ & sigma_d(k,i)=1.0d0/(sigma_d(k,i)*sigma_d(k,i))
+ if (i-nnt+1.gt.lim_xx) lim_xx=i-nnt+1
+ enddo
+ endif
+ enddo ! l
+ enddo ! ll
+c
+c remove distance restraints not used in any model from the list
+c shift data in all arrays
+c
+ if (waga_dist.ne.0.0d0) then
+ ii=0
+ liiflag=.true.
+ do i=nnt,nct-2
+ do j=i+2,nct
+ ii=ii+1
+ if (ii_in_use(ii).eq.0.and.liiflag) then
+ liiflag=.false.
+ iistart=ii
+ endif
+ if (ii_in_use(ii).ne.0.and..not.liiflag.or.
+ & .not.liiflag.and.ii.eq.lim_odl) then
+ if (ii.eq.lim_odl) then
+ iishift=ii-iistart+1
+ else
+ iishift=ii-iistart
+ endif
+ liiflag=.true.
+ do ki=iistart,lim_odl-iishift
+ ires_homo(ki)=ires_homo(ki+iishift)
+ jres_homo(ki)=jres_homo(ki+iishift)
+ ii_in_use(ki)=ii_in_use(ki+iishift)
+ do k=1,constr_homology
+ odl(k,ki)=odl(k,ki+iishift)
+ sigma_odl(k,ki)=sigma_odl(k,ki+iishift)
+ l_homo(k,ki)=l_homo(k,ki+iishift)
+ enddo
+ enddo
+ ii=ii-iishift
+ lim_odl=lim_odl-iishift
+ endif
+ enddo
+ enddo
+ endif
+#ifdef DEBUG
+ write (iout,*) "ires_homo and jres_homo arrays, lim_odl",lim_odl
+ do i=1,lim_odl
+ write (iout,*) i,ires_homo(i),jres_homo(i)
+ enddo
+#endif
+ return
+ 10 stop "Error in fragment file"
+ end
--- /dev/null
+ subroutine read_dist_constr
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.CONTROL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.SBRIDGE'
+ integer ifrag_(2,100),ipair_(2,100)
+ double precision wfrag_(100),wpair_(100)
+ character*500 controlcard
+ logical lprn /.true./
+ logical normalize,next
+ integer restr_type
+ double precision xlink(4,0:4) /
+c a b c sigma
+ & 0.0d0,0.0d0,0.0d0,0.0d0, ! default, no xlink potential
+ & 0.00305218d0,9.46638d0,4.68901d0,4.74347d0, ! ZL
+ & 0.00214928d0,12.7517d0,0.00375009d0,6.13477d0, ! ADH
+ & 0.00184547d0,11.2678d0,0.00140292d0,7.00868d0, ! PDH
+ & 0.000161786d0,6.29273d0,4.40993d0,7.13956d0 / ! DSS
+ write (iout,*) "Calling read_dist_constr"
+c write (iout,*) "nres",nres," nstart_sup",nstart_sup," nsup",nsup
+c call flush(iout)
+ next=.true.
+
+ DO WHILE (next)
+
+ call card_concat(controlcard)
+ next = index(controlcard,"NEXT").gt.0
+ call readi(controlcard,"RESTR_TYPE",restr_type,constr_dist)
+ write (iout,*) "restr_type",restr_type
+ call readi(controlcard,"NFRAG",nfrag_,0)
+ 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)
+ if (restr_type.eq.10)
+ & call reada(controlcard,'WBOLTZD',wboltzd,0.591d0)
+ 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)
+ normalize = index(controlcard,"NORMALIZE").gt.0
+ write (iout,*) "WBOLTZD",wboltzd
+c write (iout,*) "NFRAG",nfrag_," NPAIR",npair_," NDIST",ndist_
+c write (iout,*) "IFRAG"
+c do i=1,nfrag_
+c write (iout,*) i,ifrag_(1,i),ifrag_(2,i),wfrag_(i)
+c enddo
+c write (iout,*) "IPAIR"
+c do i=1,npair_
+c write (iout,*) i,ipair_(1,i),ipair_(2,i),wpair_(i)
+c enddo
+ if (nfrag_.gt.0) then
+ & write (iout,*)
+ & "Distance restraints as generated from reference structure"
+ 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)
+ endif
+ 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)
+c call flush(iout)
+ if (wfrag_(i).eq.0.0d0) cycle
+ do j=ifrag_(1,i),ifrag_(2,i)-1
+ do k=j+1,ifrag_(2,i)
+c write (iout,*) "j",j," k",k
+ ddjk=dist(j,k)
+ if (restr_type.eq.1) then
+ nhpb=nhpb+1
+ irestr_type(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
+ irestr_type(nhpb)=1
+ ihpb(nhpb)=j
+ jhpb(nhpb)=k
+ dhpb(nhpb)=ddjk
+ forcon(nhpb)=wfrag_(i)
+ endif
+ else if (restr_type.eq.3) then
+ nhpb=nhpb+1
+ irestr_type(nhpb)=1
+ ihpb(nhpb)=j
+ jhpb(nhpb)=k
+ dhpb(nhpb)=ddjk
+ forcon(nhpb)=wfrag_(i)*dexp(-0.5d0*(ddjk/dist_cut)**2)
+ endif
+#ifdef MPI
+ if (.not.out1file .or. me.eq.king)
+ & write (iout,'(a,3i5,f8.2,1pe12.2)') "+dist.restr ",
+ & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb)
+#else
+ write (iout,'(a,3i5,f8.2,1pe12.2)') "+dist.restr ",
+ & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb)
+#endif
+ enddo
+ enddo
+ enddo
+ do i=1,npair_
+ if (wpair_(i).eq.0.0d0) cycle
+ 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)
+ if (restr_type.eq.1) then
+ nhpb=nhpb+1
+ irestr_type(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
+ irestr_type(nhpb)=1
+ ihpb(nhpb)=j
+ jhpb(nhpb)=k
+ dhpb(nhpb)=ddjk
+ forcon(nhpb)=wfrag_(i)
+ endif
+ else if (restr_type.eq.3) then
+ nhpb=nhpb+1
+ irestr_type(nhpb)=1
+ ihpb(nhpb)=j
+ jhpb(nhpb)=k
+ dhpb(nhpb)=ddjk
+ forcon(nhpb)=wfrag_(i)*dexp(-0.5d0*(ddjk/dist_cut)**2)
+ endif
+#ifdef MPI
+ if (.not.out1file .or. me.eq.king)
+ & write (iout,'(a,3i5,f8.2,f10.1)') "+dist.restr ",
+ & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb)
+#else
+ write (iout,'(a,3i5,f8.2,f10.1)') "+dist.restr ",
+ & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb)
+#endif
+ enddo
+ enddo
+ enddo
+
+c print *,ndist_
+ write (iout,*) "Distance restraints as read from input"
+ do i=1,ndist_
+ if (restr_type.eq.11) then
+ read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),dhpb(nhpb+1),
+ & dhpb1(nhpb+1),ibecarb(i),forcon(nhpb+1),fordepth(nhpb+1)
+c fordepth(nhpb+1)=fordepth(nhpb+1)/forcon(nhpb+1)
+ if (forcon(nhpb+1).le.0.0d0.or.fordepth(nhpb+1).le.0.0d0)cycle
+ nhpb=nhpb+1
+ irestr_type(nhpb)=11
+#ifdef MPI
+ if (.not.out1file .or. me.eq.king)
+ & write (iout,'(a,4i5,2f8.2,2f10.5,i5)') "+dist.restr ",
+ & nhpb,ihpb(nhpb),jhpb(nhpb),ibecarb(nhpb),dhpb(nhpb),
+ & dhpb1(nhpb),forcon(nhpb),fordepth(nhpb),irestr_type(nhpb)
+#else
+ write (iout,'(a,4i5,2f8.2,2f10.5,i5)') "+dist.restr ",
+ & nhpb,ihpb(nhpb),jhpb(nhpb),ibecarb(nhpb),dhpb(nhpb),
+ & dhpb1(nhpb),forcon(nhpb),fordepth(nhpb),irestr_type(nhpb)
+#endif
+ if (ibecarb(nhpb).gt.0) then
+ ihpb(nhpb)=ihpb(nhpb)+nres
+ jhpb(nhpb)=jhpb(nhpb)+nres
+ endif
+ else if (constr_dist.eq.10) then
+c Cross-lonk Markov-like potential
+ call card_concat(controlcard)
+ call readi(controlcard,"ILINK",ihpb(nhpb+1),0)
+ call readi(controlcard,"JLINK",jhpb(nhpb+1),0)
+ ibecarb(nhpb+1)=0
+ if (index(controlcard,"BETA").gt.0) ibecarb(nhpb+1)=1
+ if (ihpb(nhpb+1).eq.0 .or. jhpb(nhpb+1).eq.0) cycle
+ if (index(controlcard,"ZL").gt.0) then
+ link_type=1
+ else if (index(controlcard,"ADH").gt.0) then
+ link_type=2
+ else if (index(controlcard,"PDH").gt.0) then
+ link_type=3
+ else if (index(controlcard,"DSS").gt.0) then
+ link_type=4
+ else
+ link_type=0
+ endif
+ call reada(controlcard,"AXLINK",dhpb(nhpb+1),
+ & xlink(1,link_type))
+ call reada(controlcard,"BXLINK",dhpb1(nhpb+1),
+ & xlink(2,link_type))
+ call reada(controlcard,"CXLINK",fordepth(nhpb+1),
+ & xlink(3,link_type))
+ call reada(controlcard,"SIGMA",forcon(nhpb+1),
+ & xlink(4,link_type))
+ call reada(controlcard,"SCORE",xlscore(nhpb+1),1.0d0)
+c read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),ibecarb(nhpb+1),
+c & dhpb(nhpb+1),dhpb1(nhpb+1),forcon(nhpb+1),fordepth(nhpb+1)
+ if (forcon(nhpb+1).le.0.0d0 .or.
+ & (dhpb(nhpb+1).eq.0 .and. dhpb1(nhpb+1).eq.0)) cycle
+ nhpb=nhpb+1
+ irestr_type(nhpb)=10
+ if (ibecarb(nhpb).gt.0) then
+ ihpb(nhpb)=ihpb(nhpb)+nres
+ jhpb(nhpb)=jhpb(nhpb)+nres
+ endif
+#ifdef MPI
+ if (.not.out1file .or. me.eq.king)
+ & write (iout,'(a,4i5,2f8.2,3f10.5,i5)') "+dist.restr ",
+ & nhpb,ihpb(nhpb),jhpb(nhpb),ibecarb(nhpb),dhpb(nhpb),
+ & dhpb1(nhpb),forcon(nhpb),fordepth(nhpb),xlscore(nhpb),
+ & irestr_type(nhpb)
+#else
+ write (iout,'(a,4i5,2f8.2,3f10.5,i5)') "+dist.restr ",
+ & nhpb,ihpb(nhpb),jhpb(nhpb),ibecarb(nhpb),dhpb(nhpb),
+ & dhpb1(nhpb),forcon(nhpb),fordepth(nhpb),xlscore(nhpb),
+ & irestr_type(nhpb)
+#endif
+ else
+C print *,"in else"
+ read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),dhpb(nhpb+1),
+ & dhpb1(nhpb+1),ibecarb(nhpb+1),forcon(nhpb+1)
+ if (forcon(nhpb+1).gt.0.0d0) then
+ nhpb=nhpb+1
+ if (dhpb1(nhpb).eq.0.0d0) then
+ irestr_type(nhpb)=1
+ else
+ irestr_type(nhpb)=2
+ endif
+ if (ibecarb(nhpb).gt.0) then
+ ihpb(nhpb)=ihpb(nhpb)+nres
+ jhpb(nhpb)=jhpb(nhpb)+nres
+ endif
+ if (dhpb(nhpb).eq.0.0d0)
+ & dhpb(nhpb)=dist(ihpb(nhpb),jhpb(nhpb))
+ endif
+#ifdef MPI
+ if (.not.out1file .or. me.eq.king)
+ & write (iout,'(a,4i5,f8.2,f10.1)') "+dist.restr ",
+ & nhpb,ihpb(nhpb),jhpb(nhpb),ibecarb(i),dhpb(nhpb),forcon(nhpb)
+#else
+ write (iout,'(a,4i5,f8.2,f10.1)') "+dist.restr ",
+ & nhpb,ihpb(nhpb),jhpb(nhpb),ibecarb(i),dhpb(nhpb),forcon(nhpb)
+#endif
+ endif
+C read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),forcon(nhpb+1)
+C if (forcon(nhpb+1).gt.0.0d0) then
+C nhpb=nhpb+1
+C dhpb(nhpb)=dist(ihpb(nhpb),jhpb(nhpb))
+ enddo
+
+ ENDDO ! next
+
+ fordepthmax=0.0d0
+ if (normalize) then
+ do i=nss+1,nhpb
+ if (irestr_type(i).eq.11.and.fordepth(i).gt.fordepthmax)
+ & fordepthmax=fordepth(i)
+ enddo
+ do i=nss+1,nhpb
+ if (irestr_type(i).eq.11) fordepth(i)=fordepth(i)/fordepthmax
+ enddo
+ endif
+ if (nhpb.gt.nss) then
+ write (iout,'(/a,i5,a/4a5,2a8,3a10,a5)')
+ & "The following",nhpb-nss,
+ & " distance restraints have been imposed:",
+ & " Nr"," res1"," res2"," beta"," d1"," d2"," k"," V",
+ & " score"," type"
+ do i=nss+1,nhpb
+ write (iout,'(4i5,2f8.2,3f10.5,i5)')i-nss,ihpb(i),jhpb(i),
+ & ibecarb(i),dhpb(i),dhpb1(i),forcon(i),fordepth(i),xlscore(i),
+ & irestr_type(i)
+ enddo
+ endif
+ write (iout,*) "Calling HPB_PARTINION"
+ call hpb_partition
+ call flush(iout)
+ return
+ end
--- /dev/null
+ 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 nnt_old,nct_old
+ integer ilen,kkk
+ external ilen
+C
+ nres0=nres
+ nnt_old=nnt
+ nct_old=nct
+c 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(j)
+ theta_ref(j+i)=theta(j)
+ alph_ref(j+i)=alph(j)
+ omeg_ref(j+i)=omeg(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
+ kkk=1
+ nstart_sup=nnt
+ nstart_seq=nnt
+ nsup=nct-nnt+1
+ do i=1,2*nres
+ do j=1,3
+ cref(j,i)=c(j,i)
+ enddo
+ enddo
+ 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 write(iout, *)"Calling contact"
+ call contact(.true.,ncont_ref,icont_ref(1,1),
+ & nstart_sup,nend_sup,1)
+c write(iout, *)"Calling elecont"
+ call elecont(.true.,ncont_pept_ref,
+ & icont_pept_ref(1,1),
+ & nstart_sup,nend_sup,1)
+ write (iout,'(a,i3,a,i3,a,i3,a)')
+ & 'Number of residues to be superposed:',nsup,
+ & ' (from residue',nstart_sup,' to residue',
+ & nend_sup,').'
+ nres=nres0
+ nnt=nnt_old
+ nct=nct_old
+ return
+ end
--- /dev/null
+ 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'
+ include 'COMMON.SBRIDGE'
+ character*3 seq,atom,res
+ character*80 card
+ double precision sccor(3,50)
+ integer i,j,iii,ibeg,ishift,ishift1,ity,ires,ires_old
+ double precision dcj
+ integer rescode,kkk,lll,icha,cou,kupa,iprzes
+ ibeg=1
+ ishift1=0
+ do
+ read (ipdbin,'(a80)',end=10) card
+ if (card(:3).eq.'END') then
+ goto 10
+ else if (card(:3).eq.'TER') then
+C End current chain
+c ires_old=ires+1
+ ires_old=ires+2
+ itype(ires_old-1)=ntyp1
+ itype(ires_old)=ntyp1
+ ibeg=2
+c write (iout,*) "Chain ended",ires,ishift,ires_old
+ call sccenter(ires,iii,sccor)
+ endif
+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) then
+ call sccenter(ires,iii,sccor)
+ endif
+C Start new residue.
+c write (iout,'(a80)') card
+ read (card(23:26),*) ires
+ 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)=ntyp1
+ endif
+c write (iout,*) "ires",ires," ibeg",ibeg," ishift",ishift
+ ibeg=0
+ else if (ibeg.eq.2) then
+c Start a new chain
+ ishift=-ires_old+ires-1
+c write (iout,*) "New chain started",ires,ishift
+ ibeg=0
+ endif
+ ires=ires-ishift
+c write (2,*) "ires",ires," ishift",ishift
+ 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)
+ read(card(61:66),*) bfac(ires)
+c write (iout,'(2i3,2x,a,3f8.3,5x,f8.3)')
+c & ires,itype(ires),res,(c(j,ires),j=1,3),bfac(ires)
+ iii=1
+ do j=1,3
+ sccor(j,iii)=c(j,ires)
+ enddo
+ else if (atom.ne.'O '.and.atom(1:1).ne.'H' .and.
+ & atom(1:1).ne.'Q' .and. atom(1:2).ne.'1H' .and.
+ & atom(1:2).ne.'2H' .and. atom(1:2).ne.'3H' .and.
+ & atom.ne.'N ' .and. atom.ne.'C ' .and.
+ & atom.ne.'OXT' ) then
+ iii=iii+1
+c write (iout,*) res,ires,iii,atom
+ read(card(31:54),'(3f8.3)') (sccor(j,iii),j=1,3)
+c write (iout,'(3f8.3)') (sccor(j,iii),j=1,3)
+ endif
+ endif
+ enddo
+ 10 write (iout,'(a,i5)') ' Nres: ',ires
+C Calculate dummy residue coordinates inside the "chain" of a multichain
+C system
+ nres=ires
+ do i=2,nres-1
+c write (iout,*) i,itype(i)
+
+ if (itype(i).eq.ntyp1) then
+ if (itype(i+1).eq.ntyp1) then
+C 16/01/2014 by Adasko: Adding to dummy atoms in the chain
+C first is connected prevous chain (itype(i+1).eq.ntyp1)=true
+C second dummy atom is conected to next chain itype(i+1).eq.ntyp1=false
+C if (unres_pdb) then
+C 2/15/2013 by Adam: corrected insertion of the last dummy residue
+C call refsys(i-3,i-2,i-1,e1,e2,e3,fail)
+C if (fail) then
+C e2(1)=0.0d0
+C e2(2)=1.0d0
+C e2(3)=0.0d0
+C endif !fail
+C do j=1,3
+C c(j,i)=c(j,i-1)-1.9d0*e2(j)
+C enddo
+C else !unres_pdb
+ do j=1,3
+ dcj=(c(j,i-2)-c(j,i-3))/2.0
+ c(j,i)=c(j,i-1)+dcj
+ c(j,nres+i)=c(j,i)
+ enddo
+C endif !unres_pdb
+ else !itype(i+1).eq.ntyp1
+C if (unres_pdb) then
+C 2/15/2013 by Adam: corrected insertion of the first dummy residue
+C call refsys(i+1,i+2,i+3,e1,e2,e3,fail)
+C if (fail) then
+C e2(1)=0.0d0
+C e2(2)=1.0d0
+C e2(3)=0.0d0
+C endif
+C do j=1,3
+C c(j,i)=c(j,i+1)-1.9d0*e2(j)
+C enddo
+C else !unres_pdb
+ do j=1,3
+ dcj=(c(j,i+3)-c(j,i+2))/2.0
+ c(j,i)=c(j,i+1)-dcj
+ c(j,nres+i)=c(j,i)
+ enddo
+C endif !unres_pdb
+ endif !itype(i+1).eq.ntyp1
+ endif !itype.eq.ntyp1
+ enddo
+C Calculate the CM of the last side chain.
+ call sccenter(ires,iii,sccor)
+ nsup=nres
+ nstart_sup=1
+ if (itype(nres).ne.10) then
+ nres=nres+1
+ itype(nres)=ntyp1
+ do j=1,3
+ dcj=(c(j,nres-2)-c(j,nres-3))/2.0
+ c(j,nres)=c(j,nres-1)+dcj
+ c(j,2*nres)=c(j,nres)
+ enddo
+ 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.ntyp1) then
+ nsup=nsup-1
+ nstart_sup=2
+ do j=1,3
+ dcj=(c(j,4)-c(j,3))/2.0
+ c(j,1)=c(j,2)-dcj
+ c(j,nres+1)=c(j,1)
+ enddo
+ endif
+C Calculate internal coordinates.
+ write (iout,100)
+ 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,nres+ires),j=1,3)
+ enddo
+ call int_from_cart(.true.,.false.)
+ call flush(iout)
+ 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=2,nres-1
+ 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
+c write (iout,*) i,(dc(j,i+nres),j=1,3),(dc_norm(j,i+nres),j=1,3),
+c & vbld_inv(i+nres)
+ enddo
+c call chainbuild
+C Copy the coordinates to reference coordinates
+ do i=1,nres
+ do j=1,3
+ cref(j,i)=c(j,i)
+ cref(j,i+nres)=c(j,i+nres)
+ enddo
+ enddo
+ 100 format ('Residue alpha-carbon coordinates ',
+ & ' centroid coordinates'/
+ 1 ' ', 6X,'X',7X,'Y',7X,'Z',
+ & 12X,'X',7X,'Y',7X,'Z')
+ 110 format (a,'(',i3,')',6f12.5)
+
+ 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,50)
+ 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)
+c 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.ntyp1 .and. itype(i).ne.ntyp1 .and.
+ & (dist(i,i-1).lt.1.0D0 .or. dist(i,i-1).gt.6.0D0)) then
+ write (iout,'(a,i4)') 'Bad Cartesians for residue',i
+ stop
+ endif
+ vbld(i)=dist(i-1,i)
+ vbld_inv(i)=1.0d0/vbld(i)
+ 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
+c if (itype(1).eq.ntyp1) then
+c do j=1,3
+c c(j,1)=c(j,2)+(c(j,3)-c(j,4))
+c enddo
+c endif
+c if (itype(nres).eq.ntyp1) then
+c do j=1,3
+c c(j,nres)=c(j,nres-1)+(c(j,nres-2)-c(j,nres-3))
+c enddo
+c 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)
+ vbld(i+nres)=di
+ if (itype(i).ne.10) then
+ vbld_inv(i+nres)=1.0d0/di
+ else
+ vbld_inv(i+nres)=0.0d0
+ endif
+ if (iti.ne.10) then
+ alph(i)=alpha(nres+i,i,maxres2)
+ omeg(i)=beta(nres+i,i,maxres2,i+1)
+ endif
+ 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,50),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
+c---------------------------------------------------------------------------
+ subroutine sc_loc_geom(lprn)
+ implicit real*8 (a-h,o-z)
+ 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'
+ include 'COMMON.CONTROL'
+ include 'COMMON.SETUP'
+ double precision x_prime(3),y_prime(3),z_prime(3)
+ logical lprn
+ do i=1,nres-1
+ do j=1,3
+ dc_norm(j,i)=vbld_inv(i+1)*(c(j,i+1)-c(j,i))
+ enddo
+ enddo
+ do i=2,nres-1
+ if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then
+ do j=1,3
+ dc_norm(j,i+nres)=vbld_inv(i+nres)*(c(j,i+nres)-c(j,i))
+ enddo
+ else
+ do j=1,3
+ dc_norm(j,i+nres)=0.0d0
+ enddo
+ endif
+ enddo
+ do i=2,nres-1
+ costtab(i+1) =dcos(theta(i+1))
+ sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
+ cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
+ sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
+ cosfac2=0.5d0/(1.0d0+costtab(i+1))
+ cosfac=dsqrt(cosfac2)
+ sinfac2=0.5d0/(1.0d0-costtab(i+1))
+ sinfac=dsqrt(sinfac2)
+ it=itype(i)
+ if (it.ne.10 .and. itype(i).ne.ntyp1) then
+c
+C Compute the axes of tghe local cartesian coordinates system; store in
+c x_prime, y_prime and z_prime
+c
+ do j=1,3
+ x_prime(j) = 0.00
+ y_prime(j) = 0.00
+ z_prime(j) = 0.00
+ enddo
+ do j = 1,3
+ x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
+ y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
+ enddo
+c write (iout,*) "x_prime",(x_prime(j),j=1,3)
+c write (iout,*) "y_prime",(y_prime(j),j=1,3)
+ call vecpr(x_prime,y_prime,z_prime)
+c write (iout,*) "z_prime",(z_prime(j),j=1,3)
+c
+C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
+C to local coordinate system. Store in xx, yy, zz.
+c
+ xx=0.0d0
+ yy=0.0d0
+ zz=0.0d0
+ do j = 1,3
+ xx = xx + x_prime(j)*dc_norm(j,i+nres)
+ yy = yy + y_prime(j)*dc_norm(j,i+nres)
+ zz = zz + z_prime(j)*dc_norm(j,i+nres)
+ enddo
+
+ xxref(i)=xx
+ yyref(i)=yy
+ zzref(i)=zz
+ else
+ xxref(i)=0.0d0
+ yyref(i)=0.0d0
+ zzref(i)=0.0d0
+ endif
+ enddo
+ if (lprn) then
+ write (iout,*) "xxref,yyref,zzref"
+ do i=2,nres
+ iti=itype(i)
+ write (iout,'(a3,i4,3f10.5)') restyp(iti),i,xxref(i),yyref(i),
+ & zzref(i)
+ enddo
+ endif
+ return
+ end
+c---------------------------------------------------------------------------
+ subroutine bond_regular
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CALC'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CHAIN'
+ do i=1,nres-1
+ vbld(i+1)=vbl
+ vbld_inv(i+1)=1.0d0/vbld(i+1)
+ vbld(i+1+nres)=dsc(iabs(itype(i+1)))
+ vbld_inv(i+1+nres)=dsc_inv(iabs(itype(i+1)))
+c print *,vbld(i+1),vbld(i+1+nres)
+ enddo
+ return
+ end
+c---------------------------------------------------------------------------
+ subroutine readpdb_template(k)
+C Read the PDB file for read_constr_homology with read2sigma
+C and convert the peptide geometry into virtual-chain geometry.
+ implicit real*8 (a-h,o-z)
+ 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'
+ include 'COMMON.CONTROL'
+ include 'COMMON.SETUP'
+ integer i,j,ibeg,ishift1,ires,iii,ires_old,ishift,ity
+ logical lprn /.false./,fail
+ double precision e1(3),e2(3),e3(3)
+ double precision dcj,efree_temp
+ character*3 seq,res
+ character*5 atom
+ character*80 card
+ double precision sccor(3,20)
+ integer rescode,iterter(maxres)
+ do i=1,maxres
+ iterter(i)=0
+ enddo
+ ibeg=1
+ ishift1=0
+ ishift=0
+c write (2,*) "UNRES_PDB",unres_pdb
+ ires=0
+ ires_old=0
+ iii=0
+ lsecondary=.false.
+ nhfrag=0
+ nbfrag=0
+ do
+ read (ipdbin,'(a80)',end=10) card
+ if (card(:3).eq.'END') then
+ goto 10
+ else if (card(:3).eq.'TER') then
+C End current chain
+ ires_old=ires+2
+ itype(ires_old-1)=ntyp1
+ iterter(ires_old-1)=1
+ itype(ires_old)=ntyp1
+ iterter(ires_old)=1
+ ibeg=2
+c write (iout,*) "Chain ended",ires,ishift,ires_old
+ if (unres_pdb) then
+ do j=1,3
+ dc(j,ires)=sccor(j,iii)
+ enddo
+ else
+ call sccenter(ires,iii,sccor)
+ endif
+ endif
+C Fish out the ATOM cards.
+ if (index(card(1:4),'ATOM').gt.0) then
+ read (card(12:16),*) atom
+c write (iout,*) "! ",atom," !",ires
+c if (atom.eq.'CA' .or. atom.eq.'CH3') then
+ read (card(23:26),*) ires
+ read (card(18:20),'(a3)') res
+c write (iout,*) "ires",ires,ires-ishift+ishift1,
+c & " ires_old",ires_old
+c write (iout,*) "ishift",ishift," ishift1",ishift1
+c write (iout,*) "IRES",ires-ishift+ishift1,ires_old
+ if (ires-ishift+ishift1.ne.ires_old) then
+C Calculate the CM of the preceding residue.
+ if (ibeg.eq.0) then
+ if (unres_pdb) then
+ do j=1,3
+ dc(j,ires)=sccor(j,iii)
+ enddo
+ else
+ call sccenter(ires_old,iii,sccor)
+ endif
+ iii=0
+ endif
+C Start new residue.
+ if (res.eq.'Cl-' .or. res.eq.'Na+') then
+ ires=ires_old
+ cycle
+ else if (ibeg.eq.1) then
+c write (iout,*) "BEG ires",ires
+ ishift=ires-1
+ if (res.ne.'GLY' .and. res.ne. 'ACE') then
+ ishift=ishift-1
+ itype(1)=ntyp1
+ endif
+ ires=ires-ishift+ishift1
+ ires_old=ires
+c write (iout,*) "ishift",ishift," ires",ires,
+c & " ires_old",ires_old
+c write (iout,*) "ires",ires," ibeg",ibeg," ishift",ishift
+ ibeg=0
+ else if (ibeg.eq.2) then
+c Start a new chain
+ ishift=-ires_old+ires-1
+ ires=ires_old+1
+c write (iout,*) "New chain started",ires,ishift
+ ibeg=0
+ else
+ ishift=ishift-(ires-ishift+ishift1-ires_old-1)
+ ires=ires-ishift+ishift1
+ ires_old=ires
+ endif
+ if (res.eq.'ACE' .or. res.eq.'NHE') then
+ itype(ires)=10
+ else
+ itype(ires)=rescode(ires,res,0)
+ endif
+ else
+ ires=ires-ishift+ishift1
+ endif
+c write (iout,*) "ires_old",ires_old," ires",ires
+c if (card(27:27).eq."A" .or. card(27:27).eq."B") then
+c ishift1=ishift1+1
+c endif
+c write (2,*) "ires",ires," res ",res," ity",ity
+ if (atom.eq.'CA' .or. atom.eq.'CH3' .or.
+ & res.eq.'NHE'.and.atom(:2).eq.'HN') then
+ read(card(31:54),'(3f8.3)') (c(j,ires),j=1,3)
+c write (iout,*) "backbone ",atom ,ires,res, (c(j,ires),j=1,3)
+#ifdef DEBUG
+ write (iout,'(2i3,2x,a,3f8.3)')
+ & ires,itype(ires),res,(c(j,ires),j=1,3)
+#endif
+ iii=iii+1
+ do j=1,3
+ sccor(j,iii)=c(j,ires)
+ enddo
+ if (ishift.ne.0) then
+ ires_ca=ires+ishift-ishift1
+ else
+ ires_ca=ires
+ endif
+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' .and.
+ & atom(:2).ne.'1H' .and. atom(:2).ne.'2H' .and.
+ & atom.ne.'OXT' .and. atom(:2).ne.'3H') then
+c write (iout,*) "sidechain ",atom
+ 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 dummy residue coordinates inside the "chain" of a multichain
+C system
+ nres=ires
+ do i=2,nres-1
+c write (iout,*) i,itype(i),itype(i+1)
+ if (itype(i).eq.ntyp1.and.iterter(i).eq.1) then
+ if (itype(i+1).eq.ntyp1.and.iterter(i+1).eq.1 ) then
+C 16/01/2014 by Adasko: Adding to dummy atoms in the chain
+C first is connected prevous chain (itype(i+1).eq.ntyp1)=true
+C second dummy atom is conected to next chain itype(i+1).eq.ntyp1=false
+ if (unres_pdb) then
+C 2/15/2013 by Adam: corrected insertion of the last dummy residue
+ call refsys(i-3,i-2,i-1,e1,e2,e3,fail)
+ if (fail) then
+ e2(1)=0.0d0
+ e2(2)=1.0d0
+ e2(3)=0.0d0
+ endif !fail
+ do j=1,3
+ c(j,i)=c(j,i-1)-1.9d0*e2(j)
+ enddo
+ else !unres_pdb
+ do j=1,3
+ dcj=(c(j,i-2)-c(j,i-3))/2.0
+ if (dcj.eq.0) dcj=1.23591524223
+ c(j,i)=c(j,i-1)+dcj
+ c(j,nres+i)=c(j,i)
+ enddo
+ endif !unres_pdb
+ else !itype(i+1).eq.ntyp1
+ if (unres_pdb) then
+C 2/15/2013 by Adam: corrected insertion of the first dummy residue
+ call refsys(i+1,i+2,i+3,e1,e2,e3,fail)
+ if (fail) then
+ e2(1)=0.0d0
+ e2(2)=1.0d0
+ e2(3)=0.0d0
+ endif
+ do j=1,3
+ c(j,i)=c(j,i+1)-1.9d0*e2(j)
+ enddo
+ else !unres_pdb
+ do j=1,3
+ dcj=(c(j,i+3)-c(j,i+2))/2.0
+ if (dcj.eq.0) dcj=1.23591524223
+ c(j,i)=c(j,i+1)-dcj
+ c(j,nres+i)=c(j,i)
+ enddo
+ endif !unres_pdb
+ endif !itype(i+1).eq.ntyp1
+ endif !itype.eq.ntyp1
+ enddo
+C Calculate the CM of the last side chain.
+ if (unres_pdb) then
+ do j=1,3
+ dc(j,ires)=sccor(j,iii)
+ enddo
+ else
+ call sccenter(ires,iii,sccor)
+ endif
+ nsup=nres
+ nstart_sup=1
+ if (itype(nres).ne.10) then
+ nres=nres+1
+ itype(nres)=ntyp1
+ if (unres_pdb) then
+C 2/15/2013 by Adam: corrected insertion of the last dummy residue
+ call refsys(nres-3,nres-2,nres-1,e1,e2,e3,fail)
+ if (fail) then
+ e2(1)=0.0d0
+ e2(2)=1.0d0
+ e2(3)=0.0d0
+ endif
+ do j=1,3
+ c(j,nres)=c(j,nres-1)-1.9d0*e2(j)
+ enddo
+ else
+ do j=1,3
+ dcj=(c(j,nres-2)-c(j,nres-3))/2.0
+ if (dcj.eq.0) dcj=1.23591524223
+ c(j,nres)=c(j,nres-1)+dcj
+ c(j,2*nres)=c(j,nres)
+ enddo
+ endif
+ 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.ntyp1) then
+ nsup=nsup-1
+ nstart_sup=2
+ if (unres_pdb) then
+C 2/15/2013 by Adam: corrected insertion of the first dummy residue
+ call refsys(2,3,4,e1,e2,e3,fail)
+ if (fail) then
+ e2(1)=0.0d0
+ e2(2)=1.0d0
+ e2(3)=0.0d0
+ endif
+ do j=1,3
+ c(j,1)=c(j,2)-1.9d0*e2(j)
+ enddo
+ else
+ do j=1,3
+ dcj=(c(j,4)-c(j,3))/2.0
+ c(j,1)=c(j,2)-dcj
+ c(j,nres+1)=c(j,1)
+ enddo
+ endif
+ endif
+C Copy the coordinates to reference coordinates
+c do i=1,2*nres
+c do j=1,3
+c cref(j,i)=c(j,i)
+c enddo
+c enddo
+C Calculate internal coordinates.
+ if (out_template_coord) then
+ write (iout,'(/a)')
+ & "Cartesian coordinates of the reference structure"
+ write (iout,'(a,3(3x,a5),5x,3(3x,a5))')
+ & "Residue","X(CA)","Y(CA)","Z(CA)","X(SC)","Y(SC)","Z(SC)"
+ do ires=1,nres
+ write (iout,'(a3,1x,i3,3f8.3,5x,3f8.3)')
+ & restyp(itype(ires)),ires,(c(j,ires),j=1,3),
+ & (c(j,ires+nres),j=1,3)
+ enddo
+ endif
+C Calculate internal coordinates.
+c call int_from_cart1(.false.)
+ call int_from_cart(.true.,.true.)
+ call sc_loc_geom(.true.)
+ do i=1,nres
+ thetaref(i)=theta(i)
+ phiref(i)=phi(i)
+ 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=2,nres-1
+ 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
+c write (iout,*) i,(dc(j,i+nres),j=1,3),(dc_norm(j,i+nres),j=1,3),
+c & vbld_inv(i+nres)
+ enddo
+ do i=1,nres
+ do j=1,3
+ cref(j,i)=c(j,i)
+ cref(j,i+nres)=c(j,i+nres)
+ enddo
+ enddo
+ do i=1,2*nres
+ do j=1,3
+ chomo(j,i,k)=c(j,i)
+ enddo
+ enddo
+
+ return
+ end
+
+
--- /dev/null
+ 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"
+ include "COMMON.SPLITELE"
+ include "COMMON.SBRIDGE"
+ include "COMMON.SHIELD"
+ include "COMMON.SAXS"
+ 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
+ double precision pi
+ 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
+ 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)
+ do i=1,nparmset
+ if (isampl(i).eq.0) then
+ write (iout,*) "ERROR: isampl is 0 for parmset",i
+ call flush(iout)
+ stop
+ endif
+ enddo
+ 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
+ energy_dec=(index(controlcard,'ENERGY_DEC').gt.0)
+ if (index(controlcard,"CLASSIFY").gt.0) indpdb=1
+ call reada(controlcard,"DELTA",delta,1.0d-2)
+ call reada(controlcard,"TOLE",tole,1.0d-1)
+ 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)
+ check_conf=index(controlcard,"NO_CHECK_CONF").eq.0
+ call readi(controlcard,'TORMODE',tor_mode,0)
+ write(iout,*) "torsional and valence angle mode",tor_mode
+ call reada(controlcard,'DISTCHAINMAX',distchainmax,50.0d0)
+ call reada(controlcard,'BOXX',boxxsize,100.0d0)
+ call reada(controlcard,'BOXY',boxysize,100.0d0)
+ call reada(controlcard,'BOXZ',boxzsize,100.0d0)
+c Cutoff range for interactions
+ call reada(controlcard,"R_CUT",r_cut,15.0d0)
+ call reada(controlcard,"LAMBDA",rlamb,0.3d0)
+ call reada(controlcard,"LIPTHICK",lipthick,0.0d0)
+ call reada(controlcard,"LIPAQBUF",lipbufthick,0.0d0)
+ unres_pdb = index(controlcard,'UNRES_PDB') .gt. 0
+ if (lipthick.gt.0.0d0) then
+ bordliptop=(boxzsize+lipthick)/2.0
+ bordlipbot=bordliptop-lipthick
+C endif
+ if ((bordliptop.gt.boxzsize).or.(bordlipbot.lt.0.0))
+ & write(iout,*) "WARNING WRONG SIZE OF LIPIDIC PHASE"
+ buflipbot=bordlipbot+lipbufthick
+ bufliptop=bordliptop-lipbufthick
+ if ((lipbufthick*2.0d0).gt.lipthick)
+ &write(iout,*) "WARNING WRONG SIZE OF LIP AQ BUF"
+ endif
+ write(iout,*) "bordliptop=",bordliptop
+ write(iout,*) "bordlipbot=",bordlipbot
+ write(iout,*) "bufliptop=",bufliptop
+ write(iout,*) "buflipbot=",buflipbot
+ call readi(controlcard,'SYM',symetr,1)
+ write (iout,*) "DISTCHAINMAX",distchainmax
+ write (iout,*) "delta",delta
+ 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
+ write (iout,*) "with_dihed_constr ",with_dihed_constr
+ with_theta_constr = index(controlcard,"WITH_THETA_CONSTR").gt.0
+ write (iout,*) "with_theta_constr ",with_theta_constr
+ call readi(controlcard,'SHIELD',shield_mode,0)
+ write(iout,*) "shield_mode",shield_mode
+C endif
+ call readi(controlcard,'TORMODE',tor_mode,0)
+ write(iout,*) "torsional and valence angle mode",tor_mode
+ if (shield_mode.gt.0) then
+ pi=3.141592d0
+C VSolvSphere the volume of solving sphere
+C print *,pi,"pi"
+C rpp(1,1) is the energy r0 for peptide group contact and will be used for it
+C there will be no distinction between proline peptide group and normal peptide
+C group in case of shielding parameters
+ VSolvSphere=4.0/3.0*pi*rpp(1,1)**3
+ VSolvSphere_div=VSolvSphere-4.0/3.0*pi*(rpp(1,1)/2.0)**3
+ write (iout,*) VSolvSphere,VSolvSphere_div
+C long axis of side chain
+C do i=1,ntyp
+C long_r_sidechain(i)=vbldsc0(1,i)
+C short_r_sidechain(i)=sigma0(i)
+C enddo
+ buff_shield=1.0d0
+ endif
+
+ call readi(controlcard,'CONSTR_DIST',constr_dist,0)
+ call readi(controlcard,'CONSTR_HOMOL',constr_homology,0)
+c if (constr_homology) tole=dmax1(tole,1.5d0)
+ write (iout,*) "with_homology_constr ",with_dihed_constr,
+ & " CONSTR_HOMOLOGY",constr_homology
+ read_homol_frag = index(controlcard,"READ_HOMOL_FRAG").gt.0
+ out_template_coord = index(controlcard,"OUT_TEMPLATE_COORD").gt.0
+ out_template_restr = index(controlcard,"OUT_TEMPLATE_RESTR").gt.0
+ write (iout,*) "out_template_coord ",OUT_TEMPLATE_COORD
+ write (iout,*) "out_template_restr",OUT_TEMPLATE_RESTR
+ dyn_ss=index(controlcard,"DYN_SS").gt.0
+ adaptive = index(controlcard,"ADAPTIVE").gt.0
+ call readi(controlcard,'NSAXS',nsaxs,0)
+ call readi(controlcard,'SAXS_MODE',saxs_mode,0)
+ call reada(controlcard,'SCAL_RAD',scal_rad,1.0d0)
+ call reada(controlcard,'SAXS_CUTOFF',saxs_cutoff,1.0d0)
+ write (iout,*) "Number of SAXS restraints",NSAXS," SAXS_MODE",
+ & SAXS_MODE," SCAL_RAD",scal_rad,"SAXS_CUTOFF",saxs_cutoff
+ 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), maxslice_buff
+ 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
+
+c call MPI_ALLgather(MPI_IN_PLACE,stot(1),MPI_DATATYPE_NULL,
+c & ntot_all(1,0),maxslice,MPI_INTEGER,MPI_Comm_World,IERROR)
+
+ maxslice_buff=maxslice
+
+ call MPI_Allgather(stot(1),maxslice_buff,MPI_INTEGER,
+ & ntot_all(1,0),maxslice,MPI_INTEGER,MPI_Comm_World,IERROR)
+ lerr=.false.
+ do i=0,nprocs-1
+ 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
+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'
+ include 'COMMON.INTERACT'
+ integer ifrag_(2,100),ipair_(2,100)
+ double precision wfrag_(100),wpair_(100)
+ character*500 controlcard
+ logical normalize,next
+ integer restr_type
+ double precision xlink(4,0:4) /
+c a b c sigma
+ & 0.0d0,0.0d0,0.0d0,0.0d0, ! default, no xlink potential
+ & 0.00305218d0,9.46638d0,4.68901d0,4.74347d0, ! ZL
+ & 0.00214928d0,12.7517d0,0.00375009d0,6.13477d0, ! ADH
+ & 0.00184547d0,11.2678d0,0.00140292d0,7.00868d0, ! PDH
+ & 0.000161786d0,6.29273d0,4.40993d0,7.13956d0 / ! DSS
+ write (iout,*) "Calling read_dist_constr"
+c write (iout,*) "nres",nres," nstart_sup",nstart_sup," nsup",nsup
+c call flush(iout)
+ restr_on_coord=.false.
+ next=.true.
+
+ DO WHILE (next)
+
+ call card_concat(controlcard,.true.)
+ next = index(controlcard,"NEXT").gt.0
+ call readi(controlcard,"RESTR_TYPE",restr_type,constr_dist)
+ write (iout,*) "restr_type",restr_type
+ call readi(controlcard,"NFRAG",nfrag_,0)
+ 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 reada(controlcard,'SCAL_BFAC',scal_bfac,1.0d0)
+ if (restr_type.eq.10)
+ & call reada(controlcard,'WBOLTZD',wboltzd,0.591d0)
+ if (restr_type.eq.12)
+ & call reada(controlcard,'SCAL_PEAK',scal_peak,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)
+ normalize = index(controlcard,"NORMALIZE").gt.0
+ write (iout,*) "WBOLTZD",wboltzd
+ write (iout,*) "SCAL_PEAK",scal_peak
+ 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
+ if (nfrag_.gt.0 .or. restr_type.eq.4 .or. restr_type.eq.5) then
+ nres0=nres
+ read(inp,'(a)') pdbfile
+ write (iout,*)
+ & "Distance restraints will be constructed from structure ",pdbfile
+ open(ipdbin,file=pdbfile,status='old',err=11)
+ call readpdb(.true.)
+ nres=nres0
+ close(ipdbin)
+ endif
+ 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)
+c call flush(iout)
+ if (wfrag_(i).eq.0.0d0) cycle
+ do j=ifrag_(1,i),ifrag_(2,i)-1
+ do k=j+1,ifrag_(2,i)
+c write (iout,*) "j",j," k",k
+ ddjk=dist(j,k)
+ if (restr_type.eq.1) then
+ nhpb=nhpb+1
+ irestr_type(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
+ irestr_type(nhpb)=1
+ ihpb(nhpb)=j
+ jhpb(nhpb)=k
+ dhpb(nhpb)=ddjk
+ forcon(nhpb)=wfrag_(i)
+ endif
+ else if (restr_type.eq.3) then
+ nhpb=nhpb+1
+ irestr_type(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.restr ",
+ & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb)
+ enddo
+ enddo
+ enddo
+ do i=1,npair_
+ if (wpair_(i).eq.0.0d0) cycle
+ 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)
+ ddjk=dist(j,k)
+ if (restr_type.eq.1) then
+ nhpb=nhpb+1
+ irestr_type(nhpb)=1
+ ihpb(nhpb)=j
+ jhpb(nhpb)=k
+ dhpb(nhpb)=ddjk
+ forcon(nhpb)=wpair_(i)
+ else if (constr_dist.eq.2) then
+ if (ddjk.le.dist_cut) then
+ nhpb=nhpb+1
+ irestr_type(nhpb)=1
+ ihpb(nhpb)=j
+ jhpb(nhpb)=k
+ dhpb(nhpb)=ddjk
+ forcon(nhpb)=wpair_(i)
+ endif
+ else if (restr_type.eq.3) then
+ nhpb=nhpb+1
+ irestr_type(nhpb)=1
+ ihpb(nhpb)=j
+ jhpb(nhpb)=k
+ dhpb(nhpb)=ddjk
+ forcon(nhpb)=wpair_(i)*dexp(-0.5d0*(ddjk/dist_cut)**2)
+ endif
+ write (iout,'(a,3i5,f8.2,f10.1)') "+dist.restr ",
+ & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb)
+ enddo
+ enddo
+ enddo
+
+c print *,ndist_
+ write (iout,*) "Distance restraints as read from input"
+ do i=1,ndist_
+ if (restr_type.eq.12) then
+ read (inp,*) ihpb_peak(nhpb_peak+1),jhpb_peak(nhpb_peak+1),
+ & dhpb_peak(nhpb_peak+1),dhpb1_peak(nhpb_peak+1),
+ & ibecarb_peak(nhpb_peak+1),forcon_peak(nhpb_peak+1),
+ & fordepth_peak(nhpb_peak+1),npeak
+c write(iout,*) ihpb_peak(nhpb_peak+1),jhpb_peak(nhpb_peak+1),
+c & dhpb_peak(nhpb_peak+1),dhpb1_peak(nhpb_peak+1),
+c & ibecarb_peak(nhpb_peak+1),forcon_peak(nhpb_peak+1),
+c & fordepth_peak(nhpb_peak+1),npeak
+ if (forcon_peak(nhpb_peak+1).le.0.0d0.or.
+ & fordepth_peak(nhpb_peak+1).le.0.0d0)cycle
+ nhpb_peak=nhpb_peak+1
+ irestr_type_peak(nhpb_peak)=12
+ if (ipeak(1,npeak).eq.0) ipeak(1,npeak)=i
+ ipeak(2,npeak)=i
+ write (iout,'(a,5i5,2f8.2,2f10.5,i5)') "+dist.restr ",
+ & nhpb_peak,ihpb_peak(nhpb_peak),jhpb_peak(nhpb_peak),
+ & ibecarb_peak(nhpb_peak),npeak,dhpb_peak(nhpb_peak),
+ & dhpb1_peak(nhpb_peak),forcon_peak(nhpb_peak),
+ & fordepth_peak(nhpb_peak),irestr_type_peak(nhpb_peak)
+ if (ibecarb_peak(nhpb_peak).eq.3) then
+ jhpb_peak(nhpb_peak)=jhpb_peak(nhpb_peak)+nres
+ else if (ibecarb_peak(nhpb_peak).eq.2) then
+ ihpb_peak(nhpb_peak)=ihpb_peak(nhpb_peak)+nres
+ else if (ibecarb_peak(nhpb_peak).eq.1) then
+ ihpb_peak(nhpb_peak)=ihpb_peak(nhpb_peak)+nres
+ jhpb_peak(nhpb_peak)=jhpb_peak(nhpb_peak)+nres
+ endif
+ else if (restr_type.eq.11) then
+ read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),dhpb(nhpb+1),
+ & dhpb1(nhpb+1),ibecarb(i),forcon(nhpb+1),fordepth(nhpb+1)
+c fordepth(nhpb+1)=fordepth(nhpb+1)/forcon(nhpb+1)
+ if (forcon(nhpb+1).le.0.0d0.or.fordepth(nhpb+1).le.0.0d0)cycle
+ nhpb=nhpb+1
+ irestr_type(nhpb)=11
+ write (iout,'(a,4i5,2f8.2,2f10.5,i5)') "+dist.restr ",
+ & nhpb,ihpb(nhpb),jhpb(nhpb),ibecarb(nhpb),dhpb(nhpb),
+ & dhpb1(nhpb),forcon(nhpb),fordepth(nhpb),irestr_type(nhpb)
+c if (ibecarb(nhpb).gt.0) then
+c ihpb(nhpb)=ihpb(nhpb)+nres
+c jhpb(nhpb)=jhpb(nhpb)+nres
+c endif
+ if (ibecarb(nhpb).eq.3) then
+ ihpb(nhpb)=ihpb(nhpb)+nres
+ else if (ibecarb(nhpb).eq.2) then
+ ihpb(nhpb)=ihpb(nhpb)+nres
+ else if (ibecarb(nhpb).eq.1) then
+ ihpb(nhpb)=ihpb(nhpb)+nres
+ jhpb(nhpb)=jhpb(nhpb)+nres
+ endif
+ else if (restr_type.eq.10) then
+c Cross-lonk Markov-like potential
+ call card_concat(controlcard,.true.)
+ call readi(controlcard,"ILINK",ihpb(nhpb+1),0)
+ call readi(controlcard,"JLINK",jhpb(nhpb+1),0)
+ ibecarb(nhpb+1)=0
+ if (index(controlcard,"BETA").gt.0) ibecarb(nhpb+1)=1
+ if (ihpb(nhpb+1).eq.0 .or. jhpb(nhpb+1).eq.0) cycle
+ if (index(controlcard,"ZL").gt.0) then
+ link_type=1
+ else if (index(controlcard,"ADH").gt.0) then
+ link_type=2
+ else if (index(controlcard,"PDH").gt.0) then
+ link_type=3
+ else if (index(controlcard,"DSS").gt.0) then
+ link_type=4
+ else
+ link_type=0
+ endif
+ call reada(controlcard,"AXLINK",dhpb(nhpb+1),
+ & xlink(1,link_type))
+ call reada(controlcard,"BXLINK",dhpb1(nhpb+1),
+ & xlink(2,link_type))
+ call reada(controlcard,"CXLINK",fordepth(nhpb+1),
+ & xlink(3,link_type))
+ call reada(controlcard,"SIGMA",forcon(nhpb+1),
+ & xlink(4,link_type))
+ call reada(controlcard,"SCORE",xlscore(nhpb+1),1.0d0)
+c read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),ibecarb(nhpb+1),
+c & dhpb(nhpb+1),dhpb1(nhpb+1),forcon(nhpb+1),fordepth(nhpb+1)
+ if (forcon(nhpb+1).le.0.0d0 .or.
+ & (dhpb(nhpb+1).eq.0 .and. dhpb1(nhpb+1).eq.0)) cycle
+ nhpb=nhpb+1
+ irestr_type(nhpb)=10
+c if (ibecarb(nhpb).gt.0) then
+c ihpb(nhpb)=ihpb(nhpb)+nres
+c jhpb(nhpb)=jhpb(nhpb)+nres
+c endif
+ if (ibecarb(nhpb).eq.3) then
+ jhpb(nhpb)=jhpb(nhpb)+nres
+ else if (ibecarb(nhpb).eq.2) then
+ ihpb(nhpb)=ihpb(nhpb)+nres
+ else if (ibecarb(nhpb).eq.1) then
+ ihpb(nhpb)=ihpb(nhpb)+nres
+ jhpb(nhpb)=jhpb(nhpb)+nres
+ endif
+ write (iout,'(a,4i5,2f8.2,3f10.5,i5)') "+dist.restr ",
+ & nhpb,ihpb(nhpb),jhpb(nhpb),ibecarb(nhpb),dhpb(nhpb),
+ & dhpb1(nhpb),forcon(nhpb),fordepth(nhpb),xlscore(nhpb),
+ & irestr_type(nhpb)
+ else
+C print *,"in else"
+ read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),dhpb(nhpb+1),
+ & dhpb1(nhpb+1),ibecarb(nhpb+1),forcon(nhpb+1)
+ if (forcon(nhpb+1).gt.0.0d0) then
+ nhpb=nhpb+1
+ if (dhpb1(nhpb).eq.0.0d0) then
+ irestr_type(nhpb)=1
+ else
+ irestr_type(nhpb)=2
+ endif
+c if (ibecarb(nhpb).gt.0) then
+c ihpb(nhpb)=ihpb(nhpb)+nres
+c jhpb(nhpb)=jhpb(nhpb)+nres
+c endif
+ if (ibecarb(nhpb).eq.3) then
+ ihpb(nhpb)=ihpb(nhpb)+nres
+ else if (ibecarb(nhpb).eq.2) then
+ ihpb(nhpb)=ihpb(nhpb)+nres
+ else if (ibecarb(nhpb).eq.1) then
+ ihpb(nhpb)=ihpb(nhpb)+nres
+ jhpb(nhpb)=jhpb(nhpb)+nres
+ endif
+ if (dhpb(nhpb).eq.0.0d0)
+ & dhpb(nhpb)=dist(ihpb(nhpb),jhpb(nhpb))
+ endif
+ write (iout,'(a,4i5,f8.2,f10.1)') "+dist.restr ",
+ & nhpb,ihpb(nhpb),jhpb(nhpb),ibecarb(i),dhpb(nhpb),forcon(nhpb)
+ endif
+C read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),forcon(nhpb+1)
+C if (forcon(nhpb+1).gt.0.0d0) then
+C nhpb=nhpb+1
+C dhpb(nhpb)=dist(ihpb(nhpb),jhpb(nhpb))
+ enddo
+
+ if (restr_type.eq.4) then
+ write (iout,*) "The BFAC array"
+ do i=nnt,nct
+ write (iout,'(i5,f10.5)') i,bfac(i)
+ enddo
+ do i=nnt,nct
+ if (itype(i).eq.ntyp1) cycle
+ do j=nnt,i-1
+ if (itype(j).eq.ntyp1) cycle
+ if (itype(i).eq.10) then
+ iiend=0
+ else
+ iiend=1
+ endif
+ if (itype(j).eq.10) then
+ jjend=0
+ else
+ jjend=1
+ endif
+ kk=0
+ do ii=0,iiend
+ do jj=0,jjend
+ nhpb=nhpb+1
+ irestr_type(nhpb)=1
+ forcon(nhpb)=scal_bfac**2/(bfac(i)**2+bfac(j)**2)
+ irestr_type(nhpb)=1
+ ibecarb(nhpb)=kk
+ if (ibecarb(nhpb).gt.0) ibecarb(nhpb)=4-ibecarb(nhpb)
+ ihpb(nhpb)=i+nres*ii
+ jhpb(nhpb)=j+nres*jj
+ dhpb(nhpb)=dist(i+nres*ii,j+nres*jj)
+ write (iout,'(a,4i5,2f8.2,3f10.5,i5)') "+dist.restr ",
+ & nhpb,ihpb(nhpb),jhpb(nhpb),ibecarb(nhpb),dhpb(nhpb),
+ & dhpb1(nhpb),forcon(nhpb),fordepth(nhpb),xlscore(nhpb),
+ & irestr_type(nhpb)
+ kk=kk+1
+ enddo
+ enddo
+ enddo
+ enddo
+ endif
+
+ if (restr_type.eq.5) then
+ restr_on_coord=.true.
+ do i=nnt,nct
+ if (itype(i).eq.ntyp1) cycle
+ bfac(i)=(scal_bfac/bfac(i))**2
+ enddo
+ endif
+
+ ENDDO ! next
+
+ fordepthmax=0.0d0
+ if (normalize) then
+ do i=nss+1,nhpb
+ if (irestr_type(i).eq.11.and.fordepth(i).gt.fordepthmax)
+ & fordepthmax=fordepth(i)
+ enddo
+ do i=nss+1,nhpb
+ if (irestr_type(i).eq.11) fordepth(i)=fordepth(i)/fordepthmax
+ enddo
+ endif
+ if (nhpb.gt.nss) then
+ write (iout,'(/a,i5,a/4a5,2a8,3a10,a5)')
+ & "The following",nhpb-nss,
+ & " distance restraints have been imposed:",
+ & " Nr"," res1"," res2"," beta"," d1"," d2"," k"," V",
+ & " score"," type"
+ do i=nss+1,nhpb
+ write (iout,'(4i5,2f8.2,3f10.5,i5)')i-nss,ihpb(i),jhpb(i),
+ & ibecarb(i),dhpb(i),dhpb1(i),forcon(i),fordepth(i),xlscore(i),
+ & irestr_type(i)
+ enddo
+ endif
+ write (iout,*)
+ call hpb_partition
+ call flush(iout)
+ return
+ 11 write (iout,*)"read_dist_restr: error reading reference structure"
+ stop
+ end
--- /dev/null
+ 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
--- /dev/null
+ 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)
+ if (index(controlcard,"CASC").gt.0) then
+ iz_sc=1
+ else if (index(controlcard,"SCONLY").gt.0) then
+ iz_sc=2
+ else
+ iz_sc=0
+ endif
+ 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
--- /dev/null
+ subroutine refsys(i2,i3,i4,e1,e2,e3,fail)
+c This subroutine calculates unit vectors of a local reference system
+c defined by atoms (i2), (i3), and (i4). The x axis is the axis from
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include "COMMON.CHAIN"
+c this subroutine calculates unity vectors of a local reference system
+c defined by atoms (i2), (i3), and (i4). the x axis is the axis from
+c atom (i3) to atom (i2), and the xy plane is the plane defined by atoms
+c (i2), (i3), and (i4). z axis is directed according to the sign of the
+c vector product (i3)-(i2) and (i3)-(i4). sets fail to .true. if atoms
+c (i2) and (i3) or (i3) and (i4) coincide or atoms (i2), (i3), and (i4)
+c form a linear fragment. returns vectors e1, e2, and e3.
+ logical fail
+ double precision e1(3),e2(3),e3(3)
+ double precision u(3),z(3)
+ double precision coinc/1.0D-13/,align /1.0D-13/
+c print *,'just initialize'
+ fail=.false.
+c print *,fail
+ s1=0.0
+ s2=0.0
+ print *,s1,s2
+ do 1 i=1,3
+ print *, i2,i3,i4
+ zi=c(i,i2)-c(i,i3)
+ ui=c(i,i4)-c(i,i3)
+ print *,zi,ui
+ s1=s1+zi*zi
+ s2=s2+ui*ui
+ z(i)=zi
+ 1 u(i)=ui
+ s1=sqrt(s1)
+ s2=sqrt(s2)
+ if (s1.gt.coinc) goto 2
+ write (iout,1000) i2,i3,i1
+ fail=.true.
+ return
+ 2 if (s2.gt.coinc) goto 4
+ write(iout,1000) i3,i4,i1
+ fail=.true.
+ return
+ print *,'two if pass'
+ 4 s1=1.0/s1
+ s2=1.0/s2
+ v1=z(2)*u(3)-z(3)*u(2)
+ v2=z(3)*u(1)-z(1)*u(3)
+ v3=z(1)*u(2)-z(2)*u(1)
+ anorm=sqrt(v1*v1+v2*v2+v3*v3)
+ if (anorm.gt.align) goto 6
+ write (iout,1010) i2,i3,i4,i1
+ fail=.true.
+ return
+ 6 anorm=1.0/anorm
+ e3(1)=v1*anorm
+ e3(2)=v2*anorm
+ e3(3)=v3*anorm
+ e1(1)=z(1)*s1
+ e1(2)=z(2)*s1
+ e1(3)=z(3)*s1
+ e2(1)=e1(3)*e3(2)-e1(2)*e3(3)
+ e2(2)=e1(1)*e3(3)-e1(3)*e3(1)
+ e2(3)=e1(2)*e3(1)-e1(1)*e3(2)
+ 1000 format (/1x,' * * * Error - atoms',i4,' and',i4,' coincide.',
+ 1 'coordinates of atom',i4,' are set to zero.')
+ 1010 format (/1x,' * * * Error - atoms',2(i4,2h, ),i4,' form a linear',
+ 1 ' fragment. coordinates of atom',i4,' are set to zero.')
+ return
+ end
--- /dev/null
+ 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=-ntyp1,ntyp1
+ if (ucase(nam).eq.restyp(i)) then
+ rescode=i
+ return
+ endif
+ enddo
+
+ else
+
+ do i=-ntyp1,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
+
--- /dev/null
+ double precision function rmscalc_frag(ishif,i,j,jcon,kkk,
+ & 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'
+ include 'COMMON.CONTROL'
+ 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
+ integer kkk
+ if (lprn) then
+ write (iout,*) "i",i," j",j," jcont",jcon," ishif",ishif
+ write (iout,*) "npiece",npiece(j,i)
+ write (iout,*) "kkk",kkk
+ call flush(iout)
+ endif
+c write (iout,*) "symetr",symetr
+c call flush(iout)
+c nperm=1
+c do idup=1,symetr
+c nperm=nperm*idup
+c enddo
+c write (iout,*) "nperm",nperm
+c call flush(iout)
+c do kkk=1,nperm
+ idup=0
+ do l=1,nres
+ iadded(l)=.false.
+ enddo
+c write (iout,*) "kkk",kkk
+c call flush(iout)
+ do k=1,npiece(j,i)
+ if (i.eq.1) then
+ if (lprn) then
+ write (iout,*) "Level 1: j=",j,"k=",k," adding fragment",
+ & ifrag(1,k,j),ifrag(2,k,j)
+ call flush(iout)
+ endif
+ call cprep(ifrag(1,k,j),ifrag(2,k,j),ishif,idup,kkk)
+c write (iout,*) "Exit cprep"
+c call flush(iout)
+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) then
+ write (iout,*) "Level",i,": j=",j,"k=",k," kk=",kk,
+ & " l=",l," adding fragment",
+ & ifrag(1,l,kk),ifrag(2,l,kk)
+ call flush(iout)
+ endif
+ call cprep(ifrag(1,l,kk),ifrag(2,l,kk),ishif,idup,kkk)
+c write (iout,*) "After cprep"
+c call flush(iout)
+ enddo
+ endif
+ enddo
+ if (lprn) then
+ write (iout,*) "tuszukaj"
+c do kkk=1,nperm
+ do k=1,idup
+ 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
+c enddo
+ call flush(iout)
+ endif
+c rminrms=1.0d10
+c do kkk=1,nperm
+ call fitsq(rms,cc(1,1),creff(1,1),idup,przes,obrot,non_conv)
+ if (non_conv) then
+ print *,'Error: FITSQ non-convergent, jcon',jcon,i
+ rms = 1.0d10
+ else if (rms.lt.-1.0d-6) then
+ print *,'Error: rms^2 = ',rms,jcon,i
+ rms = 1.0d10
+ else if (rms.ge.1.0d-6 .and. rms.lt.0) then
+ rms = 0.0d0
+ endif
+c write (iout,*) "rmsmin", rminrms, "rms", rms
+c if (rms.le.rminrms) rminrms=rms
+c enddo
+ rmscalc_frag = dsqrt(rms)
+c write (iout, *) "analysys", rmscalc,anatemp
+ return
+ end
+c-------------------------------------------------------------------------
+ subroutine cprep(if1,if2,ishif,idup,kwa)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'DIMENSIONS.ZSCOPT'
+ include 'DIMENSIONS.COMPAR'
+ include 'COMMON.CONTROL'
+ 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),iistrart,kwa,blar
+ common /ccc/ creff,cc,iadded,inumber
+ integer ll,iperm
+c write (iout,*) "Calling cprep if1",if1," if2",if2," ishif",ishif,
+c & " kwa",kwa
+c nperm=1
+c do blar=1,symetr
+c nperm=nperm*blar
+c enddo
+c write (iout,*) "nperm",nperm
+c kkk=kwa
+c ii=0
+ do l=if1,if2
+c write (iout,*) "l",l," iadded",iadded(l)," ireschain",
+c & ireschain(l),ireschain(l+ishif)
+c call flush(iout)
+ if (l+ishif.gt.1 .and. l+ishif.le.nres .and. .not.iadded(l)
+ & .and. ireschain(l+ishif).gt.0 .and. ireschain(l).gt.0 .and.
+ & ireschain(l).eq.ireschain(l+ishif)) then
+ idup=idup+1
+ iadded(l)=.true.
+ inumber(1,idup)=l
+ inumber(2,idup)=l+ishif
+ ll=iperm(l+ishif,kwa)
+ do m=1,3
+ creff(m,idup)=cref(m,l)
+ cc(m,idup)=c(m,ll)
+ enddo
+c write (iout,'(2i5,3f10.5,5x,3f10.5)') l,ll,
+c & (creff(m,idup),m=1,3),(cc(m,idup),m=1,3)
+ endif
+ enddo
+c write (iout,*) "idup",idup
+ return
+ end
+c-------------------------------------------------------------------------
+ double precision function rmsnat(jcon,ipermmin)
+ 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'
+ include 'COMMON.CONTROL'
+ integer ipermmin
+ rmsnat = rmscalc(c(1,1),cref(1,1),ipermmin)
+ return
+ end
+c-----------------------------------------------------------------------------
+ double precision function rmscalc(ccc,cccref,ipermmin)
+ implicit none
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.VAR'
+ double precision cccref(3,maxres2),creff(3,maxres2),
+ & ccc(3,maxres2),cc(3,maxres2)
+ double precision przes(3),obrot(3,3)
+ logical non_conv
+ integer i,ii,j,ib,ichain,indchain,ichain1,ichain2,
+ & iperm,ipermmin
+ double precision rms,rmsmin
+C Loop over chain permutations
+c write (iout,*) "iz_sc",iz_sc
+ rmsmin=1.0d10
+ DO IPERM=1,NPERMCHAIN
+c write (iout,*) "iperm",iperm
+ ii=0
+ if (iz_sc.lt.2) then
+ do ichain=1,nchain
+ indchain=tabpermchain(ichain,iperm)
+#ifdef DEBUG
+ write (iout,*) "ichain",ichain," indchain",indchain
+ write (iout,*) "chain_border",chain_border(1,ichain),
+ & chain_border(2,ichain)
+#endif
+ do i=1,chain_length(ichain)
+c do i=nstart_sup(ichain),nend_sup(ichain)
+ ichain1=chain_border(1,ichain)+i-1
+ ichain2=chain_border(1,indchain)+i-1
+ if (ichain1.lt.nstart_sup .or. ichain1.gt.nend_sup .or.
+ & ichain2.lt.nstart_sup .or. ichain2.gt.nend_sup) cycle
+ ii=ii+1
+#ifdef DEBUG
+ write (iout,*) "back",ii," ichain1",ichain1,
+ & " ichain2",ichain2," i",i,chain_border(1,ichain)+i-1
+#endif
+ do j=1,3
+ cc(j,ii)=ccc(j,ichain2)
+ creff(j,ii)=cccref(j,ichain1)
+ enddo
+#ifdef DEBUG
+ write (iout,'(2i5,3f10.5,5x,3f10.5)')
+ & ichain1,ii,(cc(j,ii),j=1,3),(creff(j,ii),j=1,3)
+#endif
+ enddo
+ enddo
+ endif
+ if (iz_sc.gt.0) then
+ do ichain=1,nchain
+ indchain=tabpermchain(ichain,iperm)
+ do i=1,chain_length(ichain)
+c do i=nstart_sup(ichain),nend_sup(ichain)
+ ichain1=chain_border(1,ichain)+i-1
+ ichain2=chain_border(1,indchain)+i-1
+ if (ichain1.lt.nstart_sup .or. ichain1.gt.nend_sup .or.
+ & ichain2.lt.nstart_sup .or. ichain2.gt.nend_sup) cycle
+ if (itype(ichain1).ne.10) then
+ ii=ii+1
+#ifdef DEBUG
+ write (iout,*) "side",ii," ichain1",ichain1,
+ & " ichain2",ichain2
+#endif
+ do j=1,3
+ cc(j,ii)=ccc(j,ichain2+nres)
+ creff(j,ii)=cccref(j,ichain1+nres)
+ enddo
+#ifdef DEBUG
+ write (iout,'(2i5,3f10.5,5x,3f10.5)')
+ & ichain1+nres,ii,(cc(j,ii),j=1,3),(creff(j,ii),j=1,3)
+#endif
+ endif
+ enddo
+ enddo
+ endif
+c write (iout,*) "rmscalc: iprot",iprot," nsup",nsup(iprot)," ii",ii
+ call fitsq(rms,cc(1,1),creff(1,1),ii,przes,obrot,non_conv)
+ if (non_conv) then
+ write (iout,*) 'Error: FITSQ non-convergent'
+ rms=1.0d2
+ else if (rms.lt.-1.0d-6) then
+ print *,'Error: rms^2 = ',rms
+ rms = 1.0d2
+ else if (rms.ge.1.0d-6 .and. rms.lt.0) then
+ rmscalc=0.0d0
+ else
+ rms = dsqrt(rms)
+ endif
+ if (rms.lt.rmsmin) then
+ rmsmin=rms
+ ipermmin=iperm
+ endif
+#ifdef DEBUG
+ write (iout,*) "iperm",iperm," rms",rms
+#endif
+ ENDDO
+ rmscalc=rmsmin
+#ifdef DEBUG
+ write (iout,*) "ipermmin",ipermmin," rmsmin",rmsmin
+#endif
+ return
+ end
+c-----------------------------------------------------------------------------
+ double precision function gyrate(jcon)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CHAIN'
+ include 'COMMON.IOUNITS'
+ double precision cen(3),rg
+
+ do j=1,3
+ cen(j)=0.0d0
+ enddo
+
+ ii=0
+ do i=nnt,nct
+ if (itype(i).eq.ntyp1) cycle
+ ii=ii+1
+ do j=1,3
+ cen(j)=cen(j)+c(j,i)
+ enddo
+ enddo
+ do j=1,3
+ cen(j)=cen(j)/dble(ii)
+ enddo
+ rg = 0.0d0
+ do i = nnt, nct
+ if (itype(i).eq.ntyp1) cycle
+ do j=1,3
+ rg = rg + (c(j,i)-cen(j))**2
+ enddo
+ end do
+ gyrate = dsqrt(rg/dble(ii))
+ return
+ end
--- /dev/null
+sed -n 's/D/E/gp' | awk '{print $2,$4,$2*$4;sum=sum+$2*$4}END{print sum}'
--- /dev/null
+ 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:',anatemp
+ 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),anatemp
+ 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
+
--- /dev/null
+ subroutine seq2chains(nres,itype,nchain,chain_length,chain_border,
+ & ireschain)
+c
+c Split the total UNRES sequence, which has dummy residues separating
+c the chains, into separate chains. The length of chain ichain is
+c contained in chain_length(ichain), the first and last non-dummy
+c residues are in chain_border(1,ichain) and chain_border(2,ichain),
+c respectively. The lengths pertain to non-dummy residues only.
+c
+ implicit none
+ include 'DIMENSIONS'
+ integer nres,itype(nres),nchain,chain_length(nres),
+ & chain_border(2,nres),ireschain(nres)
+ integer ii,ichain,i,j
+ logical new_chain
+ ichain=1
+ new_chain=.true.
+ chain_length(ichain)=0
+ ii=1
+ do while (ii.lt.nres)
+ if (itype(ii).eq.ntyp1) then
+ if (.not.new_chain) then
+ new_chain=.true.
+ chain_border(2,ichain)=ii-1
+ ichain=ichain+1
+ chain_border(1,ichain)=ii+1
+ chain_length(ichain)=0
+ endif
+ else
+ if (new_chain) then
+ chain_border(1,ichain)=ii
+ new_chain=.false.
+ endif
+ chain_length(ichain)=chain_length(ichain)+1
+ endif
+ ii=ii+1
+ enddo
+ if (itype(nres).eq.ntyp1) then
+ ii=ii-1
+ else
+ chain_length(ichain)=chain_length(ichain)+1
+ endif
+ if (chain_length(ichain).gt.0) then
+ chain_border(2,ichain)=ii
+ nchain=ichain
+ else
+ nchain=ichain-1
+ endif
+ ireschain=0
+ do i=1,nchain
+ do j=chain_border(1,i),chain_border(2,i)
+ ireschain(j)=i
+ enddo
+ enddo
+ return
+ end
--- /dev/null
+ 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
--- /dev/null
+ 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
--- /dev/null
+c----------------------------------------------------------------------------
+ subroutine check_energies
+c implicit none
+
+c Includes
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.VAR'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.LOCAL'
+ include 'COMMON.GEO'
+
+c External functions
+ double precision ran_number
+ external ran_number
+
+c Local variables
+ integer i,j,k,l,lmax,p,pmax
+ double precision rmin,rmax
+ double precision eij
+
+ double precision d
+ double precision wi,rij,tj,pj
+
+
+c return
+
+ i=5
+ j=14
+
+ d=dsc(1)
+ rmin=2.0D0
+ rmax=12.0D0
+
+ lmax=10000
+ pmax=1
+
+ do k=1,3
+ c(k,i)=0.0D0
+ c(k,j)=0.0D0
+ c(k,nres+i)=0.0D0
+ c(k,nres+j)=0.0D0
+ enddo
+
+ do l=1,lmax
+
+ct wi=ran_number(0.0D0,pi)
+c wi=ran_number(0.0D0,pi/6.0D0)
+c wi=0.0D0
+ct tj=ran_number(0.0D0,pi)
+ct pj=ran_number(0.0D0,pi)
+c pj=ran_number(0.0D0,pi/6.0D0)
+c pj=0.0D0
+
+ do p=1,pmax
+ct rij=ran_number(rmin,rmax)
+
+ c(1,j)=d*sin(pj)*cos(tj)
+ c(2,j)=d*sin(pj)*sin(tj)
+ c(3,j)=d*cos(pj)
+
+ c(3,nres+i)=-rij
+
+ c(1,i)=d*sin(wi)
+ c(3,i)=-rij-d*cos(wi)
+
+ do k=1,3
+ dc(k,nres+i)=c(k,nres+i)-c(k,i)
+ dc_norm(k,nres+i)=dc(k,nres+i)/d
+ dc(k,nres+j)=c(k,nres+j)-c(k,j)
+ dc_norm(k,nres+j)=dc(k,nres+j)/d
+ enddo
+
+ call dyn_ssbond_ene(i,j,eij)
+ enddo
+ enddo
+
+ call exit(1)
+
+ return
+ end
+
+C-----------------------------------------------------------------------------
+
+ subroutine dyn_ssbond_ene(resi,resj,eij)
+c implicit none
+
+c Includes
+ include 'DIMENSIONS'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.VAR'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CALC'
+#ifndef CLUST
+#ifndef WHAM
+C include 'COMMON.MD'
+#endif
+#endif
+
+c External functions
+ double precision h_base
+ external h_base
+
+c Input arguments
+ integer resi,resj
+
+c Output arguments
+ double precision eij
+
+c Local variables
+ logical havebond
+c integer itypi,itypj,k,l
+ double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
+ double precision sig0ij,ljd,sig,fac,e1,e2
+ double precision dcosom1(3),dcosom2(3),ed
+ double precision pom1,pom2
+ double precision ljA,ljB,ljXs
+ double precision d_ljB(1:3)
+ double precision ssA,ssB,ssC,ssXs
+ double precision ssxm,ljxm,ssm,ljm
+ double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
+ double precision f1,f2,h1,h2,hd1,hd2
+ double precision omega,delta_inv,deltasq_inv,fac1,fac2
+c-------FIRST METHOD
+ double precision xm,d_xm(1:3)
+c-------END FIRST METHOD
+c-------SECOND METHOD
+c$$$ double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
+c-------END SECOND METHOD
+
+c-------TESTING CODE
+ logical checkstop,transgrad
+ common /sschecks/ checkstop,transgrad
+
+ integer icheck,nicheck,jcheck,njcheck
+ double precision echeck(-1:1),deps,ssx0,ljx0
+c-------END TESTING CODE
+
+
+ i=resi
+ j=resj
+
+ itypi=itype(i)
+ dxi=dc_norm(1,nres+i)
+ dyi=dc_norm(2,nres+i)
+ dzi=dc_norm(3,nres+i)
+ dsci_inv=vbld_inv(i+nres)
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+ xi=mod(xi,boxxsize)
+ if (xi.lt.0) xi=xi+boxxsize
+ yi=mod(yi,boxysize)
+ if (yi.lt.0) yi=yi+boxysize
+ zi=mod(zi,boxzsize)
+ if (zi.lt.0) zi=zi+boxzsize
+ if ((zi.gt.bordlipbot)
+ &.and.(zi.lt.bordliptop)) then
+C the energy transfer exist
+ if (zi.lt.buflipbot) then
+C what fraction I am in
+ fracinbuf=1.0d0-
+ & ((zi-bordlipbot)/lipbufthick)
+C lipbufthick is thickenes of lipid buffore
+ sslipi=sscalelip(fracinbuf)
+ ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
+ elseif (zi.gt.bufliptop) then
+ fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
+ sslipi=sscalelip(fracinbuf)
+ ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
+ else
+ sslipi=1.0d0
+ ssgradlipi=0.0
+ endif
+ else
+ sslipi=0.0d0
+ ssgradlipi=0.0
+ endif
+ itypj=itype(j)
+ xj=c(1,nres+j)
+ yj=c(2,nres+j)
+ zj=c(3,nres+j)
+ xj=mod(xj,boxxsize)
+ if (xj.lt.0) xj=xj+boxxsize
+ yj=mod(yj,boxysize)
+ if (yj.lt.0) yj=yj+boxysize
+ zj=mod(zj,boxzsize)
+ if (zj.lt.0) zj=zj+boxzsize
+ if ((zj.gt.bordlipbot)
+ &.and.(zj.lt.bordliptop)) then
+C the energy transfer exist
+ if (zj.lt.buflipbot) then
+C what fraction I am in
+ fracinbuf=1.0d0-
+ & ((zj-bordlipbot)/lipbufthick)
+C lipbufthick is thickenes of lipid buffore
+ sslipj=sscalelip(fracinbuf)
+ ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
+ elseif (zj.gt.bufliptop) then
+ fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
+ sslipj=sscalelip(fracinbuf)
+ ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
+ else
+ sslipj=1.0d0
+ ssgradlipj=0.0
+ endif
+ else
+ sslipj=0.0d0
+ ssgradlipj=0.0
+ endif
+ aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
+ & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
+ bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
+ & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
+ xj=xj-xi
+ yj=yj-yi
+ zj=zj-zi
+ dxj=dc_norm(1,nres+j)
+ dyj=dc_norm(2,nres+j)
+ dzj=dc_norm(3,nres+j)
+ dscj_inv=vbld_inv(j+nres)
+
+ chi1=chi(itypi,itypj)
+ chi2=chi(itypj,itypi)
+ chi12=chi1*chi2
+ chip1=chip(itypi)
+ chip2=chip(itypj)
+ chip12=chip1*chip2
+ alf1=alp(itypi)
+ alf2=alp(itypj)
+ alf12=0.5D0*(alf1+alf2)
+
+ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
+ rij=dsqrt(rrij) ! sc_angular needs rij to really be the inverse
+c The following are set in sc_angular
+c erij(1)=xj*rij
+c erij(2)=yj*rij
+c erij(3)=zj*rij
+c om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
+c om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
+c om12=dxi*dxj+dyi*dyj+dzi*dzj
+ call sc_angular
+ rij=1.0D0/rij ! Reset this so it makes sense
+
+ sig0ij=sigma(itypi,itypj)
+ sig=sig0ij*dsqrt(1.0D0/sigsq)
+
+ ljXs=sig-sig0ij
+ ljA=eps1*eps2rt**2*eps3rt**2
+ ljB=ljA*bb
+ ljA=ljA*aa
+ ljxm=ljXs+(-2.0D0*aa/bb)**(1.0D0/6.0D0)
+
+ ssXs=d0cm
+ deltat1=1.0d0-om1
+ deltat2=1.0d0+om2
+ deltat12=om2-om1+2.0d0
+ cosphi=om12-om1*om2
+ ssA=akcm
+ ssB=akct*deltat12
+ ssC=ss_depth
+ & +akth*(deltat1*deltat1+deltat2*deltat2)
+ & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
+ ssxm=ssXs-0.5D0*ssB/ssA
+
+c-------TESTING CODE
+c$$$c Some extra output
+c$$$ ssm=ssC-0.25D0*ssB*ssB/ssA
+c$$$ ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
+c$$$ ssx0=ssB*ssB-4.0d0*ssA*ssC
+c$$$ if (ssx0.gt.0.0d0) then
+c$$$ ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
+c$$$ else
+c$$$ ssx0=ssxm
+c$$$ endif
+c$$$ ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
+c$$$ write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
+c$$$ & ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
+c$$$ return
+c-------END TESTING CODE
+
+c-------TESTING CODE
+c Stop and plot energy and derivative as a function of distance
+ if (checkstop) then
+ ssm=ssC-0.25D0*ssB*ssB/ssA
+ ljm=-0.25D0*ljB*bb/aa
+ if (ssm.lt.ljm .and.
+ & dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
+ nicheck=1000
+ njcheck=1
+ deps=0.5d-7
+ else
+ checkstop=.false.
+ endif
+ endif
+ if (.not.checkstop) then
+ nicheck=0
+ njcheck=-1
+ endif
+
+ do icheck=0,nicheck
+ do jcheck=-1,njcheck
+ if (checkstop) rij=(ssxm-1.0d0)+
+ & ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
+c-------END TESTING CODE
+
+ if (rij.gt.ljxm) then
+ havebond=.false.
+ ljd=rij-ljXs
+ fac=(1.0D0/ljd)**expon
+ e1=fac*fac*aa
+ e2=fac*bb
+ eij=eps1*eps2rt*eps3rt*(e1+e2)
+C write(iout,*) eij,'TU?1'
+ eps2der=eij*eps3rt
+ eps3der=eij*eps2rt
+ eij=eij*eps2rt*eps3rt
+
+ sigder=-sig/sigsq
+ e1=e1*eps1*eps2rt**2*eps3rt**2
+ ed=-expon*(e1+eij)/ljd
+ sigder=ed*sigder
+ eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
+ eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
+ eom12=eij*eps1_om12+eps2der*eps2rt_om12
+ & -2.0D0*alf12*eps3der+sigder*sigsq_om12
+ else if (rij.lt.ssxm) then
+ havebond=.true.
+ ssd=rij-ssXs
+ eij=ssA*ssd*ssd+ssB*ssd+ssC
+C write(iout,*) 'TU?2',ssc,ssd
+ ed=2*akcm*ssd+akct*deltat12
+ pom1=akct*ssd
+ pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
+ eom1=-2*akth*deltat1-pom1-om2*pom2
+ eom2= 2*akth*deltat2+pom1-om1*pom2
+ eom12=pom2
+ else
+ omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
+
+ d_ssxm(1)=0.5D0*akct/ssA
+ d_ssxm(2)=-d_ssxm(1)
+ d_ssxm(3)=0.0D0
+
+ d_ljxm(1)=sig0ij/sqrt(sigsq**3)
+ d_ljxm(2)=d_ljxm(1)*sigsq_om2
+ d_ljxm(3)=d_ljxm(1)*sigsq_om12
+ d_ljxm(1)=d_ljxm(1)*sigsq_om1
+
+c-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
+ xm=0.5d0*(ssxm+ljxm)
+ do k=1,3
+ d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
+ enddo
+ if (rij.lt.xm) then
+ havebond=.true.
+ ssm=ssC-0.25D0*ssB*ssB/ssA
+ d_ssm(1)=0.5D0*akct*ssB/ssA
+ d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
+ d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
+ d_ssm(3)=omega
+ f1=(rij-xm)/(ssxm-xm)
+ f2=(rij-ssxm)/(xm-ssxm)
+ h1=h_base(f1,hd1)
+ h2=h_base(f2,hd2)
+ eij=ssm*h1+Ht*h2
+C write(iout,*) eij,'TU?3'
+ delta_inv=1.0d0/(xm-ssxm)
+ deltasq_inv=delta_inv*delta_inv
+ fac=ssm*hd1-Ht*hd2
+ fac1=deltasq_inv*fac*(xm-rij)
+ fac2=deltasq_inv*fac*(rij-ssxm)
+ ed=delta_inv*(Ht*hd2-ssm*hd1)
+ eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
+ eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
+ eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
+ else
+ havebond=.false.
+ ljm=-0.25D0*ljB*bb/aa
+ d_ljm(1)=-0.5D0*bb/aa*ljB
+ d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
+ d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt-
+ + alf12/eps3rt)
+ d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
+ f1=(rij-ljxm)/(xm-ljxm)
+ f2=(rij-xm)/(ljxm-xm)
+ h1=h_base(f1,hd1)
+ h2=h_base(f2,hd2)
+ eij=Ht*h1+ljm*h2
+C write(iout,*) 'TU?4',ssA
+ delta_inv=1.0d0/(ljxm-xm)
+ deltasq_inv=delta_inv*delta_inv
+ fac=Ht*hd1-ljm*hd2
+ fac1=deltasq_inv*fac*(ljxm-rij)
+ fac2=deltasq_inv*fac*(rij-xm)
+ ed=delta_inv*(ljm*hd2-Ht*hd1)
+ eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
+ eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
+ eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
+ endif
+c-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
+
+c-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
+c$$$ ssd=rij-ssXs
+c$$$ ljd=rij-ljXs
+c$$$ fac1=rij-ljxm
+c$$$ fac2=rij-ssxm
+c$$$
+c$$$ d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
+c$$$ d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
+c$$$ d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
+c$$$
+c$$$ ssm=ssC-0.25D0*ssB*ssB/ssA
+c$$$ d_ssm(1)=0.5D0*akct*ssB/ssA
+c$$$ d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
+c$$$ d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
+c$$$ d_ssm(3)=omega
+c$$$
+c$$$ ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
+c$$$ do k=1,3
+c$$$ d_ljm(k)=ljm*d_ljB(k)
+c$$$ enddo
+c$$$ ljm=ljm*ljB
+c$$$
+c$$$ ss=ssA*ssd*ssd+ssB*ssd+ssC
+c$$$ d_ss(0)=2.0d0*ssA*ssd+ssB
+c$$$ d_ss(2)=akct*ssd
+c$$$ d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
+c$$$ d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
+c$$$ d_ss(3)=omega
+c$$$
+c$$$ ljf=bb(itypi,itypj)/aa(itypi,itypj)
+c$$$ ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
+c$$$ d_ljf(0)=ljf*2.0d0*ljB*fac1
+c$$$ do k=1,3
+c$$$ d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
+c$$$ & 2.0d0*ljB*fac1*d_ljxm(k))
+c$$$ enddo
+c$$$ ljf=ljm+ljf*ljB*fac1*fac1
+c$$$
+c$$$ f1=(rij-ljxm)/(ssxm-ljxm)
+c$$$ f2=(rij-ssxm)/(ljxm-ssxm)
+c$$$ h1=h_base(f1,hd1)
+c$$$ h2=h_base(f2,hd2)
+c$$$ eij=ss*h1+ljf*h2
+c$$$ delta_inv=1.0d0/(ljxm-ssxm)
+c$$$ deltasq_inv=delta_inv*delta_inv
+c$$$ fac=ljf*hd2-ss*hd1
+c$$$ ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
+c$$$ eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
+c$$$ & (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
+c$$$ eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
+c$$$ & (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
+c$$$ eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
+c$$$ & (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
+c$$$
+c$$$ havebond=.false.
+c$$$ if (ed.gt.0.0d0) havebond=.true.
+c-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
+
+ endif
+ write(iout,*) 'havebond',havebond
+ if (havebond) then
+#ifndef CLUST
+#ifndef WHAM
+c if (dyn_ssbond_ij(i,j).eq.1.0d300) then
+c write(iout,'(a15,f12.2,f8.1,2i5)')
+c & "SSBOND_E_FORM",totT,t_bath,i,j
+c endif
+#endif
+#endif
+ dyn_ssbond_ij(i,j)=eij
+ else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
+ dyn_ssbond_ij(i,j)=1.0d300
+#ifndef CLUST
+#ifndef WHAM
+c write(iout,'(a15,f12.2,f8.1,2i5)')
+c & "SSBOND_E_BREAK",totT,t_bath,i,j
+#endif
+#endif
+ endif
+
+c-------TESTING CODE
+ if (checkstop) then
+ if (jcheck.eq.0) write(iout,'(a,3f15.8,$)')
+ & "CHECKSTOP",rij,eij,ed
+ echeck(jcheck)=eij
+ endif
+ enddo
+ if (checkstop) then
+ write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
+ endif
+ enddo
+ if (checkstop) then
+ transgrad=.true.
+ checkstop=.false.
+ endif
+c-------END TESTING CODE
+
+ do k=1,3
+ dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
+ dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
+ enddo
+ do k=1,3
+ gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
+ enddo
+ do k=1,3
+ gvdwx(k,i)=gvdwx(k,i)-gg(k)
+ & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
+ & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
+ gvdwx(k,j)=gvdwx(k,j)+gg(k)
+ & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
+ & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
+ enddo
+cgrad do k=i,j-1
+cgrad do l=1,3
+cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
+cgrad enddo
+cgrad enddo
+
+ do l=1,3
+ gvdwc(l,i)=gvdwc(l,i)-gg(l)
+ gvdwc(l,j)=gvdwc(l,j)+gg(l)
+ enddo
+
+ return
+ end
+
+C-----------------------------------------------------------------------------
+
+ double precision function h_base(x,deriv)
+c A smooth function going 0->1 in range [0,1]
+c It should NOT be called outside range [0,1], it will not work there.
+ implicit none
+
+c Input arguments
+ double precision x
+
+c Output arguments
+ double precision deriv
+
+c Local variables
+ double precision xsq
+
+
+c Two parabolas put together. First derivative zero at extrema
+c$$$ if (x.lt.0.5D0) then
+c$$$ h_base=2.0D0*x*x
+c$$$ deriv=4.0D0*x
+c$$$ else
+c$$$ deriv=1.0D0-x
+c$$$ h_base=1.0D0-2.0D0*deriv*deriv
+c$$$ deriv=4.0D0*deriv
+c$$$ endif
+
+c Third degree polynomial. First derivative zero at extrema
+ h_base=x*x*(3.0d0-2.0d0*x)
+ deriv=6.0d0*x*(1.0d0-x)
+
+c Fifth degree polynomial. First and second derivatives zero at extrema
+c$$$ xsq=x*x
+c$$$ h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
+c$$$ deriv=x-1.0d0
+c$$$ deriv=deriv*deriv
+c$$$ deriv=30.0d0*xsq*deriv
+
+ return
+ end
+
+c----------------------------------------------------------------------------
+
+ subroutine dyn_set_nss
+c Adjust nss and other relevant variables based on dyn_ssbond_ij
+c implicit none
+
+c Includes
+ include 'DIMENSIONS'
+#ifdef MPI
+ include "mpif.h"
+#endif
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.CHAIN'
+ include 'COMMON.IOUNITS'
+C include 'COMMON.SETUP'
+#ifndef CLUST
+#ifndef WHAM
+C include 'COMMON.MD'
+#endif
+#endif
+
+c Local variables
+ double precision emin
+ integer i,j,imin
+ integer diff,allflag(maxdim),allnss,
+ & allihpb(maxdim),alljhpb(maxdim),
+ & newnss,newihpb(maxdim),newjhpb(maxdim)
+ logical found
+ integer i_newnss(1024),displ(0:1024)
+ integer g_newihpb(maxdim),g_newjhpb(maxdim),g_newnss
+
+ allnss=0
+ do i=1,nres-1
+ do j=i+1,nres
+ if (dyn_ssbond_ij(i,j).lt.1.0d300) then
+ allnss=allnss+1
+ allflag(allnss)=0
+ allihpb(allnss)=i
+ alljhpb(allnss)=j
+ endif
+ enddo
+ enddo
+
+cmc write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
+
+ 1 emin=1.0d300
+ do i=1,allnss
+ if (allflag(i).eq.0 .and.
+ & dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
+ emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
+ imin=i
+ endif
+ enddo
+ if (emin.lt.1.0d300) then
+ allflag(imin)=1
+ do i=1,allnss
+ if (allflag(i).eq.0 .and.
+ & (allihpb(i).eq.allihpb(imin) .or.
+ & alljhpb(i).eq.allihpb(imin) .or.
+ & allihpb(i).eq.alljhpb(imin) .or.
+ & alljhpb(i).eq.alljhpb(imin))) then
+ allflag(i)=-1
+ endif
+ enddo
+ goto 1
+ endif
+
+cmc write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
+
+ newnss=0
+ do i=1,allnss
+ if (allflag(i).eq.1) then
+ newnss=newnss+1
+ newihpb(newnss)=allihpb(i)
+ newjhpb(newnss)=alljhpb(i)
+ endif
+ enddo
+
+#ifdef MPI
+ if (nfgtasks.gt.1)then
+
+ call MPI_Reduce(newnss,g_newnss,1,
+ & MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
+ call MPI_Gather(newnss,1,MPI_INTEGER,
+ & i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
+ displ(0)=0
+ do i=1,nfgtasks-1,1
+ displ(i)=i_newnss(i-1)+displ(i-1)
+ enddo
+ call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,
+ & g_newihpb,i_newnss,displ,MPI_INTEGER,
+ & king,FG_COMM,IERR)
+ call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,
+ & g_newjhpb,i_newnss,displ,MPI_INTEGER,
+ & king,FG_COMM,IERR)
+ if(fg_rank.eq.0) then
+c print *,'g_newnss',g_newnss
+c print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
+c print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
+ newnss=g_newnss
+ do i=1,newnss
+ newihpb(i)=g_newihpb(i)
+ newjhpb(i)=g_newjhpb(i)
+ enddo
+ endif
+ endif
+#endif
+
+ diff=newnss-nss
+
+cmc write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
+
+ do i=1,nss
+ found=.false.
+ do j=1,newnss
+ if (idssb(i).eq.newihpb(j) .and.
+ & jdssb(i).eq.newjhpb(j)) found=.true.
+ enddo
+#ifndef CLUST
+#ifndef WHAM
+c if (.not.found.and.fg_rank.eq.0)
+c & write(iout,'(a15,f12.2,f8.1,2i5)')
+c & "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
+#endif
+#endif
+ enddo
+
+ do i=1,newnss
+ found=.false.
+ do j=1,nss
+ if (newihpb(i).eq.idssb(j) .and.
+ & newjhpb(i).eq.jdssb(j)) found=.true.
+ enddo
+#ifndef CLUST
+#ifndef WHAM
+c if (.not.found.and.fg_rank.eq.0)
+c & write(iout,'(a15,f12.2,f8.1,2i5)')
+c & "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
+#endif
+#endif
+ enddo
+
+ nss=newnss
+ do i=1,nss
+ idssb(i)=newihpb(i)
+ jdssb(i)=newjhpb(i)
+ enddo
+
+ return
+ end
+
+c----------------------------------------------------------------------------
+
+#ifdef SSREAD
+#ifdef WHAM
+ subroutine read_ssHist
+ implicit none
+
+c Includes
+ include 'DIMENSIONS'
+ include "DIMENSIONS.FREE"
+ include 'COMMON.FREE'
+
+c Local variables
+ integer i,j
+ character*80 controlcard
+
+ do i=1,dyn_nssHist
+ call card_concat(controlcard,.true.)
+ read(controlcard,*)
+ & dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
+ enddo
+
+ return
+ end
+#endif
+#endif
+c----------------------------------------------------------------------------
+
+
+C-----------------------------------------------------------------------------
+C-----------------------------------------------------------------------------
+C-----------------------------------------------------------------------------
+C-----------------------------------------------------------------------------
+C-----------------------------------------------------------------------------
+C-----------------------------------------------------------------------------
+C-----------------------------------------------------------------------------
+
+c$$$c-----------------------------------------------------------------------------
+c$$$
+c$$$ subroutine ss_relax(i_in,j_in)
+c$$$ implicit none
+c$$$
+c$$$c Includes
+c$$$ include 'DIMENSIONS'
+c$$$ include 'COMMON.VAR'
+c$$$ include 'COMMON.CHAIN'
+c$$$ include 'COMMON.IOUNITS'
+c$$$ include 'COMMON.INTERACT'
+c$$$
+c$$$c Input arguments
+c$$$ integer i_in,j_in
+c$$$
+c$$$c Local variables
+c$$$ integer i,iretcode,nfun_sc
+c$$$ logical scfail
+c$$$ double precision var(maxvar),e_sc,etot
+c$$$
+c$$$
+c$$$ mask_r=.true.
+c$$$ do i=nnt,nct
+c$$$ mask_side(i)=0
+c$$$ enddo
+c$$$ mask_side(i_in)=1
+c$$$ mask_side(j_in)=1
+c$$$
+c$$$c Minimize the two selected side-chains
+c$$$ call overlap_sc(scfail) ! Better not fail!
+c$$$ call minimize_sc(e_sc,var,iretcode,nfun_sc)
+c$$$
+c$$$ mask_r=.false.
+c$$$
+c$$$ return
+c$$$ end
+c$$$
+c$$$c-------------------------------------------------------------
+c$$$
+c$$$ subroutine minimize_sc(etot_sc,iretcode,nfun)
+c$$$c Minimize side-chains only, starting from geom but without modifying
+c$$$c bond lengths.
+c$$$c If mask_r is already set, only the selected side-chains are minimized,
+c$$$c otherwise all side-chains are minimized keeping the backbone frozen.
+c$$$ implicit none
+c$$$
+c$$$c Includes
+c$$$ include 'DIMENSIONS'
+c$$$ include 'COMMON.IOUNITS'
+c$$$ include 'COMMON.VAR'
+c$$$ include 'COMMON.CHAIN'
+c$$$ include 'COMMON.GEO'
+c$$$ include 'COMMON.MINIM'
+c$$$ integer icall
+c$$$ common /srutu/ icall
+c$$$
+c$$$c Output arguments
+c$$$ double precision etot_sc
+c$$$ integer iretcode,nfun
+c$$$
+c$$$c External functions/subroutines
+c$$$ external func_sc,grad_sc,fdum
+c$$$
+c$$$c Local variables
+c$$$ integer liv,lv
+c$$$ parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2))
+c$$$ integer iv(liv)
+c$$$ double precision rdum(1)
+c$$$ double precision d(maxvar),v(1:lv),x(maxvar),xx(maxvar)
+c$$$ integer idum(1)
+c$$$ integer i,nvar_restr
+c$$$
+c$$$
+c$$$cmc start_minim=.true.
+c$$$ call deflt(2,iv,liv,lv,v)
+c$$$* 12 means fresh start, dont call deflt
+c$$$ iv(1)=12
+c$$$* max num of fun calls
+c$$$ if (maxfun.eq.0) maxfun=500
+c$$$ iv(17)=maxfun
+c$$$* max num of iterations
+c$$$ if (maxmin.eq.0) maxmin=1000
+c$$$ iv(18)=maxmin
+c$$$* controls output
+c$$$ iv(19)=1
+c$$$* selects output unit
+c$$$ iv(21)=0
+c$$$c iv(21)=iout ! DEBUG
+c$$$c iv(21)=8 ! DEBUG
+c$$$* 1 means to print out result
+c$$$ iv(22)=0
+c$$$c iv(22)=1 ! DEBUG
+c$$$* 1 means to print out summary stats
+c$$$ iv(23)=0
+c$$$c iv(23)=1 ! DEBUG
+c$$$* 1 means to print initial x and d
+c$$$ iv(24)=0
+c$$$c iv(24)=1 ! DEBUG
+c$$$* min val for v(radfac) default is 0.1
+c$$$ v(24)=0.1D0
+c$$$* max val for v(radfac) default is 4.0
+c$$$ v(25)=2.0D0
+c$$$c v(25)=4.0D0
+c$$$* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease)
+c$$$* the sumsl default is 0.1
+c$$$ v(26)=0.1D0
+c$$$* false conv if (act fnctn decrease) .lt. v(34)
+c$$$* the sumsl default is 100*machep
+c$$$ v(34)=v(34)/100.0D0
+c$$$* absolute convergence
+c$$$ if (tolf.eq.0.0D0) tolf=1.0D-4
+c$$$ v(31)=tolf
+c$$$* relative convergence
+c$$$ if (rtolf.eq.0.0D0) rtolf=1.0D-1
+c$$$ v(32)=rtolf
+c$$$* controls initial step size
+c$$$ v(35)=1.0D-1
+c$$$* large vals of d correspond to small components of step
+c$$$ do i=1,nphi
+c$$$ d(i)=1.0D-1
+c$$$ enddo
+c$$$ do i=nphi+1,nvar
+c$$$ d(i)=1.0D-1
+c$$$ enddo
+c$$$
+c$$$ call geom_to_var(nvar,x)
+c$$$ IF (mask_r) THEN
+c$$$ do i=1,nres ! Just in case...
+c$$$ mask_phi(i)=0
+c$$$ mask_theta(i)=0
+c$$$ enddo
+c$$$ call x2xx(x,xx,nvar_restr)
+c$$$ call sumsl(nvar_restr,d,xx,func_sc,grad_sc,
+c$$$ & iv,liv,lv,v,idum,rdum,fdum)
+c$$$ call xx2x(x,xx)
+c$$$ ELSE
+c$$$c When minimizing ALL side-chains, etotal_sc is a little
+c$$$c faster if we don't set mask_r
+c$$$ do i=1,nres
+c$$$ mask_phi(i)=0
+c$$$ mask_theta(i)=0
+c$$$ mask_side(i)=1
+c$$$ enddo
+c$$$ call x2xx(x,xx,nvar_restr)
+c$$$ call sumsl(nvar_restr,d,xx,func_sc,grad_sc,
+c$$$ & iv,liv,lv,v,idum,rdum,fdum)
+c$$$ call xx2x(x,xx)
+c$$$ ENDIF
+c$$$ call var_to_geom(nvar,x)
+c$$$ call chainbuild_sc
+c$$$ etot_sc=v(10)
+c$$$ iretcode=iv(1)
+c$$$ nfun=iv(6)
+c$$$ return
+c$$$ end
+c$$$
+c$$$C--------------------------------------------------------------------------
+c$$$
+c$$$ subroutine chainbuild_sc
+c$$$ implicit none
+c$$$ include 'DIMENSIONS'
+c$$$ include 'COMMON.VAR'
+c$$$ include 'COMMON.INTERACT'
+c$$$
+c$$$c Local variables
+c$$$ integer i
+c$$$
+c$$$
+c$$$ do i=nnt,nct
+c$$$ if (.not.mask_r .or. mask_side(i).eq.1) then
+c$$$ call locate_side_chain(i)
+c$$$ endif
+c$$$ enddo
+c$$$
+c$$$ return
+c$$$ end
+c$$$
+c$$$C--------------------------------------------------------------------------
+c$$$
+c$$$ subroutine func_sc(n,x,nf,f,uiparm,urparm,ufparm)
+c$$$ implicit none
+c$$$
+c$$$c Includes
+c$$$ include 'DIMENSIONS'
+c$$$ include 'COMMON.DERIV'
+c$$$ include 'COMMON.VAR'
+c$$$ include 'COMMON.MINIM'
+c$$$ include 'COMMON.IOUNITS'
+c$$$
+c$$$c Input arguments
+c$$$ integer n
+c$$$ double precision x(maxvar)
+c$$$ double precision ufparm
+c$$$ external ufparm
+c$$$
+c$$$c Input/Output arguments
+c$$$ integer nf
+c$$$ integer uiparm(1)
+c$$$ double precision urparm(1)
+c$$$
+c$$$c Output arguments
+c$$$ double precision f
+c$$$
+c$$$c Local variables
+c$$$ double precision energia(0:n_ene)
+c$$$#ifdef OSF
+c$$$c Variables used to intercept NaNs
+c$$$ double precision x_sum
+c$$$ integer i_NAN
+c$$$#endif
+c$$$
+c$$$
+c$$$ nfl=nf
+c$$$ icg=mod(nf,2)+1
+c$$$
+c$$$#ifdef OSF
+c$$$c Intercept NaNs in the coordinates, before calling etotal_sc
+c$$$ x_sum=0.D0
+c$$$ do i_NAN=1,n
+c$$$ x_sum=x_sum+x(i_NAN)
+c$$$ enddo
+c$$$c Calculate the energy only if the coordinates are ok
+c$$$ if ((.not.(x_sum.lt.0.D0)) .and. (.not.(x_sum.ge.0.D0))) then
+c$$$ write(iout,*)" *** func_restr_sc : Found NaN in coordinates"
+c$$$ f=1.0D+77
+c$$$ nf=0
+c$$$ else
+c$$$#endif
+c$$$
+c$$$ call var_to_geom_restr(n,x)
+c$$$ call zerograd
+c$$$ call chainbuild_sc
+c$$$ call etotal_sc(energia(0))
+c$$$ f=energia(0)
+c$$$ if (energia(1).eq.1.0D20 .or. energia(0).eq.1.0D99) nf=0
+c$$$
+c$$$#ifdef OSF
+c$$$ endif
+c$$$#endif
+c$$$
+c$$$ return
+c$$$ end
+c$$$
+c$$$c-------------------------------------------------------
+c$$$
+c$$$ subroutine grad_sc(n,x,nf,g,uiparm,urparm,ufparm)
+c$$$ implicit none
+c$$$
+c$$$c Includes
+c$$$ include 'DIMENSIONS'
+c$$$ include 'COMMON.CHAIN'
+c$$$ include 'COMMON.DERIV'
+c$$$ include 'COMMON.VAR'
+c$$$ include 'COMMON.INTERACT'
+c$$$ include 'COMMON.MINIM'
+c$$$
+c$$$c Input arguments
+c$$$ integer n
+c$$$ double precision x(maxvar)
+c$$$ double precision ufparm
+c$$$ external ufparm
+c$$$
+c$$$c Input/Output arguments
+c$$$ integer nf
+c$$$ integer uiparm(1)
+c$$$ double precision urparm(1)
+c$$$
+c$$$c Output arguments
+c$$$ double precision g(maxvar)
+c$$$
+c$$$c Local variables
+c$$$ double precision f,gphii,gthetai,galphai,gomegai
+c$$$ integer ig,ind,i,j,k,igall,ij
+c$$$
+c$$$
+c$$$ icg=mod(nf,2)+1
+c$$$ if (nf-nfl+1) 20,30,40
+c$$$ 20 call func_sc(n,x,nf,f,uiparm,urparm,ufparm)
+c$$$c write (iout,*) 'grad 20'
+c$$$ if (nf.eq.0) return
+c$$$ goto 40
+c$$$ 30 call var_to_geom_restr(n,x)
+c$$$ call chainbuild_sc
+c$$$C
+c$$$C Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
+c$$$C
+c$$$ 40 call cartder
+c$$$C
+c$$$C Convert the Cartesian gradient into internal-coordinate gradient.
+c$$$C
+c$$$
+c$$$ ig=0
+c$$$ ind=nres-2
+c$$$ do i=2,nres-2
+c$$$ IF (mask_phi(i+2).eq.1) THEN
+c$$$ gphii=0.0D0
+c$$$ do j=i+1,nres-1
+c$$$ ind=ind+1
+c$$$ do k=1,3
+c$$$ gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
+c$$$ gphii=gphii+dxdv(k+3,ind)*gradx(k,j,icg)
+c$$$ enddo
+c$$$ enddo
+c$$$ ig=ig+1
+c$$$ g(ig)=gphii
+c$$$ ELSE
+c$$$ ind=ind+nres-1-i
+c$$$ ENDIF
+c$$$ enddo
+c$$$
+c$$$
+c$$$ ind=0
+c$$$ do i=1,nres-2
+c$$$ IF (mask_theta(i+2).eq.1) THEN
+c$$$ ig=ig+1
+c$$$ gthetai=0.0D0
+c$$$ do j=i+1,nres-1
+c$$$ ind=ind+1
+c$$$ do k=1,3
+c$$$ gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
+c$$$ gthetai=gthetai+dxdv(k,ind)*gradx(k,j,icg)
+c$$$ enddo
+c$$$ enddo
+c$$$ g(ig)=gthetai
+c$$$ ELSE
+c$$$ ind=ind+nres-1-i
+c$$$ ENDIF
+c$$$ enddo
+c$$$
+c$$$ do i=2,nres-1
+c$$$ if (itype(i).ne.10) then
+c$$$ IF (mask_side(i).eq.1) THEN
+c$$$ ig=ig+1
+c$$$ galphai=0.0D0
+c$$$ do k=1,3
+c$$$ galphai=galphai+dxds(k,i)*gradx(k,i,icg)
+c$$$ enddo
+c$$$ g(ig)=galphai
+c$$$ ENDIF
+c$$$ endif
+c$$$ enddo
+c$$$
+c$$$
+c$$$ do i=2,nres-1
+c$$$ if (itype(i).ne.10) then
+c$$$ IF (mask_side(i).eq.1) THEN
+c$$$ ig=ig+1
+c$$$ gomegai=0.0D0
+c$$$ do k=1,3
+c$$$ gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
+c$$$ enddo
+c$$$ g(ig)=gomegai
+c$$$ ENDIF
+c$$$ endif
+c$$$ enddo
+c$$$
+c$$$C
+c$$$C Add the components corresponding to local energy terms.
+c$$$C
+c$$$
+c$$$ ig=0
+c$$$ igall=0
+c$$$ do i=4,nres
+c$$$ igall=igall+1
+c$$$ if (mask_phi(i).eq.1) then
+c$$$ ig=ig+1
+c$$$ g(ig)=g(ig)+gloc(igall,icg)
+c$$$ endif
+c$$$ enddo
+c$$$
+c$$$ do i=3,nres
+c$$$ igall=igall+1
+c$$$ if (mask_theta(i).eq.1) then
+c$$$ ig=ig+1
+c$$$ g(ig)=g(ig)+gloc(igall,icg)
+c$$$ endif
+c$$$ enddo
+c$$$
+c$$$ do ij=1,2
+c$$$ do i=2,nres-1
+c$$$ if (itype(i).ne.10) then
+c$$$ igall=igall+1
+c$$$ if (mask_side(i).eq.1) then
+c$$$ ig=ig+1
+c$$$ g(ig)=g(ig)+gloc(igall,icg)
+c$$$ endif
+c$$$ endif
+c$$$ enddo
+c$$$ enddo
+c$$$
+c$$$cd do i=1,ig
+c$$$cd write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i)
+c$$$cd enddo
+c$$$
+c$$$ return
+c$$$ end
+c$$$
+c$$$C-----------------------------------------------------------------------------
+c$$$
+c$$$ subroutine etotal_sc(energy_sc)
+c$$$ implicit none
+c$$$
+c$$$c Includes
+c$$$ include 'DIMENSIONS'
+c$$$ include 'COMMON.VAR'
+c$$$ include 'COMMON.INTERACT'
+c$$$ include 'COMMON.DERIV'
+c$$$ include 'COMMON.FFIELD'
+c$$$
+c$$$c Output arguments
+c$$$ double precision energy_sc(0:n_ene)
+c$$$
+c$$$c Local variables
+c$$$ double precision evdw,escloc
+c$$$ integer i,j
+c$$$
+c$$$
+c$$$ do i=1,n_ene
+c$$$ energy_sc(i)=0.0D0
+c$$$ enddo
+c$$$
+c$$$ if (mask_r) then
+c$$$ call egb_sc(evdw)
+c$$$ call esc_sc(escloc)
+c$$$ else
+c$$$ call egb(evdw)
+c$$$ call esc(escloc)
+c$$$ endif
+c$$$
+c$$$ if (evdw.eq.1.0D20) then
+c$$$ energy_sc(0)=evdw
+c$$$ else
+c$$$ energy_sc(0)=wsc*evdw+wscloc*escloc
+c$$$ endif
+c$$$ energy_sc(1)=evdw
+c$$$ energy_sc(12)=escloc
+c$$$
+c$$$C
+c$$$C Sum up the components of the Cartesian gradient.
+c$$$C
+c$$$ do i=1,nct
+c$$$ do j=1,3
+c$$$ gradx(j,i,icg)=wsc*gvdwx(j,i)
+c$$$ enddo
+c$$$ enddo
+c$$$
+c$$$ return
+c$$$ end
+c$$$
+c$$$C-----------------------------------------------------------------------------
+c$$$
+c$$$ subroutine egb_sc(evdw)
+c$$$C
+c$$$C This subroutine calculates the interaction energy of nonbonded side chains
+c$$$C assuming the Gay-Berne potential of interaction.
+c$$$C
+c$$$ implicit real*8 (a-h,o-z)
+c$$$ include 'DIMENSIONS'
+c$$$ include 'COMMON.GEO'
+c$$$ include 'COMMON.VAR'
+c$$$ include 'COMMON.LOCAL'
+c$$$ include 'COMMON.CHAIN'
+c$$$ include 'COMMON.DERIV'
+c$$$ include 'COMMON.NAMES'
+c$$$ include 'COMMON.INTERACT'
+c$$$ include 'COMMON.IOUNITS'
+c$$$ include 'COMMON.CALC'
+c$$$ include 'COMMON.CONTROL'
+c$$$ logical lprn
+c$$$ evdw=0.0D0
+c$$$ energy_dec=.false.
+c$$$c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
+c$$$ evdw=0.0D0
+c$$$ lprn=.false.
+c$$$c if (icall.eq.0) lprn=.false.
+c$$$ ind=0
+c$$$ do i=iatsc_s,iatsc_e
+c$$$ itypi=itype(i)
+c$$$ itypi1=itype(i+1)
+c$$$ xi=c(1,nres+i)
+c$$$ yi=c(2,nres+i)
+c$$$ zi=c(3,nres+i)
+c$$$ dxi=dc_norm(1,nres+i)
+c$$$ dyi=dc_norm(2,nres+i)
+c$$$ dzi=dc_norm(3,nres+i)
+c$$$c dsci_inv=dsc_inv(itypi)
+c$$$ dsci_inv=vbld_inv(i+nres)
+c$$$c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
+c$$$c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
+c$$$C
+c$$$C Calculate SC interaction energy.
+c$$$C
+c$$$ do iint=1,nint_gr(i)
+c$$$ do j=istart(i,iint),iend(i,iint)
+c$$$ IF (mask_side(j).eq.1.or.mask_side(i).eq.1) THEN
+c$$$ ind=ind+1
+c$$$ itypj=itype(j)
+c$$$c dscj_inv=dsc_inv(itypj)
+c$$$ dscj_inv=vbld_inv(j+nres)
+c$$$c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
+c$$$c & 1.0d0/vbld(j+nres)
+c$$$c write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
+c$$$ sig0ij=sigma(itypi,itypj)
+c$$$ chi1=chi(itypi,itypj)
+c$$$ chi2=chi(itypj,itypi)
+c$$$ chi12=chi1*chi2
+c$$$ chip1=chip(itypi)
+c$$$ chip2=chip(itypj)
+c$$$ chip12=chip1*chip2
+c$$$ alf1=alp(itypi)
+c$$$ alf2=alp(itypj)
+c$$$ alf12=0.5D0*(alf1+alf2)
+c$$$C For diagnostics only!!!
+c$$$c chi1=0.0D0
+c$$$c chi2=0.0D0
+c$$$c chi12=0.0D0
+c$$$c chip1=0.0D0
+c$$$c chip2=0.0D0
+c$$$c chip12=0.0D0
+c$$$c alf1=0.0D0
+c$$$c alf2=0.0D0
+c$$$c alf12=0.0D0
+c$$$ xj=c(1,nres+j)-xi
+c$$$ yj=c(2,nres+j)-yi
+c$$$ zj=c(3,nres+j)-zi
+c$$$ dxj=dc_norm(1,nres+j)
+c$$$ dyj=dc_norm(2,nres+j)
+c$$$ dzj=dc_norm(3,nres+j)
+c$$$c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
+c$$$c write (iout,*) "j",j," dc_norm",
+c$$$c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
+c$$$ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
+c$$$ rij=dsqrt(rrij)
+c$$$C Calculate angle-dependent terms of energy and contributions to their
+c$$$C derivatives.
+c$$$ call sc_angular
+c$$$ sigsq=1.0D0/sigsq
+c$$$ sig=sig0ij*dsqrt(sigsq)
+c$$$ rij_shift=1.0D0/rij-sig+sig0ij
+c$$$c for diagnostics; uncomment
+c$$$c rij_shift=1.2*sig0ij
+c$$$C I hate to put IF's in the loops, but here don't have another choice!!!!
+c$$$ if (rij_shift.le.0.0D0) then
+c$$$ evdw=1.0D20
+c$$$cd write (iout,'(2(a3,i3,2x),17(0pf7.3))')
+c$$$cd & restyp(itypi),i,restyp(itypj),j,
+c$$$cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
+c$$$ return
+c$$$ endif
+c$$$ sigder=-sig*sigsq
+c$$$c---------------------------------------------------------------
+c$$$ rij_shift=1.0D0/rij_shift
+c$$$ fac=rij_shift**expon
+c$$$ e1=fac*fac*aa(itypi,itypj)
+c$$$ e2=fac*bb(itypi,itypj)
+c$$$ evdwij=eps1*eps2rt*eps3rt*(e1+e2)
+c$$$ eps2der=evdwij*eps3rt
+c$$$ eps3der=evdwij*eps2rt
+c$$$c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
+c$$$c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
+c$$$ evdwij=evdwij*eps2rt*eps3rt
+c$$$ evdw=evdw+evdwij
+c$$$ if (lprn) then
+c$$$ sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
+c$$$ epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
+c$$$ write (iout,'(2(a3,i3,2x),17(0pf7.3))')
+c$$$ & restyp(itypi),i,restyp(itypj),j,
+c$$$ & epsi,sigm,chi1,chi2,chip1,chip2,
+c$$$ & eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
+c$$$ & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
+c$$$ & evdwij
+c$$$ endif
+c$$$
+c$$$ if (energy_dec) write (iout,'(a6,2i,0pf7.3)')
+c$$$ & 'evdw',i,j,evdwij
+c$$$
+c$$$C Calculate gradient components.
+c$$$ e1=e1*eps1*eps2rt**2*eps3rt**2
+c$$$ fac=-expon*(e1+evdwij)*rij_shift
+c$$$ sigder=fac*sigder
+c$$$ fac=rij*fac
+c$$$c fac=0.0d0
+c$$$C Calculate the radial part of the gradient
+c$$$ gg(1)=xj*fac
+c$$$ gg(2)=yj*fac
+c$$$ gg(3)=zj*fac
+c$$$C Calculate angular part of the gradient.
+c$$$ call sc_grad
+c$$$ ENDIF
+c$$$ enddo ! j
+c$$$ enddo ! iint
+c$$$ enddo ! i
+c$$$ energy_dec=.false.
+c$$$ return
+c$$$ end
+c$$$
+c$$$c-----------------------------------------------------------------------------
+c$$$
+c$$$ subroutine esc_sc(escloc)
+c$$$C Calculate the local energy of a side chain and its derivatives in the
+c$$$C corresponding virtual-bond valence angles THETA and the spherical angles
+c$$$C ALPHA and OMEGA.
+c$$$ implicit real*8 (a-h,o-z)
+c$$$ include 'DIMENSIONS'
+c$$$ include 'COMMON.GEO'
+c$$$ include 'COMMON.LOCAL'
+c$$$ include 'COMMON.VAR'
+c$$$ include 'COMMON.INTERACT'
+c$$$ include 'COMMON.DERIV'
+c$$$ include 'COMMON.CHAIN'
+c$$$ include 'COMMON.IOUNITS'
+c$$$ include 'COMMON.NAMES'
+c$$$ include 'COMMON.FFIELD'
+c$$$ include 'COMMON.CONTROL'
+c$$$ double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
+c$$$ & ddersc0(3),ddummy(3),xtemp(3),temp(3)
+c$$$ common /sccalc/ time11,time12,time112,theti,it,nlobit
+c$$$ delta=0.02d0*pi
+c$$$ escloc=0.0D0
+c$$$c write (iout,'(a)') 'ESC'
+c$$$ do i=loc_start,loc_end
+c$$$ IF (mask_side(i).eq.1) THEN
+c$$$ it=itype(i)
+c$$$ if (it.eq.10) goto 1
+c$$$ nlobit=nlob(it)
+c$$$c print *,'i=',i,' it=',it,' nlobit=',nlobit
+c$$$c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
+c$$$ theti=theta(i+1)-pipol
+c$$$ x(1)=dtan(theti)
+c$$$ x(2)=alph(i)
+c$$$ x(3)=omeg(i)
+c$$$
+c$$$ if (x(2).gt.pi-delta) then
+c$$$ xtemp(1)=x(1)
+c$$$ xtemp(2)=pi-delta
+c$$$ xtemp(3)=x(3)
+c$$$ call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
+c$$$ xtemp(2)=pi
+c$$$ call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
+c$$$ call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
+c$$$ & escloci,dersc(2))
+c$$$ call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
+c$$$ & ddersc0(1),dersc(1))
+c$$$ call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
+c$$$ & ddersc0(3),dersc(3))
+c$$$ xtemp(2)=pi-delta
+c$$$ call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
+c$$$ xtemp(2)=pi
+c$$$ call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
+c$$$ call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
+c$$$ & dersc0(2),esclocbi,dersc02)
+c$$$ call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
+c$$$ & dersc12,dersc01)
+c$$$ call splinthet(x(2),0.5d0*delta,ss,ssd)
+c$$$ dersc0(1)=dersc01
+c$$$ dersc0(2)=dersc02
+c$$$ dersc0(3)=0.0d0
+c$$$ do k=1,3
+c$$$ dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
+c$$$ enddo
+c$$$ dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
+c$$$c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
+c$$$c & esclocbi,ss,ssd
+c$$$ escloci=ss*escloci+(1.0d0-ss)*esclocbi
+c$$$c escloci=esclocbi
+c$$$c write (iout,*) escloci
+c$$$ else if (x(2).lt.delta) then
+c$$$ xtemp(1)=x(1)
+c$$$ xtemp(2)=delta
+c$$$ xtemp(3)=x(3)
+c$$$ call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
+c$$$ xtemp(2)=0.0d0
+c$$$ call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
+c$$$ call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
+c$$$ & escloci,dersc(2))
+c$$$ call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
+c$$$ & ddersc0(1),dersc(1))
+c$$$ call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
+c$$$ & ddersc0(3),dersc(3))
+c$$$ xtemp(2)=delta
+c$$$ call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
+c$$$ xtemp(2)=0.0d0
+c$$$ call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
+c$$$ call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
+c$$$ & dersc0(2),esclocbi,dersc02)
+c$$$ call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
+c$$$ & dersc12,dersc01)
+c$$$ dersc0(1)=dersc01
+c$$$ dersc0(2)=dersc02
+c$$$ dersc0(3)=0.0d0
+c$$$ call splinthet(x(2),0.5d0*delta,ss,ssd)
+c$$$ do k=1,3
+c$$$ dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
+c$$$ enddo
+c$$$ dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
+c$$$c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
+c$$$c & esclocbi,ss,ssd
+c$$$ escloci=ss*escloci+(1.0d0-ss)*esclocbi
+c$$$c write (iout,*) escloci
+c$$$ else
+c$$$ call enesc(x,escloci,dersc,ddummy,.false.)
+c$$$ endif
+c$$$
+c$$$ escloc=escloc+escloci
+c$$$ if (energy_dec) write (iout,'(a6,i,0pf7.3)')
+c$$$ & 'escloc',i,escloci
+c$$$c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
+c$$$
+c$$$ gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
+c$$$ & wscloc*dersc(1)
+c$$$ gloc(ialph(i,1),icg)=wscloc*dersc(2)
+c$$$ gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
+c$$$ 1 continue
+c$$$ ENDIF
+c$$$ enddo
+c$$$ return
+c$$$ end
+c$$$
+c$$$C-----------------------------------------------------------------------------
+c$$$
+c$$$ subroutine egb_ij(i_sc,j_sc,evdw)
+c$$$C
+c$$$C This subroutine calculates the interaction energy of nonbonded side chains
+c$$$C assuming the Gay-Berne potential of interaction.
+c$$$C
+c$$$ implicit real*8 (a-h,o-z)
+c$$$ include 'DIMENSIONS'
+c$$$ include 'COMMON.GEO'
+c$$$ include 'COMMON.VAR'
+c$$$ include 'COMMON.LOCAL'
+c$$$ include 'COMMON.CHAIN'
+c$$$ include 'COMMON.DERIV'
+c$$$ include 'COMMON.NAMES'
+c$$$ include 'COMMON.INTERACT'
+c$$$ include 'COMMON.IOUNITS'
+c$$$ include 'COMMON.CALC'
+c$$$ include 'COMMON.CONTROL'
+c$$$ logical lprn
+c$$$ evdw=0.0D0
+c$$$ energy_dec=.false.
+c$$$c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
+c$$$ evdw=0.0D0
+c$$$ lprn=.false.
+c$$$ ind=0
+c$$$c$$$ do i=iatsc_s,iatsc_e
+c$$$ i=i_sc
+c$$$ itypi=itype(i)
+c$$$ itypi1=itype(i+1)
+c$$$ xi=c(1,nres+i)
+c$$$ yi=c(2,nres+i)
+c$$$ zi=c(3,nres+i)
+c$$$ dxi=dc_norm(1,nres+i)
+c$$$ dyi=dc_norm(2,nres+i)
+c$$$ dzi=dc_norm(3,nres+i)
+c$$$c dsci_inv=dsc_inv(itypi)
+c$$$ dsci_inv=vbld_inv(i+nres)
+c$$$c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
+c$$$c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
+c$$$C
+c$$$C Calculate SC interaction energy.
+c$$$C
+c$$$c$$$ do iint=1,nint_gr(i)
+c$$$c$$$ do j=istart(i,iint),iend(i,iint)
+c$$$ j=j_sc
+c$$$ ind=ind+1
+c$$$ itypj=itype(j)
+c$$$c dscj_inv=dsc_inv(itypj)
+c$$$ dscj_inv=vbld_inv(j+nres)
+c$$$c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
+c$$$c & 1.0d0/vbld(j+nres)
+c$$$c write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
+c$$$ sig0ij=sigma(itypi,itypj)
+c$$$ chi1=chi(itypi,itypj)
+c$$$ chi2=chi(itypj,itypi)
+c$$$ chi12=chi1*chi2
+c$$$ chip1=chip(itypi)
+c$$$ chip2=chip(itypj)
+c$$$ chip12=chip1*chip2
+c$$$ alf1=alp(itypi)
+c$$$ alf2=alp(itypj)
+c$$$ alf12=0.5D0*(alf1+alf2)
+c$$$C For diagnostics only!!!
+c$$$c chi1=0.0D0
+c$$$c chi2=0.0D0
+c$$$c chi12=0.0D0
+c$$$c chip1=0.0D0
+c$$$c chip2=0.0D0
+c$$$c chip12=0.0D0
+c$$$c alf1=0.0D0
+c$$$c alf2=0.0D0
+c$$$c alf12=0.0D0
+c$$$ xj=c(1,nres+j)-xi
+c$$$ yj=c(2,nres+j)-yi
+c$$$ zj=c(3,nres+j)-zi
+c$$$ dxj=dc_norm(1,nres+j)
+c$$$ dyj=dc_norm(2,nres+j)
+c$$$ dzj=dc_norm(3,nres+j)
+c$$$c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
+c$$$c write (iout,*) "j",j," dc_norm",
+c$$$c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
+c$$$ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
+c$$$ rij=dsqrt(rrij)
+c$$$C Calculate angle-dependent terms of energy and contributions to their
+c$$$C derivatives.
+c$$$ call sc_angular
+c$$$ sigsq=1.0D0/sigsq
+c$$$ sig=sig0ij*dsqrt(sigsq)
+c$$$ rij_shift=1.0D0/rij-sig+sig0ij
+c$$$c for diagnostics; uncomment
+c$$$c rij_shift=1.2*sig0ij
+c$$$C I hate to put IF's in the loops, but here don't have another choice!!!!
+c$$$ if (rij_shift.le.0.0D0) then
+c$$$ evdw=1.0D20
+c$$$cd write (iout,'(2(a3,i3,2x),17(0pf7.3))')
+c$$$cd & restyp(itypi),i,restyp(itypj),j,
+c$$$cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
+c$$$ return
+c$$$ endif
+c$$$ sigder=-sig*sigsq
+c$$$c---------------------------------------------------------------
+c$$$ rij_shift=1.0D0/rij_shift
+c$$$ fac=rij_shift**expon
+c$$$ e1=fac*fac*aa(itypi,itypj)
+c$$$ e2=fac*bb(itypi,itypj)
+c$$$ evdwij=eps1*eps2rt*eps3rt*(e1+e2)
+c$$$ eps2der=evdwij*eps3rt
+c$$$ eps3der=evdwij*eps2rt
+c$$$c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
+c$$$c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
+c$$$ evdwij=evdwij*eps2rt*eps3rt
+c$$$ evdw=evdw+evdwij
+c$$$ if (lprn) then
+c$$$ sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
+c$$$ epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
+c$$$ write (iout,'(2(a3,i3,2x),17(0pf7.3))')
+c$$$ & restyp(itypi),i,restyp(itypj),j,
+c$$$ & epsi,sigm,chi1,chi2,chip1,chip2,
+c$$$ & eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
+c$$$ & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
+c$$$ & evdwij
+c$$$ endif
+c$$$
+c$$$ if (energy_dec) write (iout,'(a6,2i,0pf7.3)')
+c$$$ & 'evdw',i,j,evdwij
+c$$$
+c$$$C Calculate gradient components.
+c$$$ e1=e1*eps1*eps2rt**2*eps3rt**2
+c$$$ fac=-expon*(e1+evdwij)*rij_shift
+c$$$ sigder=fac*sigder
+c$$$ fac=rij*fac
+c$$$c fac=0.0d0
+c$$$C Calculate the radial part of the gradient
+c$$$ gg(1)=xj*fac
+c$$$ gg(2)=yj*fac
+c$$$ gg(3)=zj*fac
+c$$$C Calculate angular part of the gradient.
+c$$$ call sc_grad
+c$$$c$$$ enddo ! j
+c$$$c$$$ enddo ! iint
+c$$$c$$$ enddo ! i
+c$$$ energy_dec=.false.
+c$$$ return
+c$$$ end
+c$$$
+c$$$C-----------------------------------------------------------------------------
+c$$$
+c$$$ subroutine perturb_side_chain(i,angle)
+c$$$ implicit none
+c$$$
+c$$$c Includes
+c$$$ include 'DIMENSIONS'
+c$$$ include 'COMMON.CHAIN'
+c$$$ include 'COMMON.GEO'
+c$$$ include 'COMMON.VAR'
+c$$$ include 'COMMON.LOCAL'
+c$$$ include 'COMMON.IOUNITS'
+c$$$
+c$$$c External functions
+c$$$ external ran_number
+c$$$ double precision ran_number
+c$$$
+c$$$c Input arguments
+c$$$ integer i
+c$$$ double precision angle ! In degrees
+c$$$
+c$$$c Local variables
+c$$$ integer i_sc
+c$$$ double precision rad_ang,rand_v(3),length,cost,sint
+c$$$
+c$$$
+c$$$ i_sc=i+nres
+c$$$ rad_ang=angle*deg2rad
+c$$$
+c$$$ length=0.0
+c$$$ do while (length.lt.0.01)
+c$$$ rand_v(1)=ran_number(0.01D0,1.0D0)
+c$$$ rand_v(2)=ran_number(0.01D0,1.0D0)
+c$$$ rand_v(3)=ran_number(0.01D0,1.0D0)
+c$$$ length=rand_v(1)*rand_v(1)+rand_v(2)*rand_v(2)+
+c$$$ + rand_v(3)*rand_v(3)
+c$$$ length=sqrt(length)
+c$$$ rand_v(1)=rand_v(1)/length
+c$$$ rand_v(2)=rand_v(2)/length
+c$$$ rand_v(3)=rand_v(3)/length
+c$$$ cost=rand_v(1)*dc_norm(1,i_sc)+rand_v(2)*dc_norm(2,i_sc)+
+c$$$ + rand_v(3)*dc_norm(3,i_sc)
+c$$$ length=1.0D0-cost*cost
+c$$$ if (length.lt.0.0D0) length=0.0D0
+c$$$ length=sqrt(length)
+c$$$ rand_v(1)=rand_v(1)-cost*dc_norm(1,i_sc)
+c$$$ rand_v(2)=rand_v(2)-cost*dc_norm(2,i_sc)
+c$$$ rand_v(3)=rand_v(3)-cost*dc_norm(3,i_sc)
+c$$$ enddo
+c$$$ rand_v(1)=rand_v(1)/length
+c$$$ rand_v(2)=rand_v(2)/length
+c$$$ rand_v(3)=rand_v(3)/length
+c$$$
+c$$$ cost=dcos(rad_ang)
+c$$$ sint=dsin(rad_ang)
+c$$$ dc(1,i_sc)=vbld(i_sc)*(dc_norm(1,i_sc)*cost+rand_v(1)*sint)
+c$$$ dc(2,i_sc)=vbld(i_sc)*(dc_norm(2,i_sc)*cost+rand_v(2)*sint)
+c$$$ dc(3,i_sc)=vbld(i_sc)*(dc_norm(3,i_sc)*cost+rand_v(3)*sint)
+c$$$ dc_norm(1,i_sc)=dc(1,i_sc)*vbld_inv(i_sc)
+c$$$ dc_norm(2,i_sc)=dc(2,i_sc)*vbld_inv(i_sc)
+c$$$ dc_norm(3,i_sc)=dc(3,i_sc)*vbld_inv(i_sc)
+c$$$ c(1,i_sc)=c(1,i)+dc(1,i_sc)
+c$$$ c(2,i_sc)=c(2,i)+dc(2,i_sc)
+c$$$ c(3,i_sc)=c(3,i)+dc(3,i_sc)
+c$$$
+c$$$ call chainbuild_cart
+c$$$
+c$$$ return
+c$$$ end
+c$$$
+c$$$c----------------------------------------------------------------------------
+c$$$
+c$$$ subroutine ss_relax3(i_in,j_in)
+c$$$ implicit none
+c$$$
+c$$$c Includes
+c$$$ include 'DIMENSIONS'
+c$$$ include 'COMMON.VAR'
+c$$$ include 'COMMON.CHAIN'
+c$$$ include 'COMMON.IOUNITS'
+c$$$ include 'COMMON.INTERACT'
+c$$$
+c$$$c External functions
+c$$$ external ran_number
+c$$$ double precision ran_number
+c$$$
+c$$$c Input arguments
+c$$$ integer i_in,j_in
+c$$$
+c$$$c Local variables
+c$$$ double precision energy_sc(0:n_ene),etot
+c$$$ double precision org_dc(3),org_dc_norm(3),org_c(3)
+c$$$ double precision ang_pert,rand_fact,exp_fact,beta
+c$$$ integer n,i_pert,i
+c$$$ logical notdone
+c$$$
+c$$$
+c$$$ beta=1.0D0
+c$$$
+c$$$ mask_r=.true.
+c$$$ do i=nnt,nct
+c$$$ mask_side(i)=0
+c$$$ enddo
+c$$$ mask_side(i_in)=1
+c$$$ mask_side(j_in)=1
+c$$$
+c$$$ call etotal_sc(energy_sc)
+c$$$ etot=energy_sc(0)
+c$$$c write(iout,'(a,3d15.5)')" SS_MC_START ",energy_sc(0),
+c$$$c + energy_sc(1),energy_sc(12)
+c$$$
+c$$$ notdone=.true.
+c$$$ n=0
+c$$$ do while (notdone)
+c$$$ if (mod(n,2).eq.0) then
+c$$$ i_pert=i_in
+c$$$ else
+c$$$ i_pert=j_in
+c$$$ endif
+c$$$ n=n+1
+c$$$
+c$$$ do i=1,3
+c$$$ org_dc(i)=dc(i,i_pert+nres)
+c$$$ org_dc_norm(i)=dc_norm(i,i_pert+nres)
+c$$$ org_c(i)=c(i,i_pert+nres)
+c$$$ enddo
+c$$$ ang_pert=ran_number(0.0D0,3.0D0)
+c$$$ call perturb_side_chain(i_pert,ang_pert)
+c$$$ call etotal_sc(energy_sc)
+c$$$ exp_fact=exp(beta*(etot-energy_sc(0)))
+c$$$ rand_fact=ran_number(0.0D0,1.0D0)
+c$$$ if (rand_fact.lt.exp_fact) then
+c$$$c write(iout,'(a,3d15.5)')" SS_MC_ACCEPT ",energy_sc(0),
+c$$$c + energy_sc(1),energy_sc(12)
+c$$$ etot=energy_sc(0)
+c$$$ else
+c$$$c write(iout,'(a,3d15.5)')" SS_MC_REJECT ",energy_sc(0),
+c$$$c + energy_sc(1),energy_sc(12)
+c$$$ do i=1,3
+c$$$ dc(i,i_pert+nres)=org_dc(i)
+c$$$ dc_norm(i,i_pert+nres)=org_dc_norm(i)
+c$$$ c(i,i_pert+nres)=org_c(i)
+c$$$ enddo
+c$$$ endif
+c$$$
+c$$$ if (n.eq.10000.or.etot.lt.30.0D0) notdone=.false.
+c$$$ enddo
+c$$$
+c$$$ mask_r=.false.
+c$$$
+c$$$ return
+c$$$ end
+c$$$
+c$$$c----------------------------------------------------------------------------
+c$$$
+c$$$ subroutine ss_relax2(etot,iretcode,nfun,i_in,j_in)
+c$$$ implicit none
+c$$$ include 'DIMENSIONS'
+c$$$ integer liv,lv
+c$$$ parameter (liv=60,lv=(77+maxres6*(maxres6+17)/2))
+c$$$*********************************************************************
+c$$$* OPTIMIZE sets up SUMSL or DFP and provides a simple interface for *
+c$$$* the calling subprogram. *
+c$$$* when d(i)=1.0, then v(35) is the length of the initial step, *
+c$$$* calculated in the usual pythagorean way. *
+c$$$* absolute convergence occurs when the function is within v(31) of *
+c$$$* zero. unless you know the minimum value in advance, abs convg *
+c$$$* is probably not useful. *
+c$$$* relative convergence is when the model predicts that the function *
+c$$$* will decrease by less than v(32)*abs(fun). *
+c$$$*********************************************************************
+c$$$ include 'COMMON.IOUNITS'
+c$$$ include 'COMMON.VAR'
+c$$$ include 'COMMON.GEO'
+c$$$ include 'COMMON.MINIM'
+c$$$ include 'COMMON.CHAIN'
+c$$$
+c$$$ double precision orig_ss_dc,orig_ss_var,orig_ss_dist
+c$$$ common /orig_ss/ orig_ss_dc(3,0:maxres2),orig_ss_var(maxvar),
+c$$$ + orig_ss_dist(maxres2,maxres2)
+c$$$
+c$$$ double precision etot
+c$$$ integer iretcode,nfun,i_in,j_in
+c$$$
+c$$$ external dist
+c$$$ double precision dist
+c$$$ external ss_func,fdum
+c$$$ double precision ss_func,fdum
+c$$$
+c$$$ integer iv(liv),uiparm(2)
+c$$$ double precision v(lv),x(maxres6),d(maxres6),rdum
+c$$$ integer i,j,k
+c$$$
+c$$$
+c$$$ call deflt(2,iv,liv,lv,v)
+c$$$* 12 means fresh start, dont call deflt
+c$$$ iv(1)=12
+c$$$* max num of fun calls
+c$$$ if (maxfun.eq.0) maxfun=500
+c$$$ iv(17)=maxfun
+c$$$* max num of iterations
+c$$$ if (maxmin.eq.0) maxmin=1000
+c$$$ iv(18)=maxmin
+c$$$* controls output
+c$$$ iv(19)=2
+c$$$* selects output unit
+c$$$c iv(21)=iout
+c$$$ iv(21)=0
+c$$$* 1 means to print out result
+c$$$ iv(22)=0
+c$$$* 1 means to print out summary stats
+c$$$ iv(23)=0
+c$$$* 1 means to print initial x and d
+c$$$ iv(24)=0
+c$$$* min val for v(radfac) default is 0.1
+c$$$ v(24)=0.1D0
+c$$$* max val for v(radfac) default is 4.0
+c$$$ v(25)=2.0D0
+c$$$c v(25)=4.0D0
+c$$$* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease)
+c$$$* the sumsl default is 0.1
+c$$$ v(26)=0.1D0
+c$$$* false conv if (act fnctn decrease) .lt. v(34)
+c$$$* the sumsl default is 100*machep
+c$$$ v(34)=v(34)/100.0D0
+c$$$* absolute convergence
+c$$$ if (tolf.eq.0.0D0) tolf=1.0D-4
+c$$$ v(31)=tolf
+c$$$ v(31)=1.0D-1
+c$$$* relative convergence
+c$$$ if (rtolf.eq.0.0D0) rtolf=1.0D-4
+c$$$ v(32)=rtolf
+c$$$ v(32)=1.0D-1
+c$$$* controls initial step size
+c$$$ v(35)=1.0D-1
+c$$$* large vals of d correspond to small components of step
+c$$$ do i=1,6*nres
+c$$$ d(i)=1.0D0
+c$$$ enddo
+c$$$
+c$$$ do i=0,2*nres
+c$$$ do j=1,3
+c$$$ orig_ss_dc(j,i)=dc(j,i)
+c$$$ enddo
+c$$$ enddo
+c$$$ call geom_to_var(nvar,orig_ss_var)
+c$$$
+c$$$ do i=1,nres
+c$$$ do j=i,nres
+c$$$ orig_ss_dist(j,i)=dist(j,i)
+c$$$ orig_ss_dist(j+nres,i)=dist(j+nres,i)
+c$$$ orig_ss_dist(j,i+nres)=dist(j,i+nres)
+c$$$ orig_ss_dist(j+nres,i+nres)=dist(j+nres,i+nres)
+c$$$ enddo
+c$$$ enddo
+c$$$
+c$$$ k=0
+c$$$ do i=1,nres-1
+c$$$ do j=1,3
+c$$$ k=k+1
+c$$$ x(k)=dc(j,i)
+c$$$ enddo
+c$$$ enddo
+c$$$ do i=2,nres-1
+c$$$ if (ialph(i,1).gt.0) then
+c$$$ do j=1,3
+c$$$ k=k+1
+c$$$ x(k)=dc(j,i+nres)
+c$$$ enddo
+c$$$ endif
+c$$$ enddo
+c$$$
+c$$$ uiparm(1)=i_in
+c$$$ uiparm(2)=j_in
+c$$$ call smsno(k,d,x,ss_func,iv,liv,lv,v,uiparm,rdum,fdum)
+c$$$ etot=v(10)
+c$$$ iretcode=iv(1)
+c$$$ nfun=iv(6)+iv(30)
+c$$$
+c$$$ k=0
+c$$$ do i=1,nres-1
+c$$$ do j=1,3
+c$$$ k=k+1
+c$$$ dc(j,i)=x(k)
+c$$$ enddo
+c$$$ enddo
+c$$$ do i=2,nres-1
+c$$$ if (ialph(i,1).gt.0) then
+c$$$ do j=1,3
+c$$$ k=k+1
+c$$$ dc(j,i+nres)=x(k)
+c$$$ enddo
+c$$$ endif
+c$$$ enddo
+c$$$ call chainbuild_cart
+c$$$
+c$$$ return
+c$$$ end
+c$$$
+c$$$C-----------------------------------------------------------------------------
+c$$$
+c$$$ subroutine ss_func(n,x,nf,f,uiparm,urparm,ufparm)
+c$$$ implicit none
+c$$$ include 'DIMENSIONS'
+c$$$ include 'COMMON.DERIV'
+c$$$ include 'COMMON.IOUNITS'
+c$$$ include 'COMMON.VAR'
+c$$$ include 'COMMON.CHAIN'
+c$$$ include 'COMMON.INTERACT'
+c$$$ include 'COMMON.SBRIDGE'
+c$$$
+c$$$ double precision orig_ss_dc,orig_ss_var,orig_ss_dist
+c$$$ common /orig_ss/ orig_ss_dc(3,0:maxres2),orig_ss_var(maxvar),
+c$$$ + orig_ss_dist(maxres2,maxres2)
+c$$$
+c$$$ integer n
+c$$$ double precision x(maxres6)
+c$$$ integer nf
+c$$$ double precision f
+c$$$ integer uiparm(2)
+c$$$ real*8 urparm(1)
+c$$$ external ufparm
+c$$$ double precision ufparm
+c$$$
+c$$$ external dist
+c$$$ double precision dist
+c$$$
+c$$$ integer i,j,k,ss_i,ss_j
+c$$$ double precision tempf,var(maxvar)
+c$$$
+c$$$
+c$$$ ss_i=uiparm(1)
+c$$$ ss_j=uiparm(2)
+c$$$ f=0.0D0
+c$$$
+c$$$ k=0
+c$$$ do i=1,nres-1
+c$$$ do j=1,3
+c$$$ k=k+1
+c$$$ dc(j,i)=x(k)
+c$$$ enddo
+c$$$ enddo
+c$$$ do i=2,nres-1
+c$$$ if (ialph(i,1).gt.0) then
+c$$$ do j=1,3
+c$$$ k=k+1
+c$$$ dc(j,i+nres)=x(k)
+c$$$ enddo
+c$$$ endif
+c$$$ enddo
+c$$$ call chainbuild_cart
+c$$$
+c$$$ call geom_to_var(nvar,var)
+c$$$
+c$$$c Constraints on all angles
+c$$$ do i=1,nvar
+c$$$ tempf=var(i)-orig_ss_var(i)
+c$$$ f=f+tempf*tempf
+c$$$ enddo
+c$$$
+c$$$c Constraints on all distances
+c$$$ do i=1,nres-1
+c$$$ if (i.gt.1) then
+c$$$ tempf=dist(i+nres,i)-orig_ss_dist(i+nres,i)
+c$$$ f=f+tempf*tempf
+c$$$ endif
+c$$$ do j=i+1,nres
+c$$$ tempf=dist(j,i)-orig_ss_dist(j,i)
+c$$$ if (tempf.lt.0.0D0 .or. j.eq.i+1) f=f+tempf*tempf
+c$$$ tempf=dist(j+nres,i)-orig_ss_dist(j+nres,i)
+c$$$ if (tempf.lt.0.0D0) f=f+tempf*tempf
+c$$$ tempf=dist(j,i+nres)-orig_ss_dist(j,i+nres)
+c$$$ if (tempf.lt.0.0D0) f=f+tempf*tempf
+c$$$ tempf=dist(j+nres,i+nres)-orig_ss_dist(j+nres,i+nres)
+c$$$ if (tempf.lt.0.0D0) f=f+tempf*tempf
+c$$$ enddo
+c$$$ enddo
+c$$$
+c$$$c Constraints for the relevant CYS-CYS
+c$$$ tempf=dist(nres+ss_i,nres+ss_j)-8.0D0
+c$$$ f=f+tempf*tempf
+c$$$CCCCCCCCCCCCCCCCC ADD SOME ANGULAR STUFF
+c$$$
+c$$$c$$$ if (nf.ne.nfl) then
+c$$$c$$$ write(iout,'(a,i10,2d15.5)')"IN DIST_FUNC (NF,F,DIST)",nf,
+c$$$c$$$ + f,dist(5+nres,14+nres)
+c$$$c$$$ endif
+c$$$
+c$$$ nfl=nf
+c$$$
+c$$$ return
+c$$$ end
+c$$$
+c$$$C-----------------------------------------------------------------------------
+c$$$C-----------------------------------------------------------------------------
+ subroutine triple_ssbond_ene(resi,resj,resk,eij)
+ include 'DIMENSIONS'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.VAR'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CALC'
+#ifndef CLUST
+#ifndef WHAM
+C include 'COMMON.MD'
+#endif
+#endif
+
+c External functions
+ double precision h_base
+ external h_base
+
+c Input arguments
+ integer resi,resj,resk
+
+c Output arguments
+ double precision eij,eij1,eij2,eij3
+
+c Local variables
+ logical havebond
+c integer itypi,itypj,k,l
+ double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
+ double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
+ double precision xik,yik,zik,xjk,yjk,zjk
+ double precision sig0ij,ljd,sig,fac,e1,e2
+ double precision dcosom1(3),dcosom2(3),ed
+ double precision pom1,pom2
+ double precision ljA,ljB,ljXs
+ double precision d_ljB(1:3)
+ double precision ssA,ssB,ssC,ssXs
+ double precision ssxm,ljxm,ssm,ljm
+ double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
+
+ i=resi
+ j=resj
+ k=resk
+C write(iout,*) resi,resj,resk
+ itypi=itype(i)
+ dxi=dc_norm(1,nres+i)
+ dyi=dc_norm(2,nres+i)
+ dzi=dc_norm(3,nres+i)
+ dsci_inv=vbld_inv(i+nres)
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+
+ itypj=itype(j)
+ xj=c(1,nres+j)
+ yj=c(2,nres+j)
+ zj=c(3,nres+j)
+
+ dxj=dc_norm(1,nres+j)
+ dyj=dc_norm(2,nres+j)
+ dzj=dc_norm(3,nres+j)
+ dscj_inv=vbld_inv(j+nres)
+ itypk=itype(k)
+ xk=c(1,nres+k)
+ yk=c(2,nres+k)
+ zk=c(3,nres+k)
+
+ dxk=dc_norm(1,nres+k)
+ dyk=dc_norm(2,nres+k)
+ dzk=dc_norm(3,nres+k)
+ dscj_inv=vbld_inv(k+nres)
+ xij=xj-xi
+ xik=xk-xi
+ xjk=xk-xj
+ yij=yj-yi
+ yik=yk-yi
+ yjk=yk-yj
+ zij=zj-zi
+ zik=zk-zi
+ zjk=zk-zj
+ rrij=(xij*xij+yij*yij+zij*zij)
+ rij=dsqrt(rrij) ! sc_angular needs rij to really be the inverse
+ rrik=(xik*xik+yik*yik+zik*zik)
+ rik=dsqrt(rrik)
+ rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
+ rjk=dsqrt(rrjk)
+C there are three combination of distances for each trisulfide bonds
+C The first case the ith atom is the center
+C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
+C distance y is second distance the a,b,c,d are parameters derived for
+C this problem d parameter was set as a penalty currenlty set to 1.
+ eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**2+ctriss)
+C second case jth atom is center
+ eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**2+ctriss)
+C the third case kth atom is the center
+ eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**2+ctriss)
+C eij2=0.0
+C eij3=0.0
+C eij1=0.0
+ eij=eij1+eij2+eij3
+C write(iout,*)i,j,k,eij
+C The energy penalty calculated now time for the gradient part
+C derivative over rij
+ fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+2.0*btriss*(rij+rik))
+ &-eij2**2/dtriss*(2.0*atriss*(rij-rjk)+2.0*btriss*(rij+rjk))
+ gg(1)=xij*fac/rij
+ gg(2)=yij*fac/rij
+ gg(3)=zij*fac/rij
+ do m=1,3
+ gvdwx(m,i)=gvdwx(m,i)-gg(m)
+ gvdwx(m,j)=gvdwx(m,j)+gg(m)
+ enddo
+ do l=1,3
+ gvdwc(l,i)=gvdwc(l,i)-gg(l)
+ gvdwc(l,j)=gvdwc(l,j)+gg(l)
+ enddo
+C now derivative over rik
+ fac=-eij1**2/dtriss*(-2.0*atriss*(rij-rik)+2.0*btriss*(rij+rik))
+ &-eij3**2/dtriss*(2.0*atriss*(rik-rjk)+2.0*btriss*(rik+rjk))
+ gg(1)=xik*fac/rik
+ gg(2)=yik*fac/rik
+ gg(3)=zik*fac/rik
+ do m=1,3
+ gvdwx(m,i)=gvdwx(m,i)-gg(m)
+ gvdwx(m,k)=gvdwx(m,k)+gg(m)
+ enddo
+ do l=1,3
+ gvdwc(l,i)=gvdwc(l,i)-gg(l)
+ gvdwc(l,k)=gvdwc(l,k)+gg(l)
+ enddo
+C now derivative over rjk
+ fac=-eij2**2/dtriss*(-2.0*atriss*(rij-rjk)+2.0*btriss*(rij+rjk))-
+ &eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+2.0*btriss*(rik+rjk))
+ gg(1)=xjk*fac/rjk
+ gg(2)=yjk*fac/rjk
+ gg(3)=zjk*fac/rjk
+ do m=1,3
+ gvdwx(m,j)=gvdwx(m,j)-gg(m)
+ gvdwx(m,k)=gvdwx(m,k)+gg(m)
+ enddo
+ do l=1,3
+ gvdwc(l,j)=gvdwc(l,j)-gg(l)
+ gvdwc(l,k)=gvdwc(l,k)+gg(l)
+ enddo
+ return
+ end
--- /dev/null
+ 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,ii,j,k,l,m,mm,iparm,ichir1,ichir2,iblock,iii
+
+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
+ ww_all(22,iparm)=wliptran
+ ww_all(26,iparm)=wsaxs
+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=-ntyp,ntyp
+ a0thet_all(i,iparm)=a0thet(i)
+ do ichir1=-1,1
+ do ichir2=-1,1
+ do j=1,2
+ athet_all(j,i,ichir1,ichir2,iparm)=athet(j,i,ichir1,ichir2)
+ bthet_all(j,i,ichir1,ichir2,iparm)=bthet(j,i,ichir1,ichir2)
+ enddo
+ enddo
+ enddo
+ do j=0,3
+ polthet_all(j,i,iparm)=polthet(j,i)
+ 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=-ntyp,ntyp
+ ithetyp_all(i,iparm)=ithetyp(i)
+ enddo
+ do iblock=1,2
+ do i=-maxthetyp1,maxthetyp1
+ do j=-maxthetyp1,maxthetyp1
+ do k=-maxthetyp1,maxthetyp1
+ aa0thet_all(i,j,k,iblock,iparm)=aa0thet(i,j,k,iblock)
+ do l=1,ntheterm
+ aathet_all(l,i,j,k,iblock,iparm)=aathet(l,i,j,k,iblock)
+ enddo
+ do l=1,ntheterm2
+ do m=1,nsingle
+ bbthet_all(m,l,i,j,k,iblock,iparm)=
+ & bbthet(m,l,i,j,k,iblock)
+ ccthet_all(m,l,i,j,k,iblock,iparm)=
+ &ccthet(m,l,i,j,k,iblock)
+ ddthet_all(m,l,i,j,k,iblock,iparm)=
+ &ddthet(m,l,i,j,k,iblock)
+ eethet_all(m,l,i,j,k,iblock,iparm)=
+ &eethet(m,l,i,j,k,iblock)
+ enddo
+ enddo
+ do l=1,ntheterm3
+ do m=1,ndouble
+ do mm=1,ndouble
+ if (iblock.eq.1) then
+ ffthet_all1(mm,m,l,i,j,k,iparm)=
+ & ffthet(mm,m,l,i,j,k,iblock)
+ ggthet_all1(mm,m,l,i,j,k,iparm)=
+ &ggthet(mm,m,l,i,j,k,iblock)
+ else
+ ffthet_all2(mm,m,l,i,j,k,iparm)=
+ & ffthet(mm,m,l,i,j,k,iblock)
+ ggthet_all2(mm,m,l,i,j,k,iparm)=
+ &ggthet(mm,m,l,i,j,k,iblock)
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+#endif
+#ifdef CRYST_SC
+c Store the sidechain rotamer parameters
+ do i=-ntyp,ntyp
+ iii=iabs(i)
+cc write (iout,*) i,"storeparm1"
+ if (i.eq.0) cycle
+ nlob_all(iii,iparm)=nlob(iii)
+ do j=1,nlob(iii)
+ bsc_all(j,iii,iparm)=bsc(j,iii)
+ do k=1,3
+ censc_all(k,j,i,iparm)=censc(k,j,i)
+ enddo
+ 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 iblock=1,2
+ do i=-ntortyp+1,ntortyp-1
+ do j=-ntortyp+1,ntortyp-1
+ v0_all(i,j,iblock,iparm)=v0(i,j,iblock)
+ nterm_all(i,j,iblock,iparm)=nterm(i,j,iblock)
+ nlor_all(i,j,iblock,iparm)=nlor(i,j,iblock)
+ do k=1,nterm(i,j,iblock)
+ v1_all(k,i,j,iblock,iparm)=v1(k,i,j,iblock)
+ v2_all(k,i,j,iblock,iparm)=v2(k,i,j,iblock)
+ enddo
+ do k=1,nlor(i,j,iblock)
+ vlor1_all(k,i,j,iparm)=vlor1(k,i,j)
+ vlor2_all(k,i,j,iparm)=vlor2(k,i,j)
+ vlor3_all(k,i,j,iparm)=vlor3(k,i,j)
+ enddo
+ enddo
+ enddo
+ enddo
+c Store the double torsional parameters
+ do iblock=1,2
+ do i=-ntortyp+1,ntortyp-1
+ do j=-ntortyp+1,ntortyp-1
+ do k=-ntortyp+1,ntortyp-1
+ ntermd1_all(i,j,k,iblock,iparm)=ntermd_1(i,j,k,iblock)
+ ntermd2_all(i,j,k,iblock,iparm)=ntermd_2(i,j,k,iblock)
+ do l=1,ntermd_1(i,j,k,iblock)
+ v1c_all(1,l,i,j,k,iblock,iparm)=v1c(1,l,i,j,k,iblock)
+ v1c_all(2,l,i,j,k,iblock,iparm)=v1c(2,l,i,j,k,iblock)
+ v2c_all(1,l,i,j,k,iblock,iparm)=v2c(1,l,i,j,k,iblock)
+ v2c_all(2,l,i,j,k,iblock,iparm)=v2c(2,l,i,j,k,iblock)
+ enddo
+ do l=1,ntermd_2(i,j,k,iblock)
+ do m=1,ntermd_2(i,j,k,iblock)
+ v2s_all(l,m,i,j,k,iblock,iparm)=v2s(l,m,i,j,k,iblock)
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+c Store parameters of the cumulants
+#ifdef NEWCORR
+ do i=-nloctyp+1,nloctyp-1
+ do ii=1,3
+ do j=1,2
+ bnew1_all(ii,j,i,iparm)=bnew1(ii,j,i)
+ bnew2_all(ii,j,i,iparm)=bnew2(ii,j,i)
+ enddo
+ enddo
+ do j=1,2
+ do k=1,3
+ ccnew_all(k,j,i,iparm)=ccnew(k,j,i)
+ ddnew_all(k,j,i,iparm)=ddnew(k,j,i)
+ enddo
+ enddo
+ do ii=1,2
+ do j=1,2
+ do k=1,2
+ eenew_all(k,j,ii,i,iparm)=eenew(k,j,ii,i)
+ enddo
+ enddo
+ enddo
+ do ii=1,2
+ e0new_all(ii,i,iparm)=e0new(ii,i)
+ enddo
+ enddo
+#else
+ do i=-nloctyp,nloctyp
+ do j=1,5
+ b_all(j,i,iparm)=b(j,i)
+ enddo
+ do j=1,2
+ do k=1,2
+ ccold_all(k,j,i,iparm)=ccold(k,j,i)
+ ddold_all(k,j,i,iparm)=ddold(k,j,i)
+ eeold_all(k,j,i,iparm)=eeold(k,j,i)
+ enddo
+ enddo
+ enddo
+#endif
+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_aq_all(j,i,iparm)=aa_aq(j,i)
+ bb_aq_all(j,i,iparm)=bb_aq(j,i)
+ aa_lip_all(j,i,iparm)=aa_lip(j,i)
+ bb_lip_all(j,i,iparm)=bb_lip(j,i)
+ r0_all(j,i,iparm)=r0(j,i)
+ sigma_all(j,i,iparm)=sigma(j,i)
+ chi_all(j,i,iparm)=chi(j,i)
+ augm_all(j,i,iparm)=augm(j,i)
+ eps_all(j,i,iparm)=eps(j,i)
+ epslip_all(j,i,iparm)=epslip(j,i)
+ enddo
+ enddo
+ do i=1,ntyp
+ 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=-nsccortyp,nsccortyp
+ do j=-nsccortyp,nsccortyp
+
+ nterm_sccor_all(j,i,iparm)=nterm_sccor(j,i)
+c do i=1,20
+c do j=1,20
+ 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,ii,j,k,l,m,mm,iparm,ichir1,ichir2,iblock,iii
+
+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)
+ wliptran=ww_all(22,iparm)
+ wsaxs=ww_all(26,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=-ntyp,ntyp
+ a0thet(i)=a0thet_all(i,iparm)
+ do ichir1=-1,1
+ do ichir2=-1,1
+ do j=1,2
+ athet(j,i,ichir1,ichir2)=athet_all(j,i,ichir1,ichir2,iparm)
+ bthet(j,i,ichir1,ichir2)=bthet_all(j,i,ichir1,ichir2,iparm)
+ enddo
+ enddo
+ enddo
+ do j=0,3
+ polthet(j,i)=polthet_all(j,i,iparm)
+ 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=-ntyp,ntyp
+ ithetyp(i)=ithetyp_all(i,iparm)
+ enddo
+ do iblock=1,2
+ do i=-maxthetyp1,maxthetyp1
+ do j=-maxthetyp1,maxthetyp1
+ do k=-maxthetyp1,maxthetyp1
+ aa0thet(i,j,k,iblock)=aa0thet_all(i,j,k,iblock,iparm)
+ do l=1,ntheterm
+ aathet(l,i,j,k,iblock)=aathet_all(l,i,j,k,iblock,iparm)
+ enddo
+ do l=1,ntheterm2
+ do m=1,nsingle
+ bbthet(m,l,i,j,k,iblock)=
+ &bbthet_all(m,l,i,j,k,iblock,iparm)
+ ccthet(m,l,i,j,k,iblock)=
+ &ccthet_all(m,l,i,j,k,iblock,iparm)
+ ddthet(m,l,i,j,k,iblock)=
+ &ddthet_all(m,l,i,j,k,iblock,iparm)
+ eethet(m,l,i,j,k,iblock)=
+ &eethet_all(m,l,i,j,k,iblock,iparm)
+ enddo
+ enddo
+ do l=1,ntheterm3
+ do m=1,ndouble
+ do mm=1,ndouble
+ if (iblock.eq.1) then
+ ffthet(mm,m,l,i,j,k,iblock)=
+ &ffthet_all1(mm,m,l,i,j,k,iparm)
+ ggthet(mm,m,l,i,j,k,iblock)=
+ &ggthet_all1(mm,m,l,i,j,k,iparm)
+ else
+ ffthet(mm,m,l,i,j,k,iblock)=
+ &ffthet_all2(mm,m,l,i,j,k,iparm)
+ ggthet(mm,m,l,i,j,k,iblock)=
+ &ggthet_all2(mm,m,l,i,j,k,iparm)
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+#endif
+c Restore the sidechain rotamer parameters
+#ifdef CRYST_SC
+ do i=-ntyp,ntyp
+ if (i.eq.0) cycle
+ iii=iabs(i)
+ nlob(iii)=nlob_all(iii,iparm)
+ do j=1,nlob(iii)
+ bsc(j,iii)=bsc_all(j,iii,iparm)
+ do k=1,3
+ censc(k,j,i)=censc_all(k,j,i,iparm)
+ enddo
+ 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 iblock=1,2
+ do i=-ntortyp+1,ntortyp-1
+ do j=-ntortyp+1,ntortyp-1
+ v0(i,j,iblock)=v0_all(i,j,iblock,iparm)
+ nterm(i,j,iblock)=nterm_all(i,j,iblock,iparm)
+ nlor(i,j,iblock)=nlor_all(i,j,iblock,iparm)
+ do k=1,nterm(i,j,iblock)
+ v1(k,i,j,iblock)=v1_all(k,i,j,iblock,iparm)
+ v2(k,i,j,iblock)=v2_all(k,i,j,iblock,iparm)
+ enddo
+ do k=1,nlor(i,j,iblock)
+ vlor1(k,i,j)=vlor1_all(k,i,j,iparm)
+ vlor2(k,i,j)=vlor2_all(k,i,j,iparm)
+ vlor3(k,i,j)=vlor3_all(k,i,j,iparm)
+ enddo
+ enddo
+ enddo
+ enddo
+c Restore the double torsional parameters
+ do iblock=1,2
+ do i=-ntortyp+1,ntortyp-1
+ do j=-ntortyp+1,ntortyp-1
+ do k=-ntortyp+1,ntortyp-1
+ ntermd_1(i,j,k,iblock)=ntermd1_all(i,j,k,iblock,iparm)
+ ntermd_2(i,j,k,iblock)=ntermd2_all(i,j,k,iblock,iparm)
+ do l=1,ntermd_1(i,j,k,iblock)
+ v1c(1,l,i,j,k,iblock)=v1c_all(1,l,i,j,k,iblock,iparm)
+ v1c(2,l,i,j,k,iblock)=v1c_all(2,l,i,j,k,iblock,iparm)
+ v2c(1,l,i,j,k,iblock)=v2c_all(1,l,i,j,k,iblock,iparm)
+ v2c(2,l,i,j,k,iblock)=v2c_all(2,l,i,j,k,iblock,iparm)
+ enddo
+ do l=1,ntermd_2(i,j,k,iblock)
+ do m=1,ntermd_2(i,j,k,iblock)
+ v2s(l,m,i,j,k,iblock)=v2s_all(l,m,i,j,k,iblock,iparm)
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+c Restore parameters of the cumulants
+#ifdef NEWCORR
+ do i=-nloctyp+1,nloctyp-1
+ do ii=1,3
+ do j=1,2
+ bnew1(ii,j,i)=bnew1_all(ii,j,i,iparm)
+ bnew2(ii,j,i)=bnew2_all(ii,j,i,iparm)
+ enddo
+ enddo
+ do j=1,2
+ do k=1,3
+ ccnew(k,j,i)=ccnew_all(k,j,i,iparm)
+ ddnew(k,j,i)=ddnew_all(k,j,i,iparm)
+ enddo
+ enddo
+ do ii=1,2
+ do j=1,2
+ do k=1,2
+ eenew(k,j,ii,i)=eenew_all(k,j,ii,i,iparm)
+ enddo
+ enddo
+ enddo
+ do ii=1,2
+ e0new(ii,i)=e0new_all(ii,i,iparm)
+ enddo
+ enddo
+#else
+ do i=-nloctyp,nloctyp
+ do j=1,5
+ b(j,i)=b_all(j,i,iparm)
+ enddo
+ do j=1,2
+ do k=1,2
+ ccold(k,j,i)=ccold_all(k,j,i,iparm)
+ ddold(k,j,i)=ddold_all(k,j,i,iparm)
+ eeold(k,j,i)=eeold_all(k,j,i,iparm)
+ enddo
+ enddo
+ enddo
+#endif
+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_aq(j,i)=aa_aq_all(j,i,iparm)
+ bb_aq(j,i)=bb_aq_all(j,i,iparm)
+ aa_lip(j,i)=aa_lip_all(j,i,iparm)
+ bb_lip(j,i)=bb_lip_all(j,i,iparm)
+ r0(j,i)=r0_all(j,i,iparm)
+ sigma(j,i)=sigma_all(j,i,iparm)
+ chi(j,i)=chi_all(j,i,iparm)
+ augm(j,i)=augm_all(j,i,iparm)
+ eps(j,i)=eps_all(j,i,iparm)
+ epslip(j,i)=epslip_all(j,i,iparm)
+ enddo
+ enddo
+ do i=1,ntyp
+ 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=-nsccortyp,nsccortyp
+ do j=-nsccortyp,nsccortyp
+
+ nterm_sccor(j,i)=nterm_sccor_all(j,i,iparm)
+ 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
--- /dev/null
+ implicit none
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ integer i,ii,iii,ires
+ integer tperm,iperm
+ iout=6
+ read (*,*) nres,(itype(i),i=1,nres)
+ call seq2chains(nres,itype,nchain,chain_length,chain_border,
+ & ireschain)
+ print *,"nres",nres," nchain",nchain
+ do i=1,nchain
+ print *,"chain",i,chain_length(i),chain_border(1,i),
+ & chain_border(2,i)
+ enddo
+ print *,"ireschain"
+ do i=1,nres
+ print *,i,ireschain(i)
+ enddo
+ call chain_symmetry(nchain,nres,itype,chain_border,
+ & chain_length,npermchain,tabpermchain)
+ print *,"ireschain permutations"
+ do i=1,nres
+ print '(60i4)',i,(tperm(ireschain(i),ii,tabpermchain),
+ & ii=1,npermchain)
+ enddo
+ print *,"residue permutations"
+ do i=1,nres
+ print '(60i4)',i,(iperm(i,ii),ii=1,npermchain)
+ enddo
+ stop
+ end
--- /dev/null
+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'
+#ifdef MP
+ include 'mpif.h'
+#endif
+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. if one of the following reasons to exit SUMSL
+C occurs. The "reason" code is stored in WHATSUP passed thru a COMMON block:
+C
+C... WHATSUP = 0 - go on, no reason to stop. Stopx will return .false.
+C... 1 - Time up in current node;
+C... 2 - STOP signal was received from another node because the
+C... node's task was accomplished (parallel only);
+C... -1 - STOP signal was received from another node because of error;
+C... -2 - STOP signal was received from another node, because
+C... the node's time was up.
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ integer nf
+ logical ovrtim
+#ifdef MP
+ include 'mpif.h'
+ include 'COMMON.INFO'
+#endif
+ include 'COMMON.IOUNITS'
+ include 'COMMON.TIME1'
+ integer Kwita
+
+cd print *,'Processor',MyID,' NF=',nf
+#ifndef MPI
+ if (ovrtim()) then
+C Finish if time is up.
+ stopx = .true.
+ WhatsUp=1
+#ifdef MPL
+ else if (mod(nf,100).eq.0) then
+C Other processors might have finished. Check this every 100th function
+C evaluation.
+C Master checks if any other processor has sent accepted conformation(s) to it.
+ if (MyID.ne.MasterID) call receive_mcm_info
+ if (MyID.eq.MasterID) call receive_conf
+cd print *,'Processor ',MyID,' is checking STOP: nf=',nf
+ call recv_stop_sig(Kwita)
+ if (Kwita.eq.-1) then
+ write (iout,'(a,i4,a,i5)') 'Processor',
+ & MyID,' has received STOP signal in STOPX; NF=',nf
+ write (*,'(a,i4,a,i5)') 'Processor',
+ & MyID,' has received STOP signal in STOPX; NF=',nf
+ stopx=.true.
+ WhatsUp=2
+ elseif (Kwita.eq.-2) then
+ write (iout,*)
+ & 'Processor',MyID,' received TIMEUP-STOP signal in SUMSL.'
+ write (*,*)
+ & 'Processor',MyID,' received TIMEUP-STOP signal in SUMSL.'
+ WhatsUp=-2
+ stopx=.true.
+ else if (Kwita.eq.-3) then
+ write (iout,*)
+ & 'Processor',MyID,' received ERROR-STOP signal in SUMSL.'
+ write (*,*)
+ & 'Processor',MyID,' received ERROR-STOP signal in SUMSL.'
+ WhatsUp=-1
+ stopx=.true.
+ else
+ stopx=.false.
+ WhatsUp=0
+ endif
+#endif
+ else
+ stopx = .false.
+ WhatsUp=0
+ endif
+#else
+ stopx=.false.
+#endif
+
+#ifdef OSF
+c Check for FOUND_NAN flag
+ if (FOUND_NAN) then
+ write(iout,*)" *** stopx : Found a NaN"
+ stopx=.true.
+ endif
+#endif
+
+ return
+ end
+C--------------------------------------------------------------------------
+ logical function ovrtim()
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.TIME1'
+ real*8 tcpu
+#ifdef MPI
+ include "mpif.h"
+ curtim = MPI_Wtime()-walltime
+#else
+ curtim= tcpu()
+#endif
+C curtim is the current time in seconds.
+c write (iout,*) "curtim",curtim," timlim",timlim," safety",safety
+ if (curtim .ge. timlim - safety) then
+ write (iout,'(a,f10.2,a,f10.2,a,f10.2,a)')
+ & "***************** Elapsed time (",curtim,
+ & " s) is within the safety limit (",safety,
+ & " s) of the allocated time (",timlim," s). Terminating."
+ ovrtim=.true.
+ else
+ ovrtim=.false.
+ endif
+ return
+ end
+**************************************************************************
+ double precision function tcpu()
+ 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 = 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 = 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 WINPGI
+****************************
+c next definitions for windows NT Digital fortran
+ real time_real
+ call cpu_time(time_real)
+ tcpu = time_real
+#endif
+#ifdef WINIFL
+****************************
+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)
+ include 'COMMON.IOUNITS'
+ 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
--- /dev/null
+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
--- /dev/null
+ 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)
+c integer MaxHdim
+c 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.HOMOLOGY"
+ include "COMMON.FFIELD"
+ include "COMMON.SBRIDGE"
+ include "COMMON.PROT"
+ include "COMMON.ENEPS"
+ include "COMMON.SHIELD"
+ 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),
+ & fimax_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
+ double precision ePMF,ePMF_q
+ double precision weimax_(0:ngridT)
+ 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),
+ & fimax(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,weimax(0:nGridT,Max_Parm)
+ 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,
+ & eliptran,esaxs,
+ & ehomology_constr,edfadis,edfator,edfanei,edfabet
+ 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
+C#define DEBUG
+#ifdef MPI
+ do i=1,scount(me1)
+#else
+ do i=1,ntot(islice)
+#endif
+c write (iout,*) "i",i," potE",(potE(i,j),j=1,nParmset)
+ 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)
+c 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
+
+ write (iout,*) "potEmin before reduce",potEmin
+ 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)
+c potEmin=potEmin_t/2
+ potEmin=potEmin_t
+ 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,22)
+#endif
+ call restore_parm(iparm)
+#ifdef DEBUG
+ write (iout,*) wsc,wscp,welec,wvdwpp,wang,wtor,wscloc,
+ & wcorr,wcorr5,wcorr6,wturn4,wturn3,wturn6,wel_loc,
+ & wtor_d,wsccor,wbond
+#endif
+ do ib=1,nT_h(iparm)
+ if (rescale_mode.eq.1) then
+ quot=1.0d0/(beta_h(ib,iparm)*1.987D-3*T0)
+ quotl=1.0d0
+ kfacl=1.0d0
+ do l=1,5
+ quotl1=quotl
+ quotl=quotl*quot
+ kfacl=kfacl*kfac
+ fT(l)=kfacl/(kfacl-1.0d0+quotl)
+ enddo
+#if defined(FUNCTH)
+ tt = 1.0d0/(beta_h(ib,iparm)*1.987D-3)
+ ft(6)=(320.0d0+80.0d0*dtanh((tt-320.0d0)/80.0d0))/320.0d0
+#elif defined(FUNCT)
+ ft(6)=1.0d0/(beta_h(ib,iparm)*1.987D-3*T0)
+#else
+ ft(6)=1.0d0
+#endif
+ else if (rescale_mode.eq.2) then
+ quot=1.0d0/(T0*beta_h(ib,iparm)*1.987D-3)
+ quotl=1.0d0
+ do l=1,5
+ quotl=quotl*quot
+ fT(l)=1.12692801104297249644d0/
+ & dlog(dexp(quotl)+dexp(-quotl))
+ enddo
+#if defined(FUNCTH)
+ tt = 1.0d0/(beta_h(ib,iparm)*1.987D-3)
+ ft(6)=(320.0d0+80.0d0*dtanh((tt-320.0d0)/80.0d0))/320.0d0
+#elif defined(FUNCT)
+ ft(6)=1.0d0/(beta_h(ib,iparm)*1.987D-3*T0)
+#else
+ ft(6)=1.0d0
+#endif
+c write (iout,*) 1.0d0/(beta_h(ib,iparm)*1.987D-3),ft
+ else if (rescale_mode.eq.0) then
+ do l=1,6
+ fT(l)=1.0d0
+ enddo
+ else
+ write (iout,*) "Error in WHAM_CALC: wrong RESCALE_MODE",
+ & rescale_mode
+ call flush(iout)
+ return1
+ endif
+ evdw=enetb(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)
+ eliptran=enetb(22,i,iparm)
+ esaxs=enetb(26,i,iparm)
+ ehomology_constr=enetb(27,i,iparm)
+ edfadis=enetb(28,i,iparm)
+ edfator=enetb(29,i,iparm)
+ edfanei=enetb(30,i,iparm)
+ edfabet=enetb(31,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,esaxs,
+ & ehomology_constr,edfadis,edfator,edfanei,edfabet
+#endif
+
+#ifdef SPLITELE
+ if (shield_mode.gt.0) then
+ etot=ft(1)*wsc*(evdw+ft(6)*evdw_t)+ft(1)*wscp*evdw2
+ & +ft(1)*welec*ees
+ & +ft(1)*wvdwpp*evdw1
+ & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc
+! & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5
+ & +wstrain*ehpb+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+wliptran*eliptran+wsaxs*esaxs
+ & +wdfa_dist*edfadis
+ & +wdfa_tor*edfator+wdfa_nei*edfanei+wdfa_beta*edfabet
+ else
+ etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2+ft(1)*welec*ees
+ & +wvdwpp*evdw1
+ & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc
+c & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5
+ & +wstrain*ehpb+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+wliptran*eliptran+wsaxs*esaxs
+ & +wdfa_dist*edfadis
+ & +wdfa_tor*edfator+wdfa_nei*edfanei+wdfa_beta*edfabet
+ endif
+#else
+ if (shield_mode.gt.0) then
+ etot=ft(1)*wsc*(evdw+ft(6)*evdw_t)+ft(1)*wscp*evdw2
+ & +ft(1)*welec*(ees+evdw1)
+ & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc
+c & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5
+ & +wstrain*ehpb+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+wliptran*eliptran+wsaxs*esaxs
+ & +wdfa_dist*edfadis
+ & +wdfa_tor*edfator+wdfa_nei*edfanei+wdfa_beta*edfabet
+ else
+ etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2
+ & +ft(1)*welec*(ees+evdw1)
+ & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc
+c & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5
+ & +wstrain*ehpb+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+wliptran*eliptran+wsaxs*esaxs
+ & +wdfa_dist*edfadis
+ & +wdfa_tor*edfator+wdfa_nei*edfanei+wdfa_beta*edfabet
+ endif
+
+#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
+#ifdef DEBUG
+ write (iout,*) "homol_nset",homol_nset,nR(ib,iparm)
+#endif
+ if (homol_nset.gt.1) then
+
+ do kk=1,nR(ib,iparm)
+ Econstr=waga_homology(kk)*ehomology_constr
+ v(i,kk,ib,iparm)=
+ & -beta_h(ib,iparm)*(etot+Econstr)
+#ifdef DEBUG
+ write (iout,'(4i5,4e15.5)') i,kk,ib,iparm,
+ & etot,Econstr,v(i,kk,ib,iparm)
+#endif
+ enddo ! kk
+
+ else
+
+ etot=etot+ehomology_constr
+
+ do kk=1,nR(ib,iparm)
+ Econstr=0.0d0
+ do j=1,nQ
+ dd = q(j,i)
+ Econstr=Econstr+Kh(j,kk,ib,iparm)
+ & *(dd-q0(j,kk,ib,iparm))**2
+ enddo
+c Adaptive potential contribution
+ if (adaptive) then
+ call PMF_energy(q(1,i),ib,kk,iparm,ePMF,ePMF_q)
+ Econstr=Econstr+ePMF
+ endif
+ 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
+
+ endif
+
+ 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
+ fimax_p(ii,iib,iparm)=v(1,ii,iib,iparm)+entfac(1)
+ do t=2,scount(me)
+ if(v(t,ii,iib,iparm)+entfac(t).gt.fimax_p(ii,iib,iparm))
+ & fimax_p(ii,iib,iparm)=v(t,ii,iib,iparm)+entfac(t)
+ enddo
+#else
+ fimax(ii,iib,iparm)=v(1,ii,iib,iparm)+entfac(1)
+ do t=2,ntot(islice)
+ if(v(t,ii,iib,iparm)+entfac(t).gt.fimax(ii,iib,iparm))
+ & fimax(ii,iib,iparm)=v(t,ii,iib,iparm)+entfac(t)
+ enddo
+#endif
+ enddo ! ii
+ enddo ! iib
+ enddo ! iparm
+#ifdef MPI
+ call MPI_AllReduce(fimax_p(1,1,1),fimax(1,1,1),
+ & maxR*MaxT_h*nParmSet,MPI_DOUBLE_PRECISION,
+ & MPI_MAX,WHAM_COMM,IERROR)
+#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)-fimax(ii,iib,iparm))
+#ifdef DEBUG
+ write (iout,'(4i5,3e15.5)') t,ii,iib,iparm,
+ & v(t,ii,iib,iparm),entfac(t),fi_p(ii,iib,iparm)
+#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)-fimax(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(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
+c write (iout,*) "REDUCE size",maxR,MaxT_h,nParmSet,
+c & maxR*MaxT_h*nParmSet
+c write (iout,*) "MPI_COMM_WORLD",MPI_COMM_WORLD,
+c & " 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))-fimax(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
+ do iparm=1,nParmSet
+
+ call restore_parm(iparm)
+c
+C Histograms
+c
+#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
+#ifdef MPI
+ do t=1,scount(me1)
+#else
+ do t=1,ntot(islice)
+#endif
+ 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
+c
+c Thermo and ensemble averages
+c
+ do k=0,nGridT
+ betaT=startGridT+k*delta_T
+ call temp_scalfac(betaT,ft,ftprim,ftbis,*10)
+c write (iout,*) "ftprim",ftprim
+c write (iout,*) "ftbis",ftbis
+ betaT=1.0d0/(1.987D-3*betaT)
+c 7/10/18 AL Determine the max Botzmann weights for each temerature
+ call sum_ene(1,iparm,ft,etot)
+ weimax(k,iparm)=-betaT*(etot-potEmin)+entfac(1)
+c write (iout,*) "k",k," t",1," weight",weimax(k,iparm)
+#ifdef MPI
+ do t=2,scount(me1)
+#else
+ do t=2,ntot(islice)
+#endif
+ call sum_ene(t,iparm,ft,etot)
+ weight=-betaT*(etot-potEmin)+entfac(t)
+c write (iout,*) "k",k," t",t," weight",weight
+ if (weight.gt.weimax(k,iparm)) weimax(k,iparm)=weight
+ enddo
+#ifdef MPI
+ enddo
+#ifdef DEBUG
+ write (iout,*) "weimax before REDUCE"
+ write (iout,*) (weimax(k,iparm),k=0,ngridt)
+#endif
+ do k=0,nGridT
+ weimax_(k)=weimax(k,iparm)
+ enddo
+ call MPI_Allreduce(weimax_(0),weimax(0,iparm),nGridT+1,
+ & MPI_DOUBLE_PRECISION,MPI_MAX,WHAM_COMM,IERROR)
+#ifdef DEBUG
+ write (iout,*) "weimax"
+ write (iout,*) (weimax(k,iparm),k=0,ngridt)
+#endif
+ do k=0,nGridT
+ temper=startGridT+k*delta_T
+ betaT=1.0d0/(1.987D-3*temper)
+ call temp_scalfac(temper,ft,ftprim,ftbis,*10)
+ 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)
+c call restore_parm(iparm)
+ call sum_ene_deriv(t,iparm,ft,ftprim,ftbis,etot,eprim,ebis)
+ weight=dexp(-betaT*(etot-potEmin)+entfac(t)-weimax(k,iparm))
+#ifdef DEBUG
+ write (iout,*) "iparm",iparm," t",t," betaT",betaT,
+ & " etot",etot," entfac",entfac(t)," boltz",
+ & -betaT*(etot-potEmin)+entfac(t)," weimax",weimax(k,iparm),
+ & " 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 ! t
+ enddo ! k
+ 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))-weimax(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,*)
+ call flush(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
+C#undef DEBUG
+ 10 return1
+ end
+c------------------------------------------------------------------------
+ subroutine temp_scalfac(betaT,ft,ftprim,ftbis,*)
+ implicit none
+ include "DIMENSIONS"
+ include "DIMENSIONS.FREE"
+ include "COMMON.CONTROL"
+ include "COMMON.FREE"
+ include "COMMON.IOUNITS"
+ double precision fT(6),fTprim(6),fTbis(6),quot,quotl1,quotl,kfacl,
+ & kfac/2.4d0/,T0/300.0d0/,startGridT/200.0d0/,
+ & logfac,tanhT,betaT,denom,eplus,eminus
+ integer l
+ 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
+ return
+ end
+c--------------------------------------------------------------------
+ subroutine sum_ene(t,iparm,ft,etot)
+ implicit none
+ include 'DIMENSIONS'
+ include 'DIMENSIONS.ZSCOPT'
+ include 'DIMENSIONS.FREE'
+ include 'COMMON.CONTROL'
+ include 'COMMON.FFIELD'
+ include "COMMON.SBRIDGE"
+ include "COMMON.ENERGIES"
+ include "COMMON.IOUNITS"
+ integer t,iparm
+ double precision fT(6)
+ 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,
+ & eliptran,esaxs
+ 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)
+ eliptran=enetb(22,t,iparm)
+ esaxs=enetb(26,t,iparm)
+#ifdef SPLITELE
+ if (shield_mode.gt.0) then
+ etot=ft(1)*wsc*(evdw+ft(6)*evdw_t)+ft(1)*wscp*evdw2
+ & +ft(1)*welec*ees
+ & +ft(1)*wvdwpp*evdw1
+ & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc
+c & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5
+ & +wstrain*ehpb+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+wliptran*eliptran+wsaxs*esaxs
+ else
+ etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2+ft(1)*welec*ees
+ & +wvdwpp*evdw1
+ & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc
+c & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5
+ & +wstrain*ehpb+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+wliptran*eliptran+wsaxs*esaxs
+ endif
+#else
+ if (shield_mode.gt.0) then
+ etot=ft(1)*wsc*(evdw+ft(6)*evdw_t)+ft(1)*wscp*evdw2
+ & +ft(1)*welec*(ees+evdw1)
+ & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc
+c & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5
+ & +wstrain*ehpb+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+wliptran*eliptran+wsaxs*esaxs
+ else
+ etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2
+ & +ft(1)*welec*(ees+evdw1)
+ & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc
+c & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5
+ & +wstrain*ehpb+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+wliptran*eliptran+wsaxs*esaxs
+ endif
+#endif
+ return
+ end
+c--------------------------------------------------------------------
+ subroutine sum_ene_deriv(t,iparm,ft,ftprim,ftbis,etot,eprim,ebis)
+ implicit none
+ include 'DIMENSIONS'
+ include 'DIMENSIONS.ZSCOPT'
+ include 'DIMENSIONS.FREE'
+ include 'COMMON.CONTROL'
+ include 'COMMON.FFIELD'
+ include "COMMON.SBRIDGE"
+ include 'COMMON.ENERGIES'
+ include "COMMON.HOMOLOGY"
+ include "COMMON.IOUNITS"
+ integer t,iparm
+ double precision fT(6),fTprim(6),fTbis(6),
+ & eprim,ebis,temper
+ 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,
+ & eliptran,esaxs,ehomology_constr,edfadis,edfator,edfanei,edfabet
+ 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)
+ eliptran=enetb(22,t,iparm)
+ esaxs=enetb(26,t,iparm)
+ ehomology_constr=enetb(27,t,iparm)
+ edfadis=enetb(28,t,iparm)
+ edfator=enetb(29,t,iparm)
+ edfanei=enetb(30,t,iparm)
+ edfabet=enetb(31,t,iparm)
+#ifdef SPLITELE
+ if (shield_mode.gt.0) then
+ etot=ft(1)*wsc*(evdw+ft(6)*evdw_t)+ft(1)*wscp*evdw2
+ & +ft(1)*welec*ees
+ & +ft(1)*wvdwpp*evdw1
+ & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc
+c & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5
+ & +wstrain*ehpb+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+wliptran*eliptran+wsaxs*esaxs
+ eprim=ftprim(1)*(ft(6)*evdw_t+evdw)
+C & +ftprim(6)*evdw_t
+ & +ftprim(1)*wscp*evdw2
+ & +ftprim(1)*welec*ees
+ & +ftprim(1)*wvdwpp*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)*wsc*(evdw+ft(6)*evdw_t)
+ & +ftbis(1)*wscp*evdw2+
+ & ftbis(1)*welec*ees
+ & +ftbis(1)*wvdwpp*evdw
+ & +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
+ & +wvdwpp*evdw1
+ & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc
+c & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5
+ & +wstrain*ehpb+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+wliptran*eliptran+wsaxs*esaxs
+ 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
+ endif
+#else
+ if (shield_mode.gt.0) then
+ etot=ft(1)*wsc*(evdw+ft(6)*evdw_t)+ft(1)*wscp*evdw2
+ & +ft(1)*welec*(ees+evdw1)
+ & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc
+c & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5
+ & +wstrain*ehpb+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+wliptran*eliptran+wsaxs*esaxs
+ eprim=ftprim(1)*(evdw+ft(6)*evdw_t)
+ & +ftprim(1)*welec*(ees+evdw1)
+ & +ftprim(1)*wtor*etors+
+ & ftprim(1)*wscp*evdw2+
+ & 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)*(evdw+ft(6)*evdw_t)
+ & +ftbis(1)*wscp*evdw2
+ & +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
+ else
+ etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2
+ & +ft(1)*welec*(ees+evdw1)
+ & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc
+c & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5
+ & +wstrain*ehpb+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+wliptran*eliptran+wsaxs*esaxs
+ 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
+#endif
+ return
+ end
--- /dev/null
+ 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)
+c integer MaxHdim
+c 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"
+ include "COMMON.SHIELD"
+ 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
+ double precision ePMF,ePMF_q
+ 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,
+ & eliptran,esaxs
+
+ 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
+C#define DEBUG
+#ifdef MPI
+ do i=1,scount(me1)
+#else
+ do i=1,ntot(islice)
+#endif
+c write (iout,*) "i",i," potE",(potE(i,j),j=1,nParmset)
+ 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)
+c 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
+
+ write (iout,*) "potEmin before reduce",potEmin
+ 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)
+c potEmin=potEmin_t/2
+ potEmin=potEmin_t
+ 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,22)
+#endif
+ call restore_parm(iparm)
+#ifdef DEBUG
+ write (iout,*) wsc,wscp,welec,wvdwpp,wang,wtor,wscloc,
+ & wcorr,wcorr5,wcorr6,wturn4,wturn3,wturn6,wel_loc,
+ & wtor_d,wsccor,wbond,wsaxs
+#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)
+ eliptran=enetb(22,i,iparm)
+ esaxs=enetb(26,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,esaxs
+#endif
+
+#ifdef SPLITELE
+ if (shield_mode.gt.0) then
+ etot=ft(1)*wsc*(evdw+ft(6)*evdw_t)+ft(1)*wscp*evdw2
+ & +ft(1)*welec*ees
+ & +ft(1)*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+wliptran*eliptran+wsaxs*esaxs
+ else
+ 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+wliptran*eliptran+wsaxs*esaxs
+ endif
+#else
+ if (shield_mode.gt.0) then
+ etot=ft(1)*wsc*(evdw+ft(6)*evdw_t)+ft(1)*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+wliptran*eliptran+wsaxs*esaxs
+ 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+wliptran*eliptran+wsaxs*esaxs
+ endif
+
+#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
+c Adaptive potential contribution
+ if (adaptive) then
+ call PMF_energy(q(1,i),ib,kk,iparm,ePMF,ePMF_q)
+ Econstr=Econstr+ePMF
+ endif
+ 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
+c write (iout,*) "REDUCE size",maxR,MaxT_h,nParmSet,
+c & maxR*MaxT_h*nParmSet
+c write (iout,*) "MPI_COMM_WORLD",MPI_COMM_WORLD,
+c & " 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)
+ esaxs=enetb(26,i,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)
+#ifdef SPLITELE
+ if (shield_mode.gt.0) then
+ etot=ft(1)*wsc*(evdw+ft(6)*evdw_t)+ft(1)*wscp*evdw2
+ & +ft(1)*welec*ees
+ & +ft(1)*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+wliptran*eliptran+wsaxs*esaxs
+ eprim=ftprim(1)*(ft(6)*evdw_t+evdw)
+C & +ftprim(6)*evdw_t
+ & +ftprim(1)*wscp*evdw2
+ & +ftprim(1)*welec*ees
+ & +ftprim(1)*wvdwpp*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)*wsc*(evdw+ft(6)*evdw_t)
+ & +ftbis(1)*wscp*evdw2+
+ & ftbis(1)*welec*ees
+ & +ftbis(1)*wvdwpp*evdw
+ & +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
+ & +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+wliptran*eliptran+wsaxs*esaxs
+ 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
+ endif
+#else
+ if (shield_mode.gt.0) then
+ etot=ft(1)*wsc*(evdw+ft(6)*evdw_t)+ft(1)*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+wliptran*eliptran+wsaxs*esaxs
+ eprim=ftprim(1)*(evdw+ft(6)*evdw_t)
+ & +ftprim(1)*welec*(ees+evdw1)
+ & +ftprim(1)*wtor*etors+
+ & ftprim(1)*wscp*evdw2+
+ & 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)*(evdw+ft(6)*evdw_t)
+ & +ftbis(1)*wscp*evdw2
+ & +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
+ 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+wliptran*eliptran+wsaxs*esaxs
+ 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
+
+#endif
+ weight=dexp(-betaT*(etot-potEmin)+entfac(t))
+#ifdef DEBUG
+ write (iout,*) "iparm",iparm," t",t," betaT",betaT,
+ & " etot",etot," entfac",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)
+ 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,*)
+ call flush(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
+C#undef DEBUG
+ end
--- /dev/null
+ 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
+ write (iout,*) "calling read_general_data"
+ call read_general_data(*10)
+ write (iout,*) "read_general_data"
+ call flush(iout)
+ write (iout,*) "calling molread"
+ call molread(*10)
+ write (iout,*) "molread"
+ call flush(iout)
+ write (iout,*) "MAIN: constr_dist",constr_dist
+ if (constr_dist.gt.0) call read_dist_constr
+#ifdef MPI
+c write (iout,*) "Calling proc_groups"
+ call proc_groups
+c write (iout,*) "proc_groups exited"
+c call flush(iout)
+#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)
+ if (adaptive) call PMFread
+c write (iout,*) "Finished READ_EFREE"
+c call flush(iout)
+ call read_protein_data(*10)
+c write (iout,*) "Finished READ_PROTEIN_DATA"
+c 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
+C if (constr_dist.gt.0) call read_dist_constr
+c write (iout,*) "Begin read_database"
+c 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)
+ 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
--- /dev/null
+../../lib/xdrf
\ No newline at end of file
--- /dev/null
+ 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
projects / unres.git / commitdiff