# add_subdirectory(source/wham/src-M)
# add_subdirectory(source/cluster/wham/src)
# add_subdirectory(source/cluster/wham/src-M)
+ add_subdirectory(source/cluster/wham/src-M-SAXS-homology)
endif(UNRES_WITH_MPI)
#add_subdirectory(source/unres/src_MIN)
1L2Y clustering
-nres=22 n_ene=18 ncut=1 cutoff=-58.0 pdbref rescale=2 PRINT_CART PDBOUT=1 &
+nres=22 n_ene=18 ncut=0 cutoff=-58.0 pdbref rescale=2 PRINT_CART PDBOUT=1 &
iopt=1 temper=280 one_letter
WSC=1.00000 WSCP=1.23315 WELEC=0.84476 WBOND=1.00000 WANG=0.62954 &
WSCLOC=0.10554 WTOR=1.34316 WTORD=1.26571 WCORRH=0.19212 WCORR5=0.00000 &
--- /dev/null
+#
+# CMake project file for cluster analysis from WHAM for oligomeric proteins
+#
+
+enable_language (Fortran C)
+
+#================================
+# Set source file lists
+#================================
+set(UNRES_CLUSTER_WHAM_M_SRC0
+ arcos.f
+ cartprint.f
+ chainbuild.f
+ contact.f
+ convert.f
+ energy_p_new.F
+ fitsq.f
+ geomout.F
+ gnmr1.f
+ hc.f
+ icant.f
+ initialize_p.F
+ intcor.f
+ int_from_cart1.f
+ main_clust.F
+ matmult.f
+ misc.f
+ noyes.f
+ parmread.F
+ permut.F
+ pinorm.f
+ printmat.f
+ probabl.F
+ read_coords.F
+ readpdb.F
+ readrtns.F
+ rescode.f
+ setup_var.f
+ srtclust.f
+ ssMD.F
+ timing.F
+ track.F
+ wrtclust.f
+ work_partition.F
+ read_ref_str.F
+ seq2chains.f
+ chain_symmetry.F
+ iperm.f
+ rmscalc.F
+ rmsnat.f
+ TMscore.F
+ refsys.f
+ read_constr_homology.F
+)
+
+set(UNRES_CLUSTER_WHAM_M_PP_SRC
+ energy_p_new.F
+ initialize_p.F
+ geomout.F
+ main_clust.F
+ parmread.F
+ probabl.F
+ read_coords.F
+ readrtns.F
+ ssMD.F
+ timing.F
+ track.F
+ work_partition.F
+ permut.F
+ read_ref_str.F
+ chain_symmetry.F
+ rmscalc.F
+ TMscore.F
+ read_constr_homology.F
+ readpdb.F
+)
+
+if(UNRES_DFA)
+ set(UNRES_CLUSTER_WHAM_M_SRC0 ${UNRES_CLUSTER_WHAM_M_SRC0} dfa.F )
+ set(UNRES_CLUSTER_WHAM_M_PP_SRC ${UNRES_CLUSTER_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 -ip -w -I. -I${CMAKE_CURRENT_SOURCE_DIR}/include_unres" )
+elseif (Fortran_COMPILER_NAME STREQUAL "gfortran")
+ set(FFLAGS0 "-std=legacy -mcmodel=medium -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 "-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_CLUSTER_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" )
+elseif(UNRES_MD_FF STREQUAL "NEWCORR")
+ set(CPPFLAGS "PROCOR -DSPLITELE -DCORRCD -DNEWCORR" )
+endif(UNRES_MD_FF STREQUAL "GAB")
+
+#=========================================
+# Additional flags
+#=========================================
+set(CPPFLAGS "${CPPFLAGS} -DUNRES -DISNAN -DCLUST")
+
+if(UNRES_DFA)
+ set(CPPFLAGS "${CPPFLAGS} -DDFA")
+endif(UNRES_DFA)
+
+#=========================================
+# 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_CLUSTER_WHAM_M_SRC0 ${CMAKE_CURRENT_BINARY_DIR}/isnan_pgi.f)
+endif (Fortran_COMPILER_NAME STREQUAL "ifort")
+
+
+#=========================================
+# System specific flags
+#=========================================
+if(${CMAKE_SYSTEM_NAME} MATCHES "Linux")
+ set(CPPFLAGS "${CPPFLAGS} -DLINUX")
+endif(${CMAKE_SYSTEM_NAME} MATCHES "Linux")
+
+#=========================================
+# Add MPI preprocessor flags
+#=========================================
+if (UNRES_WITH_MPI)
+ set(CPPFLAGS "${CPPFLAGS} -DMP -DMPI")
+endif(UNRES_WITH_MPI)
+
+
+#=========================================
+# Apply preprocesor flags to *.F files
+#=========================================
+set_property(SOURCE ${UNRES_CLUSTER_WHAM_M_PP_SRC} PROPERTY COMPILE_DEFINITIONS ${CPPFLAGS} )
+
+set_property(SOURCE proc_proc.c PROPERTY COMPILE_DEFINITIONS "LINUX -DPGI" )
+
+#========================================
+# Setting binary name
+#========================================
+if(UNRES_DFA)
+ set(UNRES_CLUSTER_WHAM_M_BIN "cluster_wham-mult_${Fortran_COMPILER_NAME}_MPI_${UNRES_MD_FF}_DFA.exe")
+else(UNRES_DFA)
+ set(UNRES_CLUSTER_WHAM_M_BIN "cluster_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 path
+set_property(SOURCE ${CMAKE_CURRENT_BINARY_DIR}/cinfo.f PROPERTY COMPILE_FLAGS "${FFLAGS0} -I${CMAKE_CURRENT_SOURCE_DIR}" )
+
+
+set_property(SOURCE proc_proc.c PROPERTY COMPILE_DEFINITIONS "LINUX -DPGI" )
+
+
+#=========================================
+# Set full unres CLUSTER sources
+#=========================================
+set(UNRES_CLUSTER_WHAM_M_SRCS ${UNRES_CLUSTER_WHAM_M_SRC0} ${CMAKE_CURRENT_BINARY_DIR}/cinfo.f proc_proc.c)
+
+#=========================================
+# Build the binary
+#=========================================
+add_executable(UNRES_CLUSTER_WHAM_M_BIN ${UNRES_CLUSTER_WHAM_M_SRCS} )
+set_target_properties(UNRES_CLUSTER_WHAM_M_BIN PROPERTIES OUTPUT_NAME ${UNRES_CLUSTER_WHAM_M_BIN})
+set_property(TARGET UNRES_CLUSTER_WHAM_M_BIN PROPERTY RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/bin )
+
+#=========================================
+# Link libraries
+#=========================================
+# link MPI libraries
+if(UNRES_WITH_MPI)
+ target_link_libraries( UNRES_CLUSTER_WHAM_M_BIN ${MPI_Fortran_LIBRARIES} )
+endif(UNRES_WITH_MPI)
+# link libxdrf.a
+target_link_libraries( UNRES_CLUSTER_WHAM_M_BIN xdrf )
+
+
+#=========================================
+# Install Path
+#=========================================
+install(TARGETS UNRES_CLUSTER_WHAM_M_BIN DESTINATION ${CMAKE_INSTALL_PREFIX}/cluster)
+
+
+#=========================================
+# 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/cluster_wham_mpi_E0LL2Y.sh
+"#!/bin/sh
+export POT=GB
+export INPUT=$1
+export INTIN=1L2Y_wham
+export OUTPUT=1L2Y_clust
+export PDB=CART
+export COORD=CX
+export PRINTCOOR=PRINT_PDB
+#-----------------------------------------------------------------------------
+CLUSTER_WHAM_BIN=${CMAKE_BINARY_DIR}/bin/${UNRES_CLUSTER_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 $CLUSTER_WHAM_BIN
+./cluster_wham_check.sh $1
+")
+
+#
+# File permissions workaround
+#
+FILE( COPY ${CMAKE_CURRENT_BINARY_DIR}/scripts/cluster_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/cluster_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_clust.inp
+ DESTINATION ${CMAKE_CURRENT_BINARY_DIR} )
+
+FILE(COPY ${CMAKE_SOURCE_DIR}/ctest/1L2Y_wham.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/cluster_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
+#-----------------------------------------------------------------------------
+CLUSTER_WHAM_BIN=${CMAKE_BINARY_DIR}/bin/${UNRES_CLUSTER_WHAM_BIN}
+#-----------------------------------------------------------------------------
+DD=${CMAKE_SOURCE_DIR}/PARAM
+export BONDPAR=$DD/bond_AM1.parm
+export THETPAR=$DD/theta_abinitio.parm
+export ROTPAR=$DD/rotamers_AM1_aura.10022007.parm
+export TORPAR=$DD/torsion_631Gdp.parm
+export TORDPAR=$DD/torsion_double_631Gdp.parm
+export ELEPAR=$DD/electr_631Gdp.parm
+export SIDEPAR=$DD/scinter_$POT.parm
+export FOURIER=$DD/fourier_opt.parm.1igd_hc_iter3_3
+export SCPPAR=$DD/scp.parm
+export SCCORPAR=$DD/sccor_am1_pawel.dat
+export THETPARPDB=$DD/thetaml.5parm
+export ROTPARPDB=$DD/scgauss.parm
+export PATTERN=$DD/patterns.cart
+export CONTFUNC=GB
+export SIDEP=$DD/contact.3.parm
+export SCRATCHDIR=.
+#-----------------------------------------------------------------------------
+echo CTEST_FULL_OUTPUT
+${mpiexec} ${boot_lam} ${np} $2 $CLUSTER_WHAM_BIN
+./cluster_wham_check.sh $1
+")
+
+FILE( COPY ${CMAKE_CURRENT_BINARY_DIR}/scripts/cluster_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 CLUSTER_WHAM_M_remd COMMAND sh ${CMAKE_CURRENT_BINARY_DIR}/cluster_wham_mpi_E0LL2Y.sh 1L2Y_clust 2 )
+ if(UNRES_DFA)
+ add_test(NAME CLUSTER_WHAM_remd_dfa COMMAND sh ${CMAKE_CURRENT_BINARY_DIR}/dfa/cluster_wham_mpi_E0LL2Y_dfa.sh dfa_clust 2 WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/dfa )
+ endif()
+endif(UNRES_MD_FF STREQUAL "E0LL2Y")
+
--- /dev/null
+ integer nres,nres0,nsup,nstart_sup,nend_sup,nstart_seq,
+ & nchain,chain_border,chain_length,ireschain,npermchain,
+ & tabpermchain,ishift_pdb,iz_sc
+ double precision c,cref,crefjlee,cref_pdb,dc,xloc,xrot,dc_norm,
+ & t,r,prod,rt,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),
+ & cref_pdb(3,maxres2+2),iz_sc,nsup,nstart_sup,
+ & nstart_seq,nend_sup,
+ & chain_length(maxchain),npermchain,ireschain(maxres),
+ & tabpermchain(maxchain,maxperm),
+ & chain_border(2,maxchain),nchain
+ 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
+ logical tree,plot_tree,lgrp,min_var
+ real*8 rcutoff,ecut
+ double precision totfree_gr
+ real*4 diss,allcart
+ double precision entfac,totfree,energy,rmstb,gdt_ts_tb,
+ & gdt_ha_tb,tmscore_tb
+ integer ncut,ngr,licz,nconf,iass,icc,mult,list_conf,
+ & nss_all,ihpb_all,jhpb_all,iass_tot,iscore,nprop,nclust
+ real*8 rmsave,rms_closest,gdt_ts_ave,gdt_ts_closest,
+ & gdt_ha_ave,gdt_ha_closest,tmscore_ave,tmscore_closest
+ common /clu/ diss(maxdist),energy(0:maxconf),ecut,
+ & entfac(maxconf),totfree(0:maxconf),totfree_gr(maxgr),
+ & rcutoff(max_cut+1),ncut,nclust,min_var,tree,plot_tree,lgrp
+ common /clu1/ ngr,licz(maxgr),nconf(maxgr,maxingr),iass(maxgr),
+ & iass_tot(maxgr,max_cut),list_conf(maxconf)
+ common /alles/ allcart(3,maxres2,maxconf),rmstb(maxconf),
+ & gdt_ts_tb(maxconf),gdt_ha_tb(maxconf),tmscore_tb(maxconf),
+ & rmsave(maxgr),rms_closest(maxgr),gdt_ts_ave(maxgr),
+ & gdt_ts_closest(maxgr),gdt_ha_ave(maxgr),gdt_ha_closest(maxgr),
+ & tmscore_ave(maxgr),tmscore_closest(maxgr),
+ & icc(maxconf),
+ & mult(maxres),nss_all(maxconf),ihpb_all(maxss,maxconf),
+ & jhpb_all(maxss,maxconf),iscore(maxconf),nprop
--- /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
+ double precision gacontp_hb1,gacontp_hb2,gacontp_hb3,gacontm_hb1,
+ & gacontm_hb2,gacontm_hb3,gacont_hbr,facont_hb,ees0p,ees0m,d_cont,
+ & grij_hb_cont
+ integer num_cont_hb,jcont_hb
+ common /contacts_hb/
+ & gacontp_hb1(3,maxconts,maxres),gacontp_hb2(3,maxconts,maxres),
+ & gacontp_hb3(3,maxconts,maxres),
+ & gacontm_hb1(3,maxconts,maxres),gacontm_hb2(3,maxconts,maxres),
+ & gacontm_hb3(3,maxconts,maxres),
+ & gacont_hbr(3,maxconts,maxres),
+ & grij_hb_cont(3,maxconts,maxres),
+ & facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
+ & ees0m(maxconts,maxres),d_cont(maxconts,maxres),
+ & num_cont_hb(maxres),jcont_hb(maxconts,maxres)
+C 9/23/99 Added improper rotation matrices and matrices of dipole-dipole
+C interactions
+C Interactions of pseudo-dipoles generated by loc-el interactions.
+ double precision dip,dipderg,dipderx
+ common /dipint/ dip(4,maxconts,maxres),dipderg(4,maxconts,maxres),
+ & dipderx(3,5,4,maxconts,maxres)
+C 10/30/99 Added other pre-computed vectors and matrices needed
+C to calculate three - six-order el-loc correlation terms
+ double precision Ug,Ugder,Ug2,Ug2der,obrot,obrot2,obrot_der,
+ & obrot2_der,Ub2,Ub2der,mu,muder,EUg,EUgder,CUg,CUgder,
+ & DUg,DUgder,DtUg2,DtUg2der,Ctobr,Ctobrder,Dtobr2,Dtobr2der
+ common /rotat/ Ug(2,2,maxres),Ugder(2,2,maxres),Ug2(2,2,maxres),
+ & Ug2der(2,2,maxres),obrot(2,maxres),obrot2(2,maxres),
+ & obrot_der(2,maxres),obrot2_der(2,maxres)
+C This common block contains vectors and matrices dependent on a single
+C amino-acid residue.
+ common /precomp1/ Ub2(2,maxres),Ub2der(2,maxres),mu(2,maxres),
+ & EUg(2,2,maxres),EUgder(2,2,maxres),CUg(2,2,maxres),
+ & CUgder(2,2,maxres),DUg(2,2,maxres),Dugder(2,2,maxres),
+ & DtUg2(2,2,maxres),DtUg2der(2,2,maxres),Ctobr(2,maxres),
+ & Ctobrder(2,maxres),Dtobr2(2,maxres),Dtobr2der(2,maxres)
+C This common block contains vectors and matrices dependent on two
+C consecutive amino-acid residues.
+ double precision Ug2Db1t,Ug2Db1tder,CUgb2,CUgb2der,EUgC,
+ & EUgCder,EUgD,EUgDder,DtUg2EUg,DtUg2EUgder,Ug2DtEUg,Ug2DtEUgder
+ common /precomp2/ Ug2Db1t(2,maxres),Ug2Db1tder(2,maxres),
+ & CUgb2(2,maxres),CUgb2der(2,maxres),EUgC(2,2,maxres),
+ & EUgCder(2,2,maxres),EUgD(2,2,maxres),EUgDder(2,2,maxres),
+ & DtUg2EUg(2,2,maxres),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,EAEA,EAEAderg,EAEAderx,
+ & ADtEA1,ADtEA1derg,ADtEA1derx,g_contij,ekont
+ 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 betaT
+ integer iscode,indpdb,outpdb,outmol2,iopt,nstart,nend,symetr,
+ & constr_dist,shield_mode,tor_mode,constr_homology,homol_nset
+ logical refstr,pdbref,punch_dist,print_dist,caonly,lside,
+ & lprint_cart,lprint_int,from_cart,lefree,from_bx,from_cx,
+ & with_dihed_constr,with_theta_constr,energy_dec,print_fittest,
+ & read2sigma,read_homol_frag,out_template_coord,out_template_restr,
+ & unres_pdb
+ common /cntrl/ betaT,iscode,indpdb,refstr,pdbref,outpdb,outmol2,
+ & punch_dist,print_dist,caonly,lside,lprint_cart,lprint_int,
+ & from_cart,from_bx,from_cx, with_dihed_constr,with_theta_constr,
+ & lefree,iopt,nstart,nend,symetr,unres_pdb,
+ & tor_mode,shield_mode,
+ & constr_dist,energy_dec,print_fittest,
+ & constr_homology,homol_nset,read2sigma,read_homol_frag,
+ & out_template_coord,out_template_restr
--- /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
+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,scalscp,cutoff_corr,delt_corr,
+ & wdfa_dist,wdfa_tor,wdfa_nei,wdfa_beta,
+ & r0_corr,wliptran,wsaxs
+ integer ipot,n_ene_comp,rescale_mode
+ common /ffield/ wsc,wscp,welec,wstrain,wtor,wtor_d,wang,wscloc,
+ & wcorr,wcorr4,wcorr5,wcorr6,wsccor,wel_loc,wturn3,wturn4,wturn6,
+ & wvdwpp,wbond,wliptran,wsaxs,
+ & weights(max_ene),scalscp,
+ & wdfa_dist,wdfa_tor,wdfa_nei,wdfa_beta,
+ & scal14,cutoff_corr,delt_corr,r0_corr,ipot,n_ene_comp,
+ & rescale_mode
+ 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 nT
+ double precision beta_h(maxT),prob_limit
+ common /free/ beta_h,prob_limit,nT
--- /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
+ 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(10),
+ & 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,icbase,istat,
+ & ientin,ientout,isidep1,ibond,isccor,jrms,jplot,
+ & iliptranpar
+ common /iounits/ inp,iout,igeom,intin,ipdb,imol2,ipdbin,ithep,
+ & irotam,itorp,itordp,ifourier,ielep,isidep,iscpp,icbase,
+ & istat,ientin,ientout,isidep1,ibond,isccor,jrms,jplot,
+ & iliptranpar
+ character*256 outname,intname,pdbname,mol2name,statname,intinname,
+ & entname,restartname,prefix,scratchdir,sidepname,pdbfile,
+ & sccorname,rmsname,prefintin,prefout
+ common /fnames/ outname,intname,pdbname,mol2name,statname,
+ & intinname,entname,restartname,prefix,pot,scratchdir,
+ & sccorname,sidepname,pdbfile,rmsname,prefintin,prefout
+C CSA I/O units & files
+ character*256 csa_rbank,csa_seed,csa_history,csa_bank,
+ & csa_bank1,csa_alpha,csa_alpha1,csa_bankt,csa_int,
+ & csa_bank_reminimized,csa_native_int,csa_in
+ common /csafiles/ csa_rbank,csa_seed,csa_history,csa_bank,
+ & csa_bank1,csa_alpha,csa_alpha1,csa_bankt,csa_int,
+ & csa_bank_reminimized,csa_native_int,csa_in
+ integer icsa_rbank,icsa_seed,icsa_history,icsa_bank,
+ & icsa_bank1,icsa_alpha,icsa_alpha1,icsa_bankt,icsa_int,
+ & icsa_bank_reminimized,icsa_native_int,icsa_in
+ common /csaunits/ icsa_rbank,icsa_seed,icsa_history,icsa_bank,
+ & icsa_bank1,icsa_alpha,icsa_alpha1,icsa_bankt,icsa_int,
+ & icsa_bank_reminimized,icsa_native_int,icsa_in
+C Parameter files
+ character*256 bondname,thetname,rotname,torname,tordname,
+ & fouriername,elename,sidename,scpname,patname,liptranname
+ common /parfiles/ thetname,rotname,torname,tordname,bondname,
+ & fouriername,elename,sidename,scpname,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 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
+C... Following COMMON block contains general variables controlling the MC/MCM
+C... procedure
+c-----------------------------------------------------------------------------
+ double precision Tcur,Tmin,Tmax,TstepH,TstepC,RanFract,
+ & overlap_cut,e_up,delte
+ integer nstepH,nstepC,maxacc,maxgen,maxtrial,maxtrial_iter,
+ & maxrepm,ngen,ntrial,ntherm,nrepm,neneval,nsave,maxoverlap,
+ & nsave_part,max_mcm_it,nsweep,print_mc
+ logical print_stat,print_int
+ common /mcm/ Tcur,Tmin,Tmax,TstepH,TstepC,Rbol,betbol,RanFract,
+ & overlap_cut,e_up,delte,
+ & nstepH,nstepC,maxacc,maxgen,maxtrial,maxtrial_iter,maxrepm,
+ & maxoverlap,ntrial,max_mcm_it,
+ & ngen,ntherm,nrepm,neneval,nsave,nsave_part(max_cg_procs),nsweep,
+ & print_mc,print_stat,print_int
+c-----------------------------------------------------------------------------
+C... The meaning of the above variables is as follows:
+C... Tcur,Tmin,Tmax - Current,minimum and maximum temperature, respectively;
+C... NstepC,NStepH - Number of cooling and heating steps, respectively;
+C... TstepH,TstepC - factors by which T is multiplied in order to be
+C... increased or decreased.
+C... betbol - Boltzmann's inverse temperature (1/(Rbol*Tcur));
+C... Rbol - the gas constant;
+C... RanFract - the chance that a new conformation will be random-generated;
+C... maxacc - maximum number of accepted conformations;
+C... maxgen,ngen - Maximum and current number of generated conformations;
+C... maxtrial,ntrial - maximum number of trials before temperature is increased
+C... and current number of trials, respectively;
+C... maxrepm,nrepm - maximum number of allowed minima repetition and current
+C... number of minima repetitions, respectively;
+C... maxoverlap - max. # of overlapping confs generated in a single iteration;
+C... neneval - number of energy evaluations;
+C... nsave - number of confs. in the backup array;
+C... nsweep - the number of macroiterations in generating the distributions.
+c------------------------------------------------------------------------------
+C... Following COMMON block contains variables controlling motion.
+c------------------------------------------------------------------------------
+ double precision sumpro_type,sumpro_bond
+ integer koniecl, Nbm,MaxSideMove,nmove,moves(-1:MaxMoveType+1),
+ & moves_acc(-1:MaxMoveType+1),nacc_tot,nacc_part(0:MaxProcs)
+ common /move/ sumpro_type(0:MaxMoveType),sumpro_bond(0:maxres),
+ & koniecl,Nbm,MaxSideMove,nmove,nbond_move(maxres),
+ & nbond_acc(maxres),moves,moves_acc
+ common /accept_stats/ nacc_tot,nacc_part
+ integer nwindow,winstart,winend,winlen
+ common /windows/ nwindow,winstart(maxres),winend(maxres),
+ & winlen(maxres)
+ character*16 MovTypID
+ common /moveID/ MovTypID(-1:MaxMoveType+1)
+c------------------------------------------------------------------------------
+C... koniecl - the number of bonds to be considered "end bonds" subjected to
+C... end moves;
+C... Nbm - The maximum length of N-bond segment to be moved;
+C... MaxSideMove - maximum number of side chains subjected to local moves
+C... simultaneously;
+C... nmove - the current number of attempted moves;
+C... nbond_move(*) array that stores the total numbers of 2-bond,3-bond,...
+C... moves;
+C... nendmove - number of endmoves;
+C... nbackmove - number of backbone moves;
+C... nsidemove - number of local side chain moves;
+C... sumpro_type(*) - array that stores the lower and upper boundary of the
+C... random-number range that determines the type of move
+C... (N-bond, backbone or side chain);
+C... sumpro_bond(*) - array that stores the probabilities to perform bond
+C... moves of consecutive segment length.
+C... winstart(*) - the starting position of the perturbation window;
+C... winend(*) - the end position of the perturbation window;
+C... winlen(*) - length of the perturbation window;
+C... nwindow - the number of perturbation windows (0 - entire chain).
--- /dev/null
+ double precision tolf,rtolf
+ integer maxfun,maxmin
+ common /minimm/ tolf,rtolf,maxfun,maxmin
--- /dev/null
+ integer me, me1, Master, Master1, Nprocs, Nprocs1, Comm1,
+ & Indstart, Indend, scount, idispl, i2ii
+ integer indstart_map,indend_map,idispl_map,scount_map
+ common /MPI_Data/ Nprocs, Master,Master1,Me,Comm1,Me1,Nprocs1,
+ & Indstart(0:MaxProcs),Indend(0:MaxProcs), idispl(0:MaxProcs),
+ & scount(0:MaxProcs), indstart_map(0:MaxProcs),
+ & indend_map(0:MaxProcs), idispl_map(0:MaxProcs),
+ & scount_map(0:MaxProcs)
--- /dev/null
+ common /names/ restyp(-ntyp1:ntyp1),onelet(-ntyp1:ntyp1)
+ character*3 restyp
+ character*1 onelet
+ character*10 ename,wname
+ integer nprint_ene,print_order,iw
+ common /namterm/ ename(max_ene),wname(max_ene),nprint_ene,
+ & print_order(max_ene),iw(max_ene)
--- /dev/null
+! SAXS restraint parameters
+ integer nsaxs,saxs_mode
+ double precision Psaxs(maxsaxs),Pcalc(maxsaxs),distsaxs(maxsaxs),
+ & CSAXS(3,maxsaxs),scal_rad,wsaxs0,saxs_cutoff
+ common /saxsretr/ Psaxs,Pcalc,distsaxs,csaxs,Wsaxs0,scal_rad,
+ & saxs_cutoff,nsaxs,saxs_mode
+
--- /dev/null
+ double precision ss_depth,ebr,d0cm,akcm,akth,akct,v1ss,v2ss,v3ss
+ integer ns,nss,nfree,iss
+ logical restr_on_coord
+ 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
+ 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
+ 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 tempfac(2,maxres)
+ common /factemp/ tempfac
--- /dev/null
+ integer nthread,nexcl,iexam,ipatt
+ double precision ener0,ener,max_time_for_thread,
+ & ave_time_for_thread
+ common /thread/ nthread,nexcl,iexam(2,maxthread),
+ & ipatt(2,maxthread)
+ common /thread1/ ener0(n_ene,maxthread),ener(n_ene,maxthread),
+ & max_time_for_thread,ave_time_for_thread
--- /dev/null
+ DOUBLE PRECISION BATIME,TIMLIM,STIME,PREVTIM,SAFETY
+ INTEGER ISTOP
+ COMMON/TIME1/STIME,TIMLIM,BATIME,PREVTIM,SAFETY
+ COMMON/STOPTIM/ISTOP
--- /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),
+ & 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,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
+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 5/10/95 ----------- *
+* *
+********************************************************************************
+C Max. number of processors.
+ integer maxprocs
+ parameter (maxprocs=48)
+C Max. number of AA residues
+ integer maxres,maxres2
+ parameter (maxres=1200)
+c parameter (maxres=3300)
+C Appr. max. number of interaction sites
+ parameter (maxres2=2*maxres)
+C Max. number of variables
+ integer maxvar
+ parameter (maxvar=4*maxres)
+C Max. number of groups of interactions that a given SC is involved in
+ integer maxint_gr
+ parameter (maxint_gr=2)
+C Max number of symetric chains
+ integer maxchain
+ parameter (maxchain=50)
+ integer maxperm
+ parameter (maxperm=120)
+C Max. number of derivatives of virtual-bond and side-chain vectors in theta
+C or phi.
+ integer maxdim
+ parameter (maxdim=(maxres-1)*(maxres-2)/2)
+C Max. number of SC contacts
+ integer maxcont
+ parameter (maxcont=12*maxres)
+C Max. number of contacts per residue
+ integer maxconts
+ parameter (maxconts=maxres)
+C Number of AA types (at present only natural AA's will be handled
+ integer ntyp,ntyp1
+ parameter (ntyp=24,ntyp1=ntyp+1)
+C Max. number of types of dihedral angles & multiplicity of torsional barriers
+ 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 energy components
+ integer max_ene
+ parameter (max_ene=31)
+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)
+C Max. number of temperatures
+ integer maxt
+ parameter (maxT=5)
+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)
--- /dev/null
+******************************************************************
+*
+* Array dimensions for level-based conformation comparison program:
+*
+* 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
+Makefile-MPICH-ifort-okeanos
\ No newline at end of file
--- /dev/null
+##################################################################
+INSTALL_DIR = /users/software/mpich2-1.0.7
+
+FC= gfortran
+
+OPT = -O
+
+FFLAGS = ${OPT} -c -I. -Iinclude_unres -I$(INSTALL_DIR)/include
+
+LIBS = -L$(INSTALL_DIR)/lib -lmpich -lpthread xdrf/libxdrf.a
+
+.c.o:
+ cc -c -DLINUX -DPGI $*.c
+
+.f.o:
+ ${FC} ${FFLAGS} $*.f
+
+.F.o:
+ ${FC} ${FFLAGS} ${CPPFLAGS} ${FFLAGS} $*.F
+
+object = main_clust.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \
+ matmult.o readrtns.o pinorm.o rescode.o intcor.o timing.o misc.o \
+ geomout.o readpdb.o read_coords.o parmread.o probabl.o fitsq.o hc.o \
+ track.o wrtclust.o srtclust.o noyes.o contact.o printmat.o ssMD.o \
+ int_from_cart1.o energy_p_new.o icant.o proc_proc.o work_partition.o \
+ setup_var.o read_ref_str.o gnmr1.o permut.o
+
+all: no_option
+ @echo "Specify force field: GAB, 4P or E0LL2Y"
+
+no_option:
+
+GAB: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \
+ -DCLUST -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC
+GAB: BIN = ../../../../bin/cluster/unres_clustMD-mult_ifort_MPICH_GAB.exe
+GAB: ${object} xdrf/libxdrf.a
+ cc -o compinfo compinfo.c
+ ./compinfo | true
+ ${FC} ${FFLAGS} cinfo.f
+ $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN}
+
+4P: CPPFLAGS = -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \
+ -DCLUST -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC
+4P: BIN = ../../../../bin/cluster/unres_clustMD-mult_ifort_MPICH_4P.exe
+4P: ${object} xdrf/libxdrf.a
+ cc -o compinfo compinfo.c
+ ./compinfo | true
+ ${FC} ${FFLAGS} cinfo.f
+ $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN}
+
+E0LL2Y: CPPFLAGS = -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \
+ -DCLUST -DSPLITELE -DLANG0
+E0LL2Y: BIN = ../../../../bin/cluster/unres_clustMD-mult_ifort_MPICH_E0LL2Y.exe
+E0LL2Y: ${object} xdrf/libxdrf.a
+ cc -o compinfo compinfo.c
+ ./compinfo | true
+ ${FC} ${FFLAGS} cinfo.f
+ $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN}
+
+NEWCORR: CPPFLAGS = -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \
+ -DCLUST -DSPLITELE -DLANG0 -DNEWCORR
+NEWCORR: BIN = ../../../../bin/cluster/unres_clustMD-mult_ifort_MPICH_NEWCORR.exe
+NEWCORR: ${object} xdrf/libxdrf.a
+ cc -o compinfo compinfo.c
+ ./compinfo | true
+ ${FC} ${FFLAGS} cinfo.f
+ $(FC) ${OPT} ${object} ${LIBS} -o ${BIN}
+
+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/cluster
+FC = ifort
+OPT = -O3 -ip -w -mcmodel=medium
+OPT = -CB -g -mcmodel=medium
+FFLAGS = ${OPT} -c -I. -Iinclude_unres -I$(INSTALL_DIR)/include
+LIBS = -L$(INSTALL_DIR)/lib -lmpich -lpmpich xdrf/libxdrf.a
+
+.c.o:
+ cc -c -DLINUX -DPGI $*.c
+
+.f.o:
+ ${FC} ${FFLAGS} $*.f
+
+.F.o:
+ ${FC} ${FFLAGS} ${CPPFLAGS} ${FFLAGS} $*.F
+
+object = main_clust.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \
+ matmult.o readrtns.o pinorm.o rescode.o intcor.o timing.o misc.o \
+ geomout.o readpdb.o read_coords.o parmread.o probabl.o fitsq.o hc.o \
+ track.o wrtclust.o srtclust.o noyes.o contact.o printmat.o \
+ int_from_cart1.o energy_p_new.o icant.o proc_proc.o work_partition.o \
+ setup_var.o read_ref_str.o gnmr1.o permut.o ssMD.o
+
+all: no_option
+ @echo "Specify force field: GAB, 4P or E0LL2Y"
+
+no_option:
+
+GAB: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \
+ -DCLUST -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC
+GAB: BIN = ../../../../bin/cluster/unres_clustMD-mult_ifort_MPICH_GAB.exe
+GAB: ${object} xdrf/libxdrf.a
+ cc -o compinfo compinfo.c
+ ./compinfo | true
+ ${FC} ${FFLAGS} cinfo.f
+ $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN}
+
+4P: CPPFLAGS = -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \
+ -DCLUST -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC
+4P: BIN = ../../../../bin/cluster/unres_clustMD-mult_ifort_MPICH_4P.exe
+4P: ${object} xdrf/libxdrf.a
+ cc -o compinfo compinfo.c
+ ./compinfo | true
+ ${FC} ${FFLAGS} cinfo.f
+ $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN}
+
+E0LL2Y: CPPFLAGS = -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI -DPROCOR \
+ -DCLUST -DSPLITELE -DLANG0
+E0LL2Y: BIN = ../../../../bin/cluster/unres_clustMD-mult_ifort_MPICH_E0LL2Y.exe
+E0LL2Y: ${object} xdrf/libxdrf.a
+ cc -o compinfo compinfo.c
+ ./compinfo | true
+ ${FC} ${FFLAGS} cinfo.f
+ $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN}
+
+NEWCORR: CPPFLAGS = -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI -DPROCOR \
+ -DCLUST -DSPLITELE -DLANG0 -DNEWCORR
+NEWCORR: BIN = ../../../../bin/cluster/unres_clustMD-mult_ifort_MPICH_NEWCORR.exe
+NEWCORR: ${object} xdrf/libxdrf.a
+ cc -o compinfo compinfo.c
+ ./compinfo | true
+ ${FC} ${FFLAGS} cinfo.f
+ $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN}
+
+xdrf/libxdrf.a:
+ cd xdrf && make
+
+
+clean:
+ /bin/rm -f *.o && /bin/rm -f compinfo && cd xdrf && make clean
+
+
--- /dev/null
+#INSTALL_DIR = /opt/cray/mpt/7.3.2/gni/mpich-intel/15.0
+FC = ftn
+OPT = -O3 -ip -mcmodel=medium -shared-intel -dynamic
+#OPT = -CB -g -mcmodel=medium -shared-intel -dynamic
+FFLAGS = ${OPT} -c -I. -Iinclude_unres -I$(INSTALL_DIR)/include
+LIBS = -L$(INSTALL_DIR)/lib -lmpich xdrf/libxdrf.a
+
+.c.o:
+ cc -c -DLINUX -DPGI $*.c
+
+.f.o:
+ ${FC} ${FFLAGS} $*.f
+
+.F.o:
+ ${FC} ${FFLAGS} ${CPPFLAGS} ${FFLAGS} $*.F
+
+object = main_clust.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \
+ matmult.o readrtns.o pinorm.o rescode.o intcor.o timing.o misc.o \
+ geomout.o readpdb.o read_coords.o parmread.o probabl.o fitsq.o hc.o \
+ track.o wrtclust.o srtclust.o noyes.o contact.o printmat.o \
+ int_from_cart1.o energy_p_new.o icant.o proc_proc.o work_partition.o \
+ setup_var.o read_ref_str.o gnmr1.o permut.o seq2chains.o \
+ chain_symmetry.o iperm.o rmscalc.o rmsnat.o TMscore.o ssMD.o refsys.o \
+ read_constr_homology.o
+
+all: no_option
+ @echo "Specify force field: GAB, 4P or E0LL2Y"
+
+no_option:
+
+GAB: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \
+ -DCLUST -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC
+GAB: BIN = ~/bin/unres_clustMD-mult_ifort_MPICH_GAB-SAXS-MRAMB-Bfac.exe
+GAB: ${object} xdrf/libxdrf.a
+ gcc -o compinfo compinfo.c
+ ./compinfo | true
+ ${FC} ${FFLAGS} cinfo.f
+ $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN}
+
+4P: CPPFLAGS = -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \
+ -DCLUST -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC
+4P: BIN = ~/bin/unres_clustMD-mult_ifort_MPICH_4P-SAXS-homologyexe
+4P: ${object} xdrf/libxdrf.a
+ gcc -o compinfo compinfo.c
+ ./compinfo | true
+ ${FC} ${FFLAGS} cinfo.f
+ $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN}
+
+E0LL2Y: CPPFLAGS = -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI -DPROCOR \
+ -DCLUST -DSPLITELE -DLANG0
+E0LL2Y: BIN = ~/bin/unres_clustMD-mult_ifort_MPICH_E0LL2Y-SAXS-homology.exe
+E0LL2Y: ${object} xdrf/libxdrf.a
+ gcc -o compinfo compinfo.c
+ ./compinfo | true
+ ${FC} ${FFLAGS} cinfo.f
+ $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN}
+
+E0LL2Y_DFA: CPPFLAGS = -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI -DPROCOR \
+ -DCLUST -DSPLITELE -DLANG0 -DDFA
+E0LL2Y_DFA: BIN = ~/bin/unres_clustMD-mult_ifort_MPICH_E0LL2Y-SAXS-homology-DFA.exe
+E0LL2Y_DFA: ${object} dfa.o xdrf/libxdrf.a
+ gcc -o compinfo compinfo.c
+ ./compinfo | true
+ ${FC} ${FFLAGS} cinfo.f
+ $(FC) ${OPT} ${object} dfa.o cinfo.o ${LIBS} -o ${BIN}
+
+NEWCORR: CPPFLAGS = -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI -DPROCOR \
+ -DCORRCD -DCLUST -DSPLITELE -DLANG0 -DNEWCORR
+#-DCLUST -DSPLITELE -DLANG0 -DNEWCORR
+NEWCORR: BIN = ~/bin/unres_clustMD-mult_ifort_MPICH_NEWCORR-fouriertor-corrCD-SAXS-homology.exe
+#NEWCORR: BIN = ~/bin/unres_clustMD-mult_ifort_MPICH_NEWCORR-fouriertor-test.exe
+NEWCORR: ${object} xdrf/libxdrf.a
+ gcc -o compinfo compinfo.c
+ ./compinfo | true
+ ${FC} ${FFLAGS} cinfo.f
+ $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN}
+
+NEWCORR_DFA: CPPFLAGS = -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI -DPROCOR \
+ -DCORRCD -DCLUST -DSPLITELE -DLANG0 -DNEWCORR -DDFA
+#-DCLUST -DSPLITELE -DLANG0 -DNEWCORR
+NEWCORR_DFA: BIN = ~/bin/unres_clustMD-mult_ifort_MPICH_NEWCORR-fouriertor-corrCD-SAXS-homology-DFA.exe
+#NEWCORR: BIN = ~/bin/unres_clustMD-mult_ifort_MPICH_NEWCORR-fouriertor-test.exe
+NEWCORR_DFA: ${object} dfa.o xdrf/libxdrf.a
+ gcc -o compinfo compinfo.c
+ ./compinfo | true
+ ${FC} ${FFLAGS} cinfo.f
+ $(FC) ${OPT} ${object} dfa.o cinfo.o ${LIBS} -o ${BIN}
+
+xdrf/libxdrf.a:
+ cd xdrf && make
+
+
+clean:
+ /bin/rm -f *.o && /bin/rm -f compinfo && cd xdrf && make clean
+
+
--- /dev/null
+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}
+
+LIBS = -lmpi xdrf/libxdrf.a
+
+.c.o:
+ cc -c -DLINUX -DPGI $*.c
+
+.f.o:
+ ${FC} ${FFLAGS} $*.f
+
+.F.o:
+ ${FC} ${FFLAGS} ${CPPFLAGS} ${FFLAGS} $*.F
+
+object = main_clust.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \
+ matmult.o readrtns.o pinorm.o rescode.o intcor.o timing.o misc.o \
+ geomout.o readpdb.o read_coords.o parmread.o probabl.o fitsq.o hc.o \
+ track.o wrtclust.o srtclust.o noyes.o contact.o printmat.o \
+ int_from_cart1.o energy_p_new.o icant.o proc_proc.o work_partition.o \
+ setup_var.o read_ref_str.o gnmr1.o permut.o rmsnat.o TMscore.o ssMD.o oligomer.o
+
+all: no_option
+ @echo "Specify force field: GAB, 4P or E0LL2Y"
+
+no_option:
+
+GAB: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \
+ -DCLUST -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC
+GAB: BIN = ~/unres/bin/unres_clustMD-mult_ifort_MPICH_GAB-SAXS-MRAMB-Bfac.exe
+GAB: ${object} xdrf/libxdrf.a
+ gcc -o compinfo compinfo.c
+ ./compinfo | true
+ ${FC} ${FFLAGS} cinfo.f
+ $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN}
+
+4P: CPPFLAGS = -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \
+ -DCLUST -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC
+4P: BIN = ~/unres/bin/unres_clustMD-mult_ifort_MPICH_4P-SAXS-MRSAMB-Bfac.exe
+4P: ${object} xdrf/libxdrf.a
+ gcc -o compinfo compinfo.c
+ ./compinfo | true
+ ${FC} ${FFLAGS} cinfo.f
+ $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN}
+
+E0LL2Y: CPPFLAGS = -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI -DPROCOR \
+ -DCLUST -DSPLITELE -DLANG0
+E0LL2Y: BIN = ~/unres/bin/unres_clustMD-mult_ifort_MPICH_E0LL2Y-SAXS-MRAMB-Bfac.exe
+E0LL2Y: ${object} xdrf/libxdrf.a
+ gcc -o compinfo compinfo.c
+ ./compinfo | true
+ ${FC} ${FFLAGS} cinfo.f
+ $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN}
+
+NEWCORR: CPPFLAGS = -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI -DPROCOR \
+ -DCORRCD -DCLUST -DSPLITELE -DLANG0 -DNEWCORR
+NEWCORR: BIN = ~/unres/bin/unres_clustMD-mult_ifort_MPICH_NEWCORR-SAXS-MRAMB-Bfac.exe
+NEWCORR: ${object} xdrf/libxdrf.a
+ gcc -o compinfo compinfo.c
+ ./compinfo | true
+ ${FC} ${FFLAGS} cinfo.f
+ $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN}
+
+xdrf/libxdrf.a:
+ cd xdrf && make
+
+
+clean:
+ /bin/rm -f *.o && /bin/rm -f compinfo && cd xdrf && make clean
+
+
--- /dev/null
+FC = ftn
+OPT = -O3 -hfp3
+#OPT = -g -Rb
+FFLAGS = ${OPT} -c -I. -Iinclude_unres
+LIBS = xdrf/libxdrf.a
+
+.c.o:
+ cc -c -DLINUX -DPGI $*.c
+
+.f.o:
+ ${FC} ${FFLAGS} $*.f
+
+.F.o:
+ ${FC} ${FFLAGS} ${CPPFLAGS} ${FFLAGS} $*.F
+
+object = main_clust.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \
+ matmult.o readrtns.o pinorm.o rescode.o intcor.o timing.o misc.o \
+ geomout.o readpdb.o read_coords.o parmread.o probabl.o fitsq.o hc.o \
+ track.o wrtclust.o srtclust.o noyes.o contact.o printmat.o \
+ int_from_cart1.o energy_p_new.o icant.o proc_proc.o work_partition.o \
+ setup_var.o read_ref_str.o gnmr1.o permut.o ssMD.o
+
+all: no_option
+ @echo "Specify force field: GAB, 4P or E0LL2Y"
+
+no_option:
+
+GAB: CPPFLAGS = -DPROCOR -DCRAY -DAMD64 -DUNRES -DISNAN -DMP -DMPI \
+ -DCLUST -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC
+GAB: BIN = ~/bin/unres_clustMD-mult_ifort_MPICH_GAB.exe
+GAB: ${object} xdrf/libxdrf.a
+ cc -o compinfo compinfo.c
+ ./compinfo | true
+ ${FC} ${FFLAGS} cinfo.f
+ $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN}
+
+4P: CPPFLAGS = -DCRAY -DAMD64 -DUNRES -DISNAN -DMP -DMPI \
+ -DCLUST -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC
+4P: BIN = ~/bin/unres_clustMD_MPI_4P.exe
+4P: ${object} xdrf/libxdrf.a
+ cc -o compinfo compinfo.c
+ ./compinfo | true
+ ${FC} ${FFLAGS} cinfo.f
+ $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN}
+
+E0LL2Y: CPPFLAGS = -DCRAY -DAMD64 -DUNRES -DISNAN -DMP -DMPI -DPROCOR \
+ -DCLUST -DSPLITELE -DLANG0
+E0LL2Y: BIN = ~/bin/unres_clustMD-mult_MPI_E0LL2Y.exe
+E0LL2Y: ${object} xdrf/libxdrf.a
+ cc -o compinfo compinfo.c
+ ./compinfo | true
+ ${FC} ${FFLAGS} cinfo.f
+ $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN}
+
+NEWCORR: CPPFLAGS = -DCRAY -DAMD64 -DUNRES -DISNAN -DMP -DMPI -DPROCOR \
+ -DCLUST -DSPLITELE -DLANG0 -DNEWCORR
+NEWCORR: BIN = ~/bin/unres_clustMD-mult_MPI_NEWCORR.exe
+NEWCORR: ${object} xdrf/libxdrf.a
+ cc -o compinfo compinfo.c
+ ./compinfo | true
+ ${FC} ${FFLAGS} cinfo.f
+ $(FC) ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN}
+
+xdrf/libxdrf.a:
+ cd xdrf && make
+
+
+clean:
+ /bin/rm -f *.o && /bin/rm -f compinfo && cd xdrf && make clean
+
+
--- /dev/null
+*************************************************************************
+* This program is to compare two protein structures and identify the
+* best superposition that has the highest TM-score. Input structures
+* must be in the PDB format. By default, TM-score is normalized by
+* the second protein. Users can obtain a brief instruction by simply
+* running the program without arguments. For comments/suggestions,
+* please contact email: zhng@umich.edu.
+*
+* Reference:
+* Yang Zhang, Jeffrey Skolnick, Proteins, 2004 57:702-10.
+*
+* Permission to use, copy, modify, and distribute this program for
+* any purpose, with or without fee, is hereby granted, provided that
+* the notices on the head, the reference information, and this
+* copyright notice appear in all copies or substantial portions of
+* the Software. It is provided "as is" without express or implied
+* warranty.
+******************* Updating history ************************************
+* 2005/10/19: the program was reformed so that the score values.
+* are not dependent on the specific compilers.
+* 2006/06/20: selected 'A' if there is altLoc when reading PDB file.
+* 2007/02/05: fixed a bug with length<15 in TMscore_32.
+* 2007/02/27: rotation matrix from Chain-1 to Chain-2 was added.
+* 2007/12/06: GDT-HA score was added, fixed a bug for reading PDB.
+* 2010/08/02: A new RMSD matrix was used and obsolete statement removed.
+* 2011/01/03: The length of pdb file names were extended to 500.
+* 2011/01/30: An open source license is attached to the program.
+* 2012/05/07: Improved RMSD calculation subroutine which speeds up
+* TM-score program by 30%.
+* 2012/06/05: Added option '-l L' which calculates TM-score (and maxsub
+* and GDT scores) normalized by a specific length 'L'.
+*************************************************************************
+
+c program TMscore
+ subroutine TMscore_sub(rmsd,gdt_ts,gdt_ha,tmscore,cfname,lprint)
+ include 'DIMENSIONS'
+ PARAMETER(nmax=5000)
+ include 'COMMON.CONTROL'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+
+ real*8 rmsd,gdt_ts,gdt_ha,tmscore
+ common/stru/xt(nmax),yt(nmax),zt(nmax),xb(nmax),yb(nmax),zb(nmax)
+ common/nres/nresA(nmax),nresB(nmax),nseqA,nseqB
+ common/para/d,d0,d0_fix
+ common/align/n_ali,iA(nmax),iB(nmax)
+ common/nscore/i_ali(nmax),n_cut ![1,n_ali],align residues for the score
+ dimension k_ali(nmax),k_ali0(nmax)
+
+ character*500 fnam,pdb(100)!,outname
+ character*80 cfname
+ character*3 aa(-1:20),seqA(nmax),seqB(nmax)
+ character*500 s,du
+ character seq1A(nmax),seq1B(nmax),ali(nmax)
+ character sequenceA(nmax),sequenceB(nmax),sequenceM(nmax)
+
+ dimension L_ini(100),iq(nmax)
+ common/scores/score,score_maxsub,score_fix,score10
+ common/GDT/n_GDT05,n_GDT1,n_GDT2,n_GDT4,n_GDT8
+ double precision score,score_max,score_fix,score_fix_max
+ double precision score_maxsub,score10
+ dimension xa(nmax),ya(nmax),za(nmax)
+
+ccc RMSD:
+ double precision r_1(3,nmax),r_2(3,nmax),r_3(3,nmax),w(nmax)
+ double precision u(3,3),tt(3),rms,drms !armsd is real
+ data w /nmax*1.0/
+ integer ii,ipermmin,iperm
+
+ logical lprint
+ccc
+
+ data aa/ 'BCK','GLY','ALA','SER','CYS',
+ & 'VAL','THR','ILE','PRO','MET',
+ & 'ASP','ASN','LEU','LYS','GLU',
+ & 'GLN','ARG','HIS','PHE','TYR',
+ & 'TRP','CYX'/
+ character*1 slc(-1:20)
+ data slc/'X','G','A','S','C',
+ & 'V','T','I','P','M',
+ & 'D','N','L','K','E',
+ & 'Q','R','H','F','Y',
+ & 'W','C'/
+
+*****instructions ----------------->
+c call getarg(1,fnam)
+c if(fnam.eq.' '.or.fnam.eq.'?'.or.fnam.eq.'-h')then
+c write(*,*)
+c write(*,*)'Brief instruction for running TM-score program:'
+c write(*,*)'(For detail: Zhang & Skolnick, Proteins, 2004',
+c & ' 57:702-10)'
+c write(*,*)
+c write(*,*)'1. Run TM-score to compare ''model'' and ',
+c & '''native'':'
+c write(*,*)' >TMscore model native'
+c write(*,*)
+c write(*,*)'2. TM-score normalized with an assigned scale d0',
+c & ' e.g. 5 A:'
+c write(*,*)' >TMscore model native -d 5'
+c write(*,*)
+c write(*,*)'3. TM-score normalized by a specific length, ',
+c & 'e.g. 120 AA:'
+c write(*,*)' >TMscore model native -l 120'
+c write(*,*)
+c write(*,*)'4. TM-score with superposition output, e.g. ',
+c & '''TM.sup'':'
+c write(*,*)' >TMscore model native -o TM.sup'
+c write(*,*)' To view the superimposed structures by rasmol:'
+c write(*,*)' >rasmol -script TM.sup'
+c write(*,*)
+c goto 9999
+c endif
+
+ pdb(1)=cfname
+ pdb(2)=pdbfile
+******* options ----------->
+ m_out=-1
+ m_fix=-1
+ m_len=-1
+c narg=iargc()
+c i=0
+c j=0
+c 115 continue
+c i=i+1
+c call getarg(i,fnam)
+c if(fnam.eq.'-o')then
+c m_out=1
+c i=i+1
+c call getarg(i,outname)
+c elseif(fnam.eq.'-d')then
+c m_fix=1
+c i=i+1
+c call getarg(i,fnam)
+c read(fnam,*)d0_fix
+c elseif(fnam.eq.'-l')then
+c m_len=1
+c i=i+1
+c call getarg(i,fnam)
+c read(fnam,*)l0_fix
+c else
+c j=j+1
+c pdb(j)=fnam
+c endif
+c if(i.lt.narg)goto 115
+c
+ccccccccc read data from first CA file:
+c open(unit=10,file=pdb(1),status='old')
+c i=0
+c 101 read(10,104,end=102) s
+c if(s(1:3).eq.'TER') goto 102
+c if(s(1:4).eq.'ATOM')then
+c if(s(13:16).eq.'CA '.or.s(13:16).eq.' CA '.or.s(13:16).
+c & eq.' CA')then
+c if(s(17:17).eq.' '.or.s(17:17).eq.'A')then
+c i=i+1
+c read(s,103)du,seqA(i),du,nresA(i),du,xa(i),ya(i),za(i)
+c do j=-1,20
+c if(seqA(i).eq.aa(j))then
+c seq1A(i)=slc(j)
+c goto 21
+c endif
+c enddo
+c seq1A(i)=slc(-1)
+c 21 continue
+c endif
+c endif
+c endif
+c goto 101
+c 102 continue
+c 103 format(A17,A3,A2,i4,A4,3F8.3)
+c 104 format(A100)
+c close(10)
+c nseqA=i
+c^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+c
+ccccccccc read data from first CA file:
+c open(unit=10,file=pdb(2),status='old')
+c i=0
+c 201 read(10,204,end=202) s
+c if(s(1:3).eq.'TER') goto 202
+c if(s(1:4).eq.'ATOM')then
+c if(s(13:16).eq.'CA '.or.s(13:16).eq.' CA '.or.s(13:16).
+c & eq.' CA')then
+c if(s(17:17).eq.' '.or.s(17:17).eq.'A')then
+c i=i+1
+c read(s,203)du,seqB(i),du,nresB(i),du,xb(i),yb(i),zb(i)
+c do j=-1,20
+c if(seqB(i).eq.aa(j))then
+c seq1B(i)=slc(j)
+c goto 22
+c endif
+c enddo
+c seq1B(i)=slc(-1)
+c 22 continue
+c endif
+c endif
+c endif
+c goto 201
+c 202 continue
+c 203 format(A17,A3,A2,i4,A4,3F8.3)
+c 204 format(A100)
+c close(10)
+c nseqB=i
+c^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+******************************************************************
+* pickup the aligned residues:
+******************************************************************
+c k=0
+c do i=1,nseqA
+c do j=1,nseqB
+c if(nresA(i).eq.nresB(j))then
+c k=k+1
+c iA(k)=i
+c iB(k)=j
+c goto 205
+c endif
+c enddo
+c 205 continue
+c enddo
+c n_ali=k !number of aligned residues
+c if(n_ali.lt.1)then
+c write(*,*)'There is no common residues in the input structures'
+c goto 9999
+c endif
+c
+************/////
+* parameters:
+*****************
+
+ DO II=1,NPERMCHAIN
+
+ noverlap=nres
+ if (nres.gt.nsup+nnt-1) noverlap=nsup+nnt-1
+ nnsup=0
+ do i=1,noverlap
+ if (itype(i).ne.ntyp1) then
+ nnsup=nnsup+1
+ iA(nnsup)=nnsup
+ iB(nnsup)=nnsup
+ endif
+ enddo
+ nseqA=nnsup
+ nseqB=nnsup
+ n_ali=nnsup
+*** d0------------->
+ if(nseqB.gt.15)then
+ d0=1.24*(nseqB-15)**(1.0/3.0)-1.8
+ else
+ d0=0.5
+ endif
+ if(m_len.eq.1)then
+ d0=1.24*(l0_fix-15)**(1.0/3.0)-1.8
+ endif
+ if(d0.lt.0.5)d0=0.5
+ if(m_fix.eq.1)d0=d0_fix
+*** d0_search ----->
+ d0_search=d0
+ if(d0_search.gt.8)d0_search=8
+ if(d0_search.lt.4.5)d0_search=4.5
+*** iterative parameters ----->
+ n_it=20 !maximum number of iterations
+ d_output=5 !for output alignment
+ if(m_fix.eq.1)d_output=d0_fix
+ n_init_max=6 !maximum number of L_init
+ n_init=0
+ L_ini_min=4
+ if(n_ali.lt.4)L_ini_min=n_ali
+ do i=1,n_init_max-1
+ n_init=n_init+1
+ L_ini(n_init)=n_ali/2**(n_init-1)
+ if(L_ini(n_init).le.L_ini_min)then
+ L_ini(n_init)=L_ini_min
+ goto 402
+ endif
+ enddo
+ n_init=n_init+1
+ L_ini(n_init)=L_ini_min
+ 402 continue
+
+******************************************************************
+* find the maximum score starting from local structures superposition
+******************************************************************
+ score_max=-1 !TM-score
+ score_maxsub_max=-1 !MaxSub-score
+ score10_max=-1 !TM-score10
+ n_GDT05_max=-1 !number of residues<0.5
+ n_GDT1_max=-1 !number of residues<1
+ n_GDT2_max=-1 !number of residues<2
+ n_GDT4_max=-1 !number of residues<4
+ n_GDT8_max=-1 !number of residues<8
+
+#ifdef DEBUG
+ write (iout,*) "cref and ccref"
+#endif
+ noverlap=nres
+ if (nres.gt.nsup+nnt-1) noverlap=nsup+nnt-1
+ nnsup=0
+ do i=1,noverlap
+ if (itype(i).ne.ntyp1) then
+ nnsup=nnsup+1
+ xa(nnsup)=c(1,iperm(i,ii))
+ ya(nnsup)=c(2,iperm(i,ii))
+ za(nnsup)=c(3,iperm(i,ii))
+ xb(nnsup)=cref_pdb(1,i)
+ yb(nnsup)=cref_pdb(2,i)
+ zb(nnsup)=cref_pdb(3,i)
+c do j=1,3
+c cc(j,nnsup)=c(j,i)
+c ccref(j,nnsup)=cref_pdb(j,i,1)
+c enddo
+#ifdef DEBUG
+ write (iout,'(i5,3f10.5,5x,3f10.5)') nnsup,
+ & xa(nnsup),ya(nnsup),za(nnsup),xb(nnsup),yb(nnsup),zb(nnsup)
+#endif
+ endif
+ enddo
+
+ do 333 i_init=1,n_init
+ L_init=L_ini(i_init)
+ iL_max=n_ali-L_init+1
+ do 300 iL=1,iL_max !on aligned residues, [1,nseqA]
+ LL=0
+ ka=0
+ do i=1,L_init
+ k=iL+i-1 ![1,n_ali] common aligned
+ r_1(1,i)=xa(iA(k))
+ r_1(2,i)=ya(iA(k))
+ r_1(3,i)=za(iA(k))
+ r_2(1,i)=xb(iB(k))
+ r_2(2,i)=yb(iB(k))
+ r_2(3,i)=zb(iB(k))
+ ka=ka+1
+ k_ali(ka)=k
+ LL=LL+1
+ enddo
+ if(i_init.eq.1)then !global superposition
+ call u3b(w,r_1,r_2,LL,2,rms,u,tt,ier) !0:rmsd; 1:u,t; 2:rmsd,u,t
+ armsd=dsqrt(rms/LL)
+ rmsd_ali=armsd
+ else
+ call u3b(w,r_1,r_2,LL,1,rms,u,tt,ier) !u rotate r_1 to r_2
+ endif
+ do j=1,nseqA
+ xt(j)=tt(1)+u(1,1)*xa(j)+u(1,2)*ya(j)+u(1,3)*za(j)
+ yt(j)=tt(2)+u(2,1)*xa(j)+u(2,2)*ya(j)+u(2,3)*za(j)
+ zt(j)=tt(3)+u(3,1)*xa(j)+u(3,2)*ya(j)+u(3,3)*za(j)
+ enddo
+ d=d0_search-1
+ call score_fun !init, get scores, n_cut+i_ali(i) for iteration
+ if(score_max.lt.score)then
+ score_max=score
+ ka0=ka
+ do i=1,ka0
+ k_ali0(i)=k_ali(i)
+ enddo
+ endif
+ if(score10_max.lt.score10)score10_max=score10
+ if(score_maxsub_max.lt.score_maxsub)score_maxsub_max=
+ & score_maxsub
+ if(n_GDT05_max.lt.n_GDT05)n_GDT05_max=n_GDT05
+ if(n_GDT1_max.lt.n_GDT1)n_GDT1_max=n_GDT1
+ if(n_GDT2_max.lt.n_GDT2)n_GDT2_max=n_GDT2
+ if(n_GDT4_max.lt.n_GDT4)n_GDT4_max=n_GDT4
+ if(n_GDT8_max.lt.n_GDT8)n_GDT8_max=n_GDT8
+*** iteration for extending ---------------------------------->
+ d=d0_search+1
+ do 301 it=1,n_it
+ LL=0
+ ka=0
+ do i=1,n_cut
+ m=i_ali(i) ![1,n_ali]
+ r_1(1,i)=xa(iA(m))
+ r_1(2,i)=ya(iA(m))
+ r_1(3,i)=za(iA(m))
+ r_2(1,i)=xb(iB(m))
+ r_2(2,i)=yb(iB(m))
+ r_2(3,i)=zb(iB(m))
+ ka=ka+1
+ k_ali(ka)=m
+ LL=LL+1
+ enddo
+ call u3b(w,r_1,r_2,LL,1,rms,u,tt,ier) !u rotate r_1 to r_2
+ do j=1,nseqA
+ xt(j)=tt(1)+u(1,1)*xa(j)+u(1,2)*ya(j)+u(1,3)*za(j)
+ yt(j)=tt(2)+u(2,1)*xa(j)+u(2,2)*ya(j)+u(2,3)*za(j)
+ zt(j)=tt(3)+u(3,1)*xa(j)+u(3,2)*ya(j)+u(3,3)*za(j)
+ enddo
+ call score_fun !get scores, n_cut+i_ali(i) for iteration
+ if(score_max.lt.score)then
+ score_max=score
+ ka0=ka
+ do i=1,ka
+ k_ali0(i)=k_ali(i)
+ enddo
+ endif
+ if(score10_max.lt.score10)score10_max=score10
+ if(score_maxsub_max.lt.score_maxsub)score_maxsub_max
+ & =score_maxsub
+ if(n_GDT05_max.lt.n_GDT05)n_GDT05_max=n_GDT05
+ if(n_GDT1_max.lt.n_GDT1)n_GDT1_max=n_GDT1
+ if(n_GDT2_max.lt.n_GDT2)n_GDT2_max=n_GDT2
+ if(n_GDT4_max.lt.n_GDT4)n_GDT4_max=n_GDT4
+ if(n_GDT8_max.lt.n_GDT8)n_GDT8_max=n_GDT8
+ if(it.eq.n_it)goto 302
+ if(n_cut.eq.ka)then
+ neq=0
+ do i=1,n_cut
+ if(i_ali(i).eq.k_ali(i))neq=neq+1
+ enddo
+ if(n_cut.eq.neq)goto 302
+ endif
+ 301 continue !for iteration
+ 302 continue
+ 300 continue !for shift
+ 333 continue !for initial length, L_ali/M
+c
+ ratio=1
+ if(m_len.gt.0)then
+ ratio=float(nseqB)/float(l0_fix)
+ endif
+ if(m_len.eq.1)then
+ score_max=score_max*float(nseqB)/float(l0_fix)
+ endif
+ score_GDT=(n_GDT1_max+n_GDT2_max+n_GDT4_max+n_GDT8_max)
+ & /float(4*nseqB)
+ score_GDT_HA=(n_GDT05_max+n_GDT1_max+n_GDT2_max+n_GDT4_max)
+ & /float(4*nseqB)
+ tmscore=score_max
+ gdt_ts=score_GDT*ratio
+ gdt_ha=score_GDT_HA*ratio
+ rmsd=rmsd_ali
+
+ if (ii.eq.1 .or. rmsd.lt.rmsd_min) then
+ rmsd_min=rmsd
+ tmscore_min=tmscore
+ gdt_ts_min=gdt_ts
+ gdt_ha_min=gdt_ha
+ ipermmin=ii
+ endif
+
+ ENDDO
+
+ rmsd=rmsd_min
+ tmscore=tmscore_min
+ gdt_ts=gdt_ts_min
+ gdt_ha=gdt_ha_min
+
+******************************************************************
+* Output
+******************************************************************
+*** output TM-scale ---------------------------->
+
+ if (lprint) then
+
+ write(iout,*)
+ write(iout,*)'**************************************************',
+ & '***************************'
+ write(iout,*)'* TM-SCORE ',
+ & ' *'
+ write(iout,*)'* A scoring function to assess the similarity of p',
+ & 'rotein structures *'
+ write(iout,*)'* Based on statistics: ',
+ & ' *'
+ write(iout,*)'* 0.0 < TM-score < 0.17, random structural s',
+ & 'imilarity *'
+ write(iout,*)'* 0.5 < TM-score < 1.00, in about the same f',
+ & 'old *'
+ write(iout,*)'* Reference: Yang Zhang and Jeffrey Skolnick, ',
+ & 'Proteins 2004 57: 702-710 *'
+ write(iout,*)'* For comments, please email to: zhng@umich.edu ',
+ & ' *'
+ write(iout,*)'**************************************************',
+ & '***************************'
+ write(iout,*)
+ write(iout,501)pdb(1),nseqA
+ 501 format('Structure1: ',A10,' Length= ',I4)
+ if(m_len.eq.1)then
+ write(iout,411)pdb(2),nseqB
+ write(iout,412)l0_fix
+ else
+ write(iout,502)pdb(2),nseqB
+ endif
+ 411 format('Structure2: ',A10,' Length= ',I4)
+ 412 format('TM-score is notmalized by ',I4)
+ 502 format('Structure2: ',A10,' Length= ',I4,
+ & ' (by which all scores are normalized)')
+ write(iout,503)n_ali
+ 503 format('Number of residues in common= ',I4)
+ write(iout,513)rmsd_ali
+ 513 format('RMSD of the common residues= ',F8.3)
+ write(iout,*)
+ write(iout,504)score_max,d0
+ 504 format('TM-score = ',f6.4,' (d0=',f5.2,')')
+ write(iout,505)score_maxsub_max*ratio
+ 505 format('MaxSub-score= ',f6.4,' (d0= 3.50)')
+ write(iout,506)score_GDT*ratio,n_GDT1_max/float(nseqB)*ratio,
+ & n_GDT2_max/float(nseqB)*ratio,n_GDT4_max/float(nseqB)*ratio,
+ & n_GDT8_max/float(nseqB)*ratio
+ 506 format('GDT-TS-score= ',f6.4,' %(d<1)=',f6.4,' %(d<2)=',f6.4,
+ $ ' %(d<4)=',f6.4,' %(d<8)=',f6.4)
+ write(iout,507)score_GDT_HA*ratio,n_GDT05_max/float(nseqB)*ratio,
+ & n_GDT1_max/float(nseqB)*ratio,n_GDT2_max/float(nseqB)*ratio,
+ & n_GDT4_max/float(nseqB)*ratio
+ 507 format('GDT-HA-score= ',f6.4,' %(d<0.5)=',f6.4,' %(d<1)=',f6.4,
+ $ ' %(d<2)=',f6.4,' %(d<4)=',f6.4)
+ write (iout,*) "Permutation",ipermmin
+ write(iout,*)
+
+ endif
+
+ return
+ end
+c------------------------------------------------------------------------
+*** recall and output the superposition of maxiumum TM-score:
+c LL=0
+c do i=1,ka0
+c m=k_ali0(i) !record of the best alignment
+c r_1(1,i)=xa(iA(m))
+c r_1(2,i)=ya(iA(m))
+c r_1(3,i)=za(iA(m))
+c r_2(1,i)=xb(iB(m))
+c r_2(2,i)=yb(iB(m))
+c r_2(3,i)=zb(iB(m))
+c LL=LL+1
+c enddo
+c call u3b(w,r_1,r_2,LL,1,rms,u,t,ier) !u rotate r_1 to r_2
+c do j=1,nseqA
+c xt(j)=t(1)+u(1,1)*xa(j)+u(1,2)*ya(j)+u(1,3)*za(j)
+c yt(j)=t(2)+u(2,1)*xa(j)+u(2,2)*ya(j)+u(2,3)*za(j)
+c zt(j)=t(3)+u(3,1)*xa(j)+u(3,2)*ya(j)+u(3,3)*za(j)
+c enddo
+c
+c********* extract rotation matrix ------------>
+c write(*,*)'-------- rotation matrix to rotate Chain-1 to ',
+c & 'Chain-2 ------'
+c write(*,*)'i t(i) u(i,1) u(i,2) ',
+c & ' u(i,3)'
+c do i=1,3
+c write(*,304)i,t(i),u(i,1),u(i,2),u(i,3)
+c enddo
+cc do j=1,nseqA
+cc xt(j)=t(1)+u(1,1)*xa(j)+u(1,2)*ya(j)+u(1,3)*za(j)
+cc yt(j)=t(2)+u(2,1)*xa(j)+u(2,2)*ya(j)+u(2,3)*za(j)
+cc zt(j)=t(3)+u(3,1)*xa(j)+u(3,2)*ya(j)+u(3,3)*za(j)
+cc write(*,*)j,xt(j),yt(j),zt(j)
+cc enddo
+c write(*,*)
+c 304 format(I2,f18.10,f15.10,f15.10,f15.10)
+c
+c********* rmsd in superposed regions --------------->
+c d=d_output !for output
+c call score_fun() !give i_ali(i), score_max=score now
+c LL=0
+c do i=1,n_cut
+c m=i_ali(i) ![1,nseqA]
+c r_1(1,i)=xa(iA(m))
+c r_1(2,i)=ya(iA(m))
+c r_1(3,i)=za(iA(m))
+c r_2(1,i)=xb(iB(m))
+c r_2(2,i)=yb(iB(m))
+c r_2(3,i)=zb(iB(m))
+c LL=LL+1
+c enddo
+c call u3b(w,r_1,r_2,LL,0,rms,u,t,ier)
+c armsd=dsqrt(rms/LL)
+c rmsd=armsd
+c
+c*** output rotated chain1 + chain2----->
+c if(m_out.ne.1)goto 999
+c OPEN(unit=7,file=outname,status='unknown') !pdb1.aln + pdb2.aln
+c 900 format(A)
+c 901 format('select ',I4)
+c write(7,900)'load inline'
+c write(7,900)'select atomno<1000'
+cc write(7,900)'color [255,20,147]'
+c write(7,900)'wireframe .45'
+c write(7,900)'select none'
+c write(7,900)'select atomno>1000'
+cc write(7,900)'color [100,149,237]'
+c write(7,900)'wireframe .15'
+c write(7,900)'color white'
+c do i=1,n_cut
+c write(7,901)nresA(iA(i_ali(i)))
+c write(7,900)'color red'
+c enddo
+c write(7,900)'select all'
+c write(7,900)'exit'
+c write(7,514)rmsd_ali
+c 514 format('REMARK RMSD of the common residues=',F8.3)
+c write(7,515)score_max,d0
+c 515 format('REMARK TM-score=',f6.4,' (d0=',f5.2,')')
+c do i=1,nseqA
+c write(7,1237)nresA(i),seqA(i),nresA(i),xt(i),yt(i),zt(i)
+c enddo
+c write(7,1238)
+c do i=2,nseqA
+c write(7,1239)nresA(i-1),nresA(i)
+c enddo
+c do i=1,nseqB
+c write(7,1237)2000+nresB(i),seqB(i),nresB(i),xb(i),yb(i),zb(i)
+c enddo
+c write(7,1238)
+c do i=2,nseqB
+c write(7,1239)2000+nresB(i-1),2000+nresB(i)
+c enddo
+c 1237 format('ATOM ',i5,' CA ',A3,I6,4X,3F8.3)
+c 1238 format('TER')
+c 1239 format('CONECT',I5,I5)
+c 999 continue
+c
+c*** record aligned residues by i=[1,nseqA], for sequenceM()------------>
+c do i=1,nseqA
+c iq(i)=0
+c enddo
+c do i=1,n_cut
+c j=iA(i_ali(i)) ![1,nseqA]
+c k=iB(i_ali(i)) ![1,nseqB]
+c dis=sqrt((xt(j)-xb(k))**2+(yt(j)-yb(k))**2+(zt(j)-zb(k))**2)
+c if(dis.lt.d_output)then
+c iq(j)=1
+c endif
+c enddo
+c*******************************************************************
+c*** output aligned sequences
+c k=0
+c i=1
+c j=1
+c 800 continue
+c if(i.gt.nseqA.and.j.gt.nseqB)goto 802
+c if(i.gt.nseqA.and.j.le.nseqB)then
+c k=k+1
+c sequenceA(k)='-'
+c sequenceB(k)=seq1B(j)
+c sequenceM(k)=' '
+c j=j+1
+c goto 800
+c endif
+c if(i.le.nseqA.and.j.gt.nseqB)then
+c k=k+1
+c sequenceA(k)=seq1A(i)
+c sequenceB(k)='-'
+c sequenceM(k)=' '
+c i=i+1
+c goto 800
+c endif
+c if(nresA(i).eq.nresB(j))then
+c k=k+1
+c sequenceA(k)=seq1A(i)
+c sequenceB(k)=seq1B(j)
+c if(iq(i).eq.1)then
+c sequenceM(k)=':'
+c else
+c sequenceM(k)=' '
+c endif
+c i=i+1
+c j=j+1
+c goto 800
+c elseif(nresA(i).lt.nresB(j))then
+c k=k+1
+c sequenceA(k)=seq1A(i)
+c sequenceB(k)='-'
+c sequenceM(k)=' '
+c i=i+1
+c goto 800
+c elseif(nresB(j).lt.nresA(i))then
+c k=k+1
+c sequenceA(k)='-'
+c sequenceB(k)=seq1B(j)
+c sequenceM(k)=' '
+c j=j+1
+c goto 800
+c endif
+c 802 continue
+c
+c write(*,600)d_output,n_cut,rmsd
+c 600 format('Superposition in the TM-score: Length(d<',f3.1,
+c $ ')=',i3,' RMSD=',f6.2)
+c write(*,603)d_output
+c 603 format('(":" denotes the residue pairs of distance < ',f3.1,
+c & ' Angstrom)')
+c write(*,601)(sequenceA(i),i=1,k)
+c write(*,601)(sequenceM(i),i=1,k)
+c write(*,601)(sequenceB(i),i=1,k)
+c write(*,602)(mod(i,10),i=1,k)
+c 601 format(2000A1)
+c 602 format(2000I1)
+c write(*,*)
+c
+c^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+c 9999 END
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c 1, collect those residues with dis<d;
+c 2, calculate score_GDT, score_maxsub, score_TM
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine score_fun
+ PARAMETER(nmax=5000)
+
+ common/stru/xt(nmax),yt(nmax),zt(nmax),xb(nmax),yb(nmax),zb(nmax)
+ common/nres/nresA(nmax),nresB(nmax),nseqA,nseqB
+ common/para/d,d0,d0_fix
+ common/align/n_ali,iA(nmax),iB(nmax)
+ common/nscore/i_ali(nmax),n_cut ![1,n_ali],align residues for the score
+ common/scores/score,score_maxsub,score_fix,score10
+ common/GDT/n_GDT05,n_GDT1,n_GDT2,n_GDT4,n_GDT8
+ double precision score,score_max,score_fix,score_fix_max
+ double precision score_maxsub,score10
+
+ d_tmp=d
+ 21 n_cut=0 !number of residue-pairs dis<d, for iteration
+ n_GDT05=0 !for GDT-score, # of dis<0.5
+ n_GDT1=0 !for GDT-score, # of dis<1
+ n_GDT2=0 !for GDT-score, # of dis<2
+ n_GDT4=0 !for GDT-score, # of dis<4
+ n_GDT8=0 !for GDT-score, # of dis<8
+ score_maxsub_sum=0 !Maxsub-score
+ score_sum=0 !TMscore
+ score_sum10=0 !TMscore10
+ do k=1,n_ali
+ i=iA(k) ![1,nseqA] reoder number of structureA
+ j=iB(k) ![1,nseqB]
+ dis=sqrt((xt(i)-xb(j))**2+(yt(i)-yb(j))**2+(zt(i)-zb(j))**2)
+*** for iteration:
+ if(dis.lt.d_tmp)then
+ n_cut=n_cut+1
+ i_ali(n_cut)=k ![1,n_ali], mark the residue-pairs in dis<d
+ endif
+*** for GDT-score:
+ if(dis.le.8)then
+ n_GDT8=n_GDT8+1
+ if(dis.le.4)then
+ n_GDT4=n_GDT4+1
+ if(dis.le.2)then
+ n_GDT2=n_GDT2+1
+ if(dis.le.1)then
+ n_GDT1=n_GDT1+1
+ if(dis.le.0.5)then
+ n_GDT05=n_GDT05+1
+ endif
+ endif
+ endif
+ endif
+ endif
+*** for MAXsub-score:
+ if(dis.lt.3.5)then
+ score_maxsub_sum=score_maxsub_sum+1/(1+(dis/3.5)**2)
+ endif
+*** for TM-score:
+ score_sum=score_sum+1/(1+(dis/d0)**2)
+*** for TM-score10:
+ if(dis.lt.10)then
+ score_sum10=score_sum10+1/(1+(dis/d0)**2)
+ endif
+ enddo
+ if(n_cut.lt.3.and.n_ali.gt.3)then
+ d_tmp=d_tmp+.5
+ goto 21
+ endif
+ score_maxsub=score_maxsub_sum/float(nseqB) !MAXsub-score
+ score=score_sum/float(nseqB) !TM-score
+ score10=score_sum10/float(nseqB) !TM-score10
+
+ return
+ end
+
+cccccccccccccccc Calculate sum of (r_d-r_m)^2 cccccccccccccccccccccccccc
+c w - w(m) is weight for atom pair c m (given)
+c x - x(i,m) are coordinates of atom c m in set x (given)
+c y - y(i,m) are coordinates of atom c m in set y (given)
+c n - n is number of atom pairs (given)
+c mode - 0:calculate rms only (given,short)
+c 1:calculate u,t only (given,medium)
+c 2:calculate rms,u,t (given,longer)
+c rms - sum of w*(ux+t-y)**2 over all atom pairs (result)
+c u - u(i,j) is rotation matrix for best superposition (result)
+c t - t(i) is translation vector for best superposition (result)
+c ier - 0: a unique optimal superposition has been determined(result)
+c -1: superposition is not unique but optimal
+c -2: no result obtained because of negative weights w
+c or all weights equal to zero.
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine u3b(w, x, y, n, mode, rms, u, t, ier)
+ double precision w(*), x(3,*), y(3,*)
+ integer n, mode
+
+ double precision rms, u(3,3), t(3)
+ integer ier
+
+ integer i, j, k, l, m1, m
+ integer ip(9), ip2312(4)
+ double precision r(3,3), xc(3), yc(3), wc
+ double precision a(3,3), b(3,3), e(3), rr(6), ss(6)
+ double precision e0, d, spur, det, cof, h, g
+ double precision cth, sth, sqrth, p, sigma
+ double precision c1x, c1y, c1z, c2x, c2y, c2z
+ double precision s1x, s1y, s1z, s2x, s2y, s2z
+ double precision sxx, sxy, sxz, syx, syy, syz, szx, szy, szz
+
+ double precision sqrt3, tol, zero
+
+ data sqrt3 / 1.73205080756888d+00 /
+ data tol / 1.0d-2 /
+ data zero / 0.0d+00 /
+ data ip / 1, 2, 4, 2, 3, 5, 4, 5, 6 /
+ data ip2312 / 2, 3, 1, 2 /
+
+ wc = zero
+ rms = zero
+ e0 = zero
+ s1x = zero
+ s1y = zero
+ s1z = zero
+ s2x = zero
+ s2y = zero
+ s2z = zero
+ sxx = zero
+ sxy = zero
+ sxz = zero
+ syx = zero
+ syy = zero
+ syz = zero
+ szx = zero
+ szy = zero
+ szz = zero
+
+ do i=1, 3
+ xc(i) = zero
+ yc(i) = zero
+ t(i) = zero
+ do j=1, 3
+ r(i,j) = zero
+ u(i,j) = zero
+ a(i,j) = zero
+ if( i .eq. j ) then
+ u(i,j) = 1.0
+ a(i,j) = 1.0
+ end if
+ end do
+ end do
+
+ ier = -1
+ if( n .lt. 1 ) return
+ ier = -2
+
+ do m=1, n
+ c1x=x(1, m)
+ c1y=x(2, m)
+ c1z=x(3, m)
+
+ c2x=y(1, m)
+ c2y=y(2, m)
+ c2z=y(3, m)
+
+ s1x = s1x + c1x
+ s1y = s1y + c1y;
+ s1z = s1z + c1z;
+
+ s2x = s2x + c2x;
+ s2y = s2y + c2y;
+ s2z = s2z + c2z;
+
+ sxx = sxx + c1x*c2x;
+ sxy = sxy + c1x*c2y;
+ sxz = sxz + c1x*c2z;
+
+ syx = syx + c1y*c2x;
+ syy = syy + c1y*c2y;
+ syz = syz + c1y*c2z;
+
+ szx = szx + c1z*c2x;
+ szy = szy + c1z*c2y;
+ szz = szz + c1z*c2z;
+ end do
+
+ xc(1) = s1x/n;
+ xc(2) = s1y/n;
+ xc(3) = s1z/n;
+
+ yc(1) = s2x/n;
+ yc(2) = s2y/n;
+ yc(3) = s2z/n;
+ if(mode.eq.2.or.mode.eq.0) then ! need rmsd
+ do m=1, n
+ do i=1, 3
+ e0 = e0+ (x(i, m)-xc(i))**2 + (y(i, m)-yc(i))**2
+ end do
+ end do
+ endif
+
+ r(1, 1) = sxx-s1x*s2x/n;
+ r(2, 1) = sxy-s1x*s2y/n;
+ r(3, 1) = sxz-s1x*s2z/n;
+ r(1, 2) = syx-s1y*s2x/n;
+ r(2, 2) = syy-s1y*s2y/n;
+ r(3, 2) = syz-s1y*s2z/n;
+ r(1, 3) = szx-s1z*s2x/n;
+ r(2, 3) = szy-s1z*s2y/n;
+ r(3, 3) = szz-s1z*s2z/n;
+
+ det = r(1,1) * ( (r(2,2)*r(3,3)) - (r(2,3)*r(3,2)) )
+ & - r(1,2) * ( (r(2,1)*r(3,3)) - (r(2,3)*r(3,1)) )
+ & + r(1,3) * ( (r(2,1)*r(3,2)) - (r(2,2)*r(3,1)) )
+
+ sigma = det
+
+ m = 0
+ do j=1, 3
+ do i=1, j
+ m = m+1
+ rr(m) = r(1,i)*r(1,j) + r(2,i)*r(2,j) + r(3,i)*r(3,j)
+ end do
+ end do
+
+ spur = (rr(1)+rr(3)+rr(6)) / 3.0
+ cof = (((((rr(3)*rr(6) - rr(5)*rr(5)) + rr(1)*rr(6))
+ & - rr(4)*rr(4)) + rr(1)*rr(3)) - rr(2)*rr(2)) / 3.0
+ det = det*det
+
+ do i=1, 3
+ e(i) = spur
+ end do
+ if( spur .le. zero ) goto 40
+ d = spur*spur
+ h = d - cof
+ g = (spur*cof - det)/2.0 - spur*h
+ if( h .le. zero ) then
+ if( mode .eq. 0 ) then
+ goto 50
+ else
+ goto 30
+ end if
+ end if
+ sqrth = dsqrt(h)
+ d = h*h*h - g*g
+ if( d .lt. zero ) d = zero
+ d = datan2( dsqrt(d), -g ) / 3.0
+ cth = sqrth * dcos(d)
+ sth = sqrth*sqrt3*dsin(d)
+ e(1) = (spur + cth) + cth
+ e(2) = (spur - cth) + sth
+ e(3) = (spur - cth) - sth
+
+ if( mode .eq. 0 ) then
+ goto 50
+ end if
+
+ do l=1, 3, 2
+ d = e(l)
+ ss(1) = (d-rr(3)) * (d-rr(6)) - rr(5)*rr(5)
+ ss(2) = (d-rr(6)) * rr(2) + rr(4)*rr(5)
+ ss(3) = (d-rr(1)) * (d-rr(6)) - rr(4)*rr(4)
+ ss(4) = (d-rr(3)) * rr(4) + rr(2)*rr(5)
+ ss(5) = (d-rr(1)) * rr(5) + rr(2)*rr(4)
+ ss(6) = (d-rr(1)) * (d-rr(3)) - rr(2)*rr(2)
+
+ if( dabs(ss(1)) .ge. dabs(ss(3)) ) then
+ j=1
+ if( dabs(ss(1)) .lt. dabs(ss(6)) ) j = 3
+ else if( dabs(ss(3)) .ge. dabs(ss(6)) ) then
+ j = 2
+ else
+ j = 3
+ end if
+
+ d = zero
+ j = 3 * (j - 1)
+
+ do i=1, 3
+ k = ip(i+j)
+ a(i,l) = ss(k)
+ d = d + ss(k)*ss(k)
+ end do
+ if( d .gt. zero ) d = 1.0 / dsqrt(d)
+ do i=1, 3
+ a(i,l) = a(i,l) * d
+ end do
+ end do
+
+ d = a(1,1)*a(1,3) + a(2,1)*a(2,3) + a(3,1)*a(3,3)
+ if ((e(1) - e(2)) .gt. (e(2) - e(3))) then
+ m1 = 3
+ m = 1
+ else
+ m1 = 1
+ m = 3
+ endif
+
+ p = zero
+ do i=1, 3
+ a(i,m1) = a(i,m1) - d*a(i,m)
+ p = p + a(i,m1)**2
+ end do
+ if( p .le. tol ) then
+ p = 1.0
+ do 21 i=1, 3
+ if (p .lt. dabs(a(i,m))) goto 21
+ p = dabs( a(i,m) )
+ j = i
+ 21 continue
+ k = ip2312(j)
+ l = ip2312(j+1)
+ p = dsqrt( a(k,m)**2 + a(l,m)**2 )
+ if( p .le. tol ) goto 40
+ a(j,m1) = zero
+ a(k,m1) = -a(l,m)/p
+ a(l,m1) = a(k,m)/p
+ else
+ p = 1.0 / dsqrt(p)
+ do i=1, 3
+ a(i,m1) = a(i,m1)*p
+ end do
+ end if
+
+ a(1,2) = a(2,3)*a(3,1) - a(2,1)*a(3,3)
+ a(2,2) = a(3,3)*a(1,1) - a(3,1)*a(1,3)
+ a(3,2) = a(1,3)*a(2,1) - a(1,1)*a(2,3)
+
+ 30 do l=1, 2
+ d = zero
+ do i=1, 3
+ b(i,l) = r(i,1)*a(1,l) + r(i,2)*a(2,l) + r(i,3)*a(3,l)
+ d = d + b(i,l)**2
+ end do
+ if( d .gt. zero ) d = 1.0 / dsqrt(d)
+ do i=1, 3
+ b(i,l) = b(i,l)*d
+ end do
+ end do
+ d = b(1,1)*b(1,2) + b(2,1)*b(2,2) + b(3,1)*b(3,2)
+ p = zero
+
+ do i=1, 3
+ b(i,2) = b(i,2) - d*b(i,1)
+ p = p + b(i,2)**2
+ end do
+ if( p .le. tol ) then
+ p = 1.0
+ do 22 i=1, 3
+ if(p.lt.dabs(b(i,1)))goto 22
+ p = dabs( b(i,1) )
+ j = i
+ 22 continue
+ k = ip2312(j)
+ l = ip2312(j+1)
+ p = dsqrt( b(k,1)**2 + b(l,1)**2 )
+ if( p .le. tol ) goto 40
+ b(j,2) = zero
+ b(k,2) = -b(l,1)/p
+ b(l,2) = b(k,1)/p
+ else
+ p = 1.0 / dsqrt(p)
+ do i=1, 3
+ b(i,2) = b(i,2)*p
+ end do
+ end if
+
+ b(1,3) = b(2,1)*b(3,2) - b(2,2)*b(3,1)
+ b(2,3) = b(3,1)*b(1,2) - b(3,2)*b(1,1)
+ b(3,3) = b(1,1)*b(2,2) - b(1,2)*b(2,1)
+
+ do i=1, 3
+ do j=1, 3
+ u(i,j) = b(i,1)*a(j,1) + b(i,2)*a(j,2) + b(i,3)*a(j,3)
+ end do
+ end do
+
+ 40 do i=1, 3
+ t(i) = ((yc(i) - u(i,1)*xc(1)) - u(i,2)*xc(2)) - u(i,3)*xc(3)
+ end do
+ 50 do i=1, 3
+ if( e(i) .lt. zero ) e(i) = zero
+ e(i) = dsqrt( e(i) )
+ end do
+
+ ier = 0
+ if( e(2) .le. (e(1) * 1.0d-05) ) ier = -1
+
+ d = e(3)
+ if( sigma .lt. 0.0 ) then
+ d = - d
+ if( (e(2) - e(3)) .le. (e(1) * 1.0d-05) ) ier = -1
+ end if
+ d = (d + e(2)) + e(1)
+
+ if(mode .eq. 2.or.mode.eq.0) then ! need rmsd
+ rms = (e0 - d) - d
+ if( rms .lt. 0.0 ) rms = 0.0
+ endif
+
+ 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(X,1.0D0)*PI)
+ RETURN
+ 1 ARCOS=DACOS(X)
+ RETURN
+ END
--- /dev/null
+ subroutine cartprint
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ 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 '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 '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)=vbl
+ c(2,2)=0.0D0
+ c(3,2)=0.0D0
+ dc(1,1)=vbl
+ 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)=vbl*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 'COMMON.CHAIN'
+ include 'COMMON.LOCAL'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ include 'COMMON.INTERACT'
+C
+C Define the rotation matrices corresponding to CA(i)
+C
+ theti=theta(i)
+ phii=phi(i)
+ cost=dcos(theti)
+ sint=dsin(theti)
+ cosphi=dcos(phii)
+ sinphi=dsin(phii)
+* Define the matrices of the rotation about the virtual-bond valence angles
+* theta, T(i,j,k), virtual-bond dihedral angles gamma (miscalled PHI in this
+* program), R(i,j,k), and, the cumulative matrices of rotation RT
+ t(1,1,i-2)=-cost
+ t(1,2,i-2)=-sint
+ t(1,3,i-2)= 0.0D0
+ t(2,1,i-2)=-sint
+ t(2,2,i-2)= cost
+ t(2,3,i-2)= 0.0D0
+ t(3,1,i-2)= 0.0D0
+ t(3,2,i-2)= 0.0D0
+ t(3,3,i-2)= 1.0D0
+ r(1,1,i-2)= 1.0D0
+ r(1,2,i-2)= 0.0D0
+ r(1,3,i-2)= 0.0D0
+ r(2,1,i-2)= 0.0D0
+ r(2,2,i-2)=-cosphi
+ r(2,3,i-2)= sinphi
+ r(3,1,i-2)= 0.0D0
+ r(3,2,i-2)= sinphi
+ r(3,3,i-2)= cosphi
+ rt(1,1,i-2)=-cost
+ rt(1,2,i-2)=-sint
+ rt(1,3,i-2)=0.0D0
+ rt(2,1,i-2)=sint*cosphi
+ rt(2,2,i-2)=-cost*cosphi
+ rt(2,3,i-2)=sinphi
+ rt(3,1,i-2)=-sint*sinphi
+ rt(3,2,i-2)=cost*sinphi
+ rt(3,3,i-2)=cosphi
+ call matmult(prod(1,1,i-2),rt(1,1,i-2),prod(1,1,i-1))
+ do j=1,3
+ dc_norm(j,i-1)=prod(j,1,i-1)
+ dc(j,i-1)=vbl*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 'COMMON.CHAIN'
+ include 'COMMON.LOCAL'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ include 'COMMON.INTERACT'
+ dimension xx(3)
+
+ dsci=dsc(iabs(itype(i)))
+ dsci_inv=dsc_inv(iabs(itype(i)))
+ alphi=alph(i)
+ omegi=omeg(i)
+ cosalphi=dcos(alphi)
+ sinalphi=dsin(alphi)
+ cosomegi=dcos(omegi)
+ sinomegi=dsin(omegi)
+ xp= dsci*cosalphi
+ yp= dsci*sinalphi*cosomegi
+ zp=-dsci*sinalphi*sinomegi
+* Now we have to rotate the coordinate system by 180-theta(i)/2 so as to get its
+* X-axis aligned with the vector DC(*,i)
+ theta2=pi-0.5D0*theta(i+1)
+ cost2=dcos(theta2)
+ sint2=dsin(theta2)
+ xx(1)= xp*cost2+yp*sint2
+ xx(2)=-xp*sint2+yp*cost2
+ xx(3)= zp
+cd print '(a3,i3,3f10.5,5x,3f10.5)',restyp(itype(i)),i,
+cd & xp,yp,zp,(xx(k),k=1,3)
+ do j=1,3
+ xloc(j,i)=xx(j)
+ enddo
+* Bring the SC vectors to the common coordinate system.
+ xx(1)=xloc(1,i)
+ xx(2)=xloc(2,i)*r(2,2,i-1)+xloc(3,i)*r(2,3,i-1)
+ xx(3)=xloc(2,i)*r(3,2,i-1)+xloc(3,i)*r(3,3,i-1)
+ do j=1,3
+ xrot(j,i)=xx(j)
+ enddo
+ do j=1,3
+ rj=0.0D0
+ do k=1,3
+ rj=rj+prod(j,k,i-1)*xx(k)
+ enddo
+ dc(j,nres+i)=rj
+ dc_norm(j,nres+i)=rj*dsci_inv
+ c(j,nres+i)=c(j,i)+rj
+ enddo
+ return
+ end
--- /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 contact(lprint,ncont,icont)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.FFIELD'
+ include 'COMMON.NAMES'
+ real*8 facont /1.569D0/ ! facont = (2/(1-sqrt(1-1/4)))**(1/6)
+ integer ncont,icont(2,maxcont)
+ logical lprint
+ ncont=0
+ kkk=3
+c print *,'nnt=',nnt,' nct=',nct
+ do i=nnt+kkk,nct
+ iti=iabs(itype(i))
+ do j=nnt,i-kkk
+ itj=iabs(itype(j))
+ if (ipot.ne.4) then
+c rcomp=sigmaii(iti,itj)+1.0D0
+ rcomp=facont*sigmaii(iti,itj)
+ else
+c rcomp=sigma(iti,itj)+1.0D0
+ rcomp=facont*sigma(iti,itj)
+ endif
+c rcomp=6.5D0
+c print *,'rcomp=',rcomp,' dist=',dist(nres+i,nres+j)
+ if (dist(nres+i,nres+j).lt.rcomp) then
+ ncont=ncont+1
+ icont(1,ncont)=i
+ icont(2,ncont)=j
+ 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)')
+ & i,restyp(it1),i1,restyp(it2),i2
+ enddo
+ endif
+ return
+ end
+c----------------------------------------------------------------------------
+ double precision function contact_fract(ncont,ncont_ref,
+ & icont,icont_ref)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ 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
--- /dev/null
+ subroutine geom_to_var(n,x)
+C
+C Transfer the geometry parameters to the variable array.
+C The positions of variables are as follows:
+C 1. Virtual-bond torsional angles: 1 thru nres-3
+C 2. Virtual-bond valence angles: nres-2 thru 2*nres-5
+C 3. The polar angles alpha of local SC orientation: 2*nres-4 thru
+C 2*nres-4+nside
+C 4. The torsional angles omega of SC orientation: 2*nres-4+nside+1
+C thru 2*nre-4+2*nside
+C
+ include 'DIMENSIONS'
+ include 'COMMON.VAR'
+ include 'COMMON.GEO'
+ include 'COMMON.CHAIN'
+ double precision x(n)
+cd print *,'nres',nres,' nphi',nphi,' ntheta',ntheta,' nvar',nvar
+ do i=4,nres
+ x(i-3)=phi(i)
+cd print *,i,i-3,phi(i)
+ enddo
+ if (n.eq.nphi) return
+ do i=3,nres
+ x(i-2+nphi)=theta(i)
+cd print *,i,i-2+nphi,theta(i)
+ enddo
+ if (n.eq.nphi+ntheta) return
+ do i=2,nres-1
+ if (ialph(i,1).gt.0) then
+ x(ialph(i,1))=alph(i)
+ x(ialph(i,1)+nside)=omeg(i)
+cd print *,i,ialph(i,1),ialph(i,1)+nside,alph(i),omeg(i)
+ endif
+ enddo
+ return
+ end
+C--------------------------------------------------------------------
+ subroutine var_to_geom(n,x)
+C
+C Update geometry parameters according to the variable array.
+C
+ include 'DIMENSIONS'
+ include 'COMMON.VAR'
+ include 'COMMON.CHAIN'
+ dimension x(n)
+ do i=4,nres
+ phi(i)=pinorm(x(i-3))
+ enddo
+ if (n.eq.nphi) return
+ do i=3,nres
+ theta(i)=x(i-2+nphi)
+ enddo
+ if (n.eq.nphi+ntheta) return
+ do i=1,nside
+ alph(ialph(i,2))=x(nphi+ntheta+i)
+ omeg(ialph(i,2))=pinorm(x(nphi+ntheta+nside+i))
+ 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 '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(*,'(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 etotal(energia,fact)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+
+#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'
+ include 'COMMON.SAXS'
+ 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
+C Calculate electrostatic (H-bonding) energy of the main chain.
+C
+ 106 continue
+c write (iout,*) "Sidechain"
+ call flush(iout)
+ 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 call flush(iout)
+
+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,*) "NSAXS",nsaxs
+ 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,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
+ 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
+
+#ifdef SPLITELE
+ if (shield_mode.gt.0) then
+ etot=fact(1)*wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
+ & +welec*fact(1)*ees
+ & +fact(1)*wvdwpp*evdw1
+ & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
+ & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
+ & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
+ & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
+ & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
+ & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
+ & +wliptran*eliptran+wsaxs*esaxs_constr+ehomology_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+ehomology_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+ehomology_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+ehomology_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 '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.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.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
+c do i=1,210
+c do j=1,2
+c eneps_temp(j,i)=0.0d0
+c enddo
+c enddo
+cROZNICA
+
+ evdw=0.0D0
+ evdw_t=0.0d0
+ do i=iatsc_s,iatsc_e
+ itypi=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
+c eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
+c eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
+c
+
+cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
+cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
+cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
+cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
+cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
+cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
+ if (bb.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.COMPAR"
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ 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
+c do i=1,210
+c do j=1,2
+c eneps_temp(j,i)=0.0d0
+c enddo
+c 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)
+c eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
+c & /dabs(eps(itypi,itypj))
+c 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.COMPAR"
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.NAMES'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CALC'
+ common /srutu/ icall
+c double precision rrsave(maxdim)
+ logical lprn
+ integer icant
+ external icant
+c do i=1,210
+c do j=1,2
+c eneps_temp(j,i)=0.0d0
+c enddo
+c 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
+c eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
+c & /dabs(eps(itypi,itypj))
+c 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.COMPAR"
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.NAMES'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CALC'
+ include 'COMMON.SBRIDGE'
+ logical lprn
+ common /srutu/icall
+ integer icant,xshift,yshift,zshift
+ external icant
+c do i=1,210
+c do j=1,2
+c eneps_temp(j,i)=0.0d0
+c enddo
+c 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
+c eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
+c & /dabs(eps(itypi,itypj))
+c 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 (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.COMPAR"
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.NAMES'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CALC'
+ common /srutu/ icall
+ logical lprn
+ integer icant
+ external icant
+c do i=1,210
+c do j=1,2
+c eneps_temp(j,i)=0.0d0
+c enddo
+c 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
+c eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
+c & /dabs(eps(itypi,itypj))
+c 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 '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 '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 '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)
+c write(iout,*) "i",i," iti",iti
+c write(iout,*) 'b1=',(b1(k,i-2),k=1,2)
+c write(iout,*) 'b2=',(b2(k,i-2),k=1,2)
+ 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 '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'
+c write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
+c call flush(iout)
+ 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'
+#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 '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 '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 '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 (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 '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
+ ggg=0.0d0
+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.
+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
+ 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.
+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
+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 '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--------------------------------------------------------------------------
+ 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 '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 '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 '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 '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 '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 '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 '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 '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 '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 '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)
+ & write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
+ & theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
+ enddo
+ return
+ end
+c---------------------------------------------------------------------------------------------
+ subroutine etor_constr(edihcnstr)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ 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
+ 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 '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 '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 '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 '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 '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 '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 '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 '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 '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 '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 '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 '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 '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 '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 '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 '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 '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 '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 '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 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'
+#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)
+#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'
+#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
+C--------------------------------------------------------------------------
+c MODELLER restraint function
+ subroutine e_modeller(ehomology_constr)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ integer nnn, i, j, k, ki, irec, l
+ integer katy, odleglosci, test7
+ real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
+ real*8 distance(max_template),distancek(max_template),
+ & min_odl,godl(max_template),dih_diff(max_template)
+
+c
+c FP - 30/10/2014 Temporary specifications for homology restraints
+c
+ double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
+ & sgtheta
+ double precision, dimension (maxres) :: guscdiff,usc_diff
+ double precision, dimension (max_template) ::
+ & gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
+ & theta_diff
+
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.CHAIN'
+ include 'COMMON.GEO'
+ include 'COMMON.DERIV'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.VAR'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.HOMRESTR'
+ 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
--- /dev/null
+ subroutine etotal(energia,fact)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'sizesclu.dat'
+
+#ifndef ISNAN
+ external proc_proc
+#endif
+#ifdef WINPGI
+cMS$ATTRIBUTES C :: proc_proc
+#endif
+
+ include 'COMMON.IOUNITS'
+ double precision energia(0:max_ene),energia1(0:max_ene+1)
+#ifdef MPL
+ include 'COMMON.INFO'
+ external d_vadd
+ integer ready
+#endif
+ include 'COMMON.FFIELD'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.CHAIN'
+ include 'COMMON.SHIELD'
+ include 'COMMON.CONTROL'
+ double precision fact(6)
+cd write(iout, '(a,i2)')'Calling etotal ipot=',ipot
+cd print *,'nnt=',nnt,' nct=',nct
+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
+C Calculate electrostatic (H-bonding) energy of the main chain.
+C
+ 106 continue
+C write(iout,*) "shield_mode",shield_mode,ethetacnstr
+ if (shield_mode.eq.1) then
+ call set_shield_fac
+ else if (shield_mode.eq.2) then
+ call set_shield_fac2
+ endif
+ call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
+C
+C Calculate excluded-volume interaction energy between peptide groups
+C and side chains.
+C
+ call escp(evdw2,evdw2_14)
+c
+c Calculate the bond-stretching energy
+c
+ call ebond(estr)
+c write (iout,*) "estr",estr
+C
+C Calculate the disulfide-bridge and other energy and the contributions
+C from other distance constraints.
+cd print *,'Calling EHPB'
+ call edis(ehpb)
+cd print *,'EHPB exitted succesfully.'
+C
+C Calculate the virtual-bond-angle energy.
+C
+ call ebend(ebe,ethetacnstr)
+cd print *,'Bend energy finished.'
+C
+C Calculate the SC local energy.
+C
+ call esc(escloc)
+cd print *,'SCLOC energy finished.'
+C
+C Calculate the virtual-bond torsional energy.
+C
+cd print *,'nterm=',nterm
+ call etor(etors,edihcnstr,fact(1))
+C
+C 6/23/01 Calculate double-torsional energy
+C
+ call etor_d(etors_d,fact(2))
+C
+C 21/5/07 Calculate local sicdechain correlation energy
+C
+ call eback_sc_corr(esccor)
+
+ 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 print *,"calling multibody_eello"
+ call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
+c write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
+c print *,ecorr,ecorr5,ecorr6,eturn6
+ else
+ ecorr=0.0d0
+ ecorr5=0.0d0
+ ecorr6=0.0d0
+ eturn6=0.0d0
+ endif
+ if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
+ call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
+ endif
+ write (iout,*) "ft(6)",fact(6),wliptran,eliptran
+#ifdef SPLITELE
+ if (shield_mode.gt.0) then
+ etot=fact(1)*wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
+ & +welec*fact(1)*ees
+ & +fact(1)*wvdwpp*evdw1
+ & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
+ & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
+ & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
+ & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
+ & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
+ & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
+ & +wliptran*eliptran
+ else
+ etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
+ & +wvdwpp*evdw1
+ & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
+ & +wstrain*ehpb+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
+ 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
+ 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
+ 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(24)=ethetacnstr
+ energia(22)=eliptran
+c detecting NaNQ
+#ifdef ISNAN
+#ifdef AIX
+ if (isnan(etot).ne.0) energia(0)=1.0d+99
+#else
+ if (isnan(etot)) energia(0)=1.0d+99
+#endif
+#else
+ i=0
+#ifdef WINPGI
+ idumm=proc_proc(etot,i)
+#else
+ call proc_proc(etot,i)
+#endif
+ if(i.eq.1)energia(0)=1.0d+99
+#endif
+#ifdef MPL
+c endif
+#endif
+ if (calc_grad) then
+C
+C Sum up the components of the Cartesian gradient.
+C
+#ifdef SPLITELE
+ do i=1,nct
+ do j=1,3
+ 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)
+ gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
+ & wbond*gradbx(j,i)+
+ & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
+ & wsccor*fact(2)*gsccorx(j,i)
+ & +wliptran*gliptranx(j,i)
+ else
+ gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)
+ & +fact(1)*wscp*gvdwc_scp(j,i)+
+ & welec*fact(1)*gelc(j,i)+fact(1)*wvdwpp*gvdwpp(j,i)+
+ & wbond*gradb(j,i)+
+ & wstrain*ghpbc(j,i)+
+ & wcorr*fact(3)*gradcorr(j,i)+
+ & wel_loc*fact(2)*gel_loc(j,i)+
+ & wturn3*fact(2)*gcorr3_turn(j,i)+
+ & wturn4*fact(3)*gcorr4_turn(j,i)+
+ & wcorr5*fact(4)*gradcorr5(j,i)+
+ & wcorr6*fact(5)*gradcorr6(j,i)+
+ & wturn6*fact(5)*gcorr6_turn(j,i)+
+ & wsccor*fact(2)*gsccorc(j,i)
+ & +wliptran*gliptranc(j,i)
+ & +welec*gshieldc(j,i)
+ & +welec*gshieldc_loc(j,i)
+ & +wcorr*gshieldc_ec(j,i)
+ & +wcorr*gshieldc_loc_ec(j,i)
+ & +wturn3*gshieldc_t3(j,i)
+ & +wturn3*gshieldc_loc_t3(j,i)
+ & +wturn4*gshieldc_t4(j,i)
+ & +wturn4*gshieldc_loc_t4(j,i)
+ & +wel_loc*gshieldc_ll(j,i)
+ & +wel_loc*gshieldc_loc_ll(j,i)
+
+ gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)
+ & +fact(1)*wscp*gradx_scp(j,i)+
+ & wbond*gradbx(j,i)+
+ & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
+ & wsccor*fact(2)*gsccorx(j,i)
+ & +wliptran*gliptranx(j,i)
+ & +welec*gshieldx(j,i)
+ & +wcorr*gshieldx_ec(j,i)
+ & +wturn3*gshieldx_t3(j,i)
+ & +wturn4*gshieldx_t4(j,i)
+ & +wel_loc*gshieldx_ll(j,i)
+
+
+ endif
+ enddo
+#else
+ do i=1,nct
+ do 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)
+ 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)
+ gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+
+ & fact(1)*wscp*gradx_scp(j,i)+
+ & wbond*gradbx(j,i)+
+ & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
+ & wsccor*fact(1)*gsccorx(j,i)
+ & +wliptran*gliptranx(j,i)
+ endif
+ enddo
+#endif
+ enddo
+
+
+ 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 ROZNICA Z WHAMem
+ 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 'sizesclu.dat'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.FFIELD'
+ include 'COMMON.SBRIDGE'
+ double precision energia(0:max_ene),fact(6)
+ etot=energia(0)
+ evdw=energia(1)+fact(6)*energia(21)
+#ifdef SCP14
+ evdw2=energia(2)+energia(17)
+#else
+ evdw2=energia(2)
+#endif
+ ees=energia(3)
+#ifdef SPLITELE
+ evdw1=energia(16)
+#endif
+ ecorr=energia(4)
+ ecorr5=energia(5)
+ ecorr6=energia(6)
+ eel_loc=energia(7)
+ eello_turn3=energia(8)
+ eello_turn4=energia(9)
+ eello_turn6=energia(10)
+ ebe=energia(11)
+ escloc=energia(12)
+ etors=energia(13)
+ etors_d=energia(14)
+ ehpb=energia(15)
+ esccor=energia(19)
+ edihcnstr=energia(20)
+ estr=energia(18)
+ ethetacnstr=energia(24)
+#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,etot
+ 10 format (/'Virtual-chain energies:'//
+ & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
+ & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
+ & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
+ & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
+ & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
+ & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
+ & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
+ & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
+ & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
+ & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6,
+ & ' (SS bridges & dist. cnstr.)'/
+ & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
+ & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
+ & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
+ & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
+ & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
+ & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
+ & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
+ & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
+ & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
+ & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
+ & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
+ & 'ETOT= ',1pE16.6,' (total)')
+#else
+ write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
+ & ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
+ & ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
+ & ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
+ & eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
+ & eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
+ & edihcnstr,ethetacnstr,ebr*nss,etot
+ 10 format (/'Virtual-chain energies:'//
+ & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
+ & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
+ & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
+ & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
+ & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
+ & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
+ & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
+ & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
+ & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6,
+ & ' (SS bridges & dist. cnstr.)'/
+ & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
+ & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
+ & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
+ & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
+ & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
+ & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
+ & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
+ & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
+ & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
+ & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
+ & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
+ & 'ETOT= ',1pE16.6,' (total)')
+#endif
+ return
+ end
+C-----------------------------------------------------------------------
+ subroutine elj(evdw,evdw_t)
+C
+C This subroutine calculates the interaction energy of nonbonded side chains
+C assuming the LJ potential of interaction.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'sizesclu.dat'
+ 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.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 DODANE Z WHAM
+c do i=1,210
+c do j=1,2
+c eneps_temp(j,i)=0.0d0
+c enddo
+c enddo
+cROZNICA
+
+ evdw=0.0D0
+ evdw_t=0.0d0
+ do i=iatsc_s,iatsc_e
+ itypi=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 WHAM
+c eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
+c eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
+c
+
+cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
+cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
+cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
+cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
+cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
+cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
+ if (bb.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 'sizesclu.dat'
+ include "DIMENSIONS.COMPAR"
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ 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
+ 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)
+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 'sizesclu.dat'
+ 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.IOUNITS'
+ include 'COMMON.CALC'
+ common /srutu/ icall
+c double precision rrsave(maxdim)
+ logical lprn
+ integer icant
+ external icant
+ 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
+ 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
+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,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 'sizesclu.dat'
+ 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.IOUNITS'
+ include 'COMMON.CALC'
+ include 'COMMON.SBRIDGE'
+ logical lprn
+ common /srutu/icall
+ integer icant
+ external icant
+ integer xshift,yshift,zshift
+ logical energy_dec /.false./
+c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
+ evdw=0.0D0
+ evdw_t=0.0d0
+ 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)
+ 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
+
+c write(iout,*) "PRZED ZWYKLE", evdwij
+ call dyn_ssbond_ene(i,j,evdwij)
+c write(iout,*) "PO ZWYKLE", evdwij
+
+ evdw=evdw+evdwij
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
+ & 'evdw',i,j,evdwij,' ss'
+C triple bond artifac removal
+ do k=j+1,iend(i,iint)
+C search over all next residues
+ if (dyn_ss_mask(k)) then
+C check if they are cysteins
+C write(iout,*) 'k=',k
+
+c write(iout,*) "PRZED TRI", evdwij
+ evdwij_przed_tri=evdwij
+ call triple_ssbond_ene(i,j,k,evdwij)
+c if(evdwij_przed_tri.ne.evdwij) then
+c write (iout,*) "TRI:", evdwij, evdwij_przed_tri
+c endif
+
+c write(iout,*) "PO TRI", evdwij
+C call the energy function that removes the artifical triple disulfide
+C bond the soubroutine is located in ssMD.F
+ evdw=evdw+evdwij
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
+ & 'evdw',i,j,evdwij,'tss'
+ endif!dyn_ss_mask(k)
+ enddo! k
+ ELSE
+ ind=ind+1
+ itypj=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)
+ xj=mod(xj,boxxsize)
+ if (xj.lt.0) xj=xj+boxxsize
+ yj=mod(yj,boxysize)
+ if (yj.lt.0) yj=yj+boxysize
+ zj=mod(zj,boxzsize)
+ if (zj.lt.0) zj=zj+boxzsize
+ if ((zj.gt.bordlipbot)
+ &.and.(zj.lt.bordliptop)) then
+C the energy transfer exist
+ if (zj.lt.buflipbot) then
+C what fraction I am in
+ fracinbuf=1.0d0-
+ & ((zj-bordlipbot)/lipbufthick)
+C lipbufthick is thickenes of lipid buffore
+ sslipj=sscalelip(fracinbuf)
+ ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
+ elseif (zj.gt.bufliptop) then
+ fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
+ sslipj=sscalelip(fracinbuf)
+ ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
+ else
+ sslipj=1.0d0
+ ssgradlipj=0.0
+ endif
+ else
+ sslipj=0.0d0
+ ssgradlipj=0.0
+ endif
+ aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
+ & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
+ bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
+ & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
+C write(iout,*) "czy jest 0", bb-bb_lip(itypi,itypj),
+C & bb-bb_aq(itypi,itypj)
+ dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
+ xj_safe=xj
+ yj_safe=yj
+ zj_safe=zj
+ subchap=0
+ do xshift=-1,1
+ do yshift=-1,1
+ do zshift=-1,1
+ xj=xj_safe+xshift*boxxsize
+ yj=yj_safe+yshift*boxysize
+ zj=zj_safe+zshift*boxzsize
+ dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
+ if(dist_temp.lt.dist_init) then
+ dist_init=dist_temp
+ xj_temp=xj
+ yj_temp=yj
+ zj_temp=zj
+ subchap=1
+ endif
+ enddo
+ enddo
+ enddo
+ if (subchap.eq.1) then
+ xj=xj_temp-xi
+ yj=yj_temp-yi
+ zj=zj_temp-zi
+ else
+ xj=xj_safe-xi
+ yj=yj_safe-yi
+ zj=zj_safe-zi
+ endif
+ dxj=dc_norm(1,nres+j)
+ dyj=dc_norm(2,nres+j)
+ dzj=dc_norm(3,nres+j)
+c write (iout,*) i,j,xj,yj,zj
+ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
+ rij=dsqrt(rrij)
+ sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
+ sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
+ if (sss.le.0.0d0) cycle
+C Calculate angle-dependent terms of energy and contributions to their
+C derivatives.
+ call sc_angular
+ 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
+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
+C write (iout,'(2(a3,i3,2x),17(0pf7.3))')
+C & restyp(itypi),i,restyp(itypj),j,
+C & epsi,sigm,chi1,chi2,chip1,chip2,
+C & eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
+C & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
+C & evdwij
+ write (iout,*) "pratial sum", evdw,evdw_t,e1,e2,fac,aa
+#endif
+C#undef DEBUG
+c endif
+ if (calc_grad) then
+C Calculate gradient components.
+ 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
+ gg_lipi(3)=eps1*(eps2rt*eps2rt)
+ &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
+ & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
+ &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
+ gg_lipj(3)=ssgradlipj*gg_lipi(3)
+ gg_lipi(3)=gg_lipi(3)*ssgradlipi
+C Calculate the radial part of the gradient
+ gg(1)=xj*fac
+ gg(2)=yj*fac
+ gg(3)=zj*fac
+C Calculate angular part of the gradient.
+ call sc_grad
+ endif
+ 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 'sizesclu.dat'
+ 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.IOUNITS'
+ include 'COMMON.CALC'
+ common /srutu/ icall
+ logical lprn
+ integer icant
+ external icant
+ 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 returning the ith atom to box
+ xi=mod(xi,boxxsize)
+ if (xi.lt.0) xi=xi+boxxsize
+ yi=mod(yi,boxysize)
+ if (yi.lt.0) yi=yi+boxysize
+ zi=mod(zi,boxzsize)
+ if (zi.lt.0) zi=zi+boxzsize
+ if ((zi.gt.bordlipbot)
+ &.and.(zi.lt.bordliptop)) then
+C the energy transfer exist
+ if (zi.lt.buflipbot) then
+C what fraction I am in
+ fracinbuf=1.0d0-
+ & ((zi-bordlipbot)/lipbufthick)
+C lipbufthick is thickenes of lipid buffore
+ sslipi=sscalelip(fracinbuf)
+ ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
+ elseif (zi.gt.bufliptop) then
+ fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
+ sslipi=sscalelip(fracinbuf)
+ ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
+ else
+ sslipi=1.0d0
+ ssgradlipi=0.0
+ endif
+ else
+ sslipi=0.0d0
+ ssgradlipi=0.0
+ endif
+C
+C Calculate SC interaction energy.
+C
+ do iint=1,nint_gr(i)
+ do j=istart(i,iint),iend(i,iint)
+ ind=ind+1
+ itypj=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)
+ yj=c(2,nres+j)
+ zj=c(3,nres+j)
+C returning jth atom to box
+ xj=mod(xj,boxxsize)
+ if (xj.lt.0) xj=xj+boxxsize
+ yj=mod(yj,boxysize)
+ if (yj.lt.0) yj=yj+boxysize
+ zj=mod(zj,boxzsize)
+ if (zj.lt.0) zj=zj+boxzsize
+ if ((zj.gt.bordlipbot)
+ &.and.(zj.lt.bordliptop)) then
+C the energy transfer exist
+ if (zj.lt.buflipbot) then
+C what fraction I am in
+ fracinbuf=1.0d0-
+ & ((zj-bordlipbot)/lipbufthick)
+C lipbufthick is thickenes of lipid buffore
+ sslipj=sscalelip(fracinbuf)
+ ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
+ elseif (zj.gt.bufliptop) then
+ fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
+ sslipj=sscalelip(fracinbuf)
+ ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
+ else
+ sslipj=1.0d0
+ ssgradlipj=0.0
+ endif
+ else
+ sslipj=0.0d0
+ ssgradlipj=0.0
+ endif
+ aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
+ & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
+ bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
+ & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
+C write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
+C checking the distance
+ dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
+ xj_safe=xj
+ yj_safe=yj
+ zj_safe=zj
+ subchap=0
+C finding the closest
+ do xshift=-1,1
+ do yshift=-1,1
+ do zshift=-1,1
+ xj=xj_safe+xshift*boxxsize
+ yj=yj_safe+yshift*boxysize
+ zj=zj_safe+zshift*boxzsize
+ dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
+ if(dist_temp.lt.dist_init) then
+ dist_init=dist_temp
+ xj_temp=xj
+ yj_temp=yj
+ zj_temp=zj
+ subchap=1
+ endif
+ enddo
+ enddo
+ enddo
+ if (subchap.eq.1) then
+ xj=xj_temp-xi
+ yj=yj_temp-yi
+ zj=zj_temp-zi
+ else
+ xj=xj_safe-xi
+ yj=yj_safe-yi
+ zj=zj_safe-zi
+ endif
+ dxj=dc_norm(1,nres+j)
+ dyj=dc_norm(2,nres+j)
+ dzj=dc_norm(3,nres+j)
+ 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
+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 'sizesclu.dat'
+ 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)+gg_lipi(k)
+ & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
+ & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
+ gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipi(k)
+ & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
+ & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
+ enddo
+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)+gg_lipi(l)
+ enddo
+ enddo
+ do l=1,3
+ gvdwc(l,j)=gvdwc(l,j)+gg_lipj(l)
+ enddo
+ return
+ end
+c------------------------------------------------------------------------------
+ subroutine vec_and_deriv
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'sizesclu.dat'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.VECTORS'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
+C Compute the local reference systems. For reference system (i), the
+C X-axis points from CA(i) to CA(i+1), the Y axis is in the
+C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
+ do i=1,nres-1
+c if (i.eq.nres-1 .or. itel(i+1).eq.0) then
+ if (i.eq.nres-1) then
+C Case of the last full residue
+C Compute the Z-axis
+ call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
+ costh=dcos(pi-theta(nres))
+ fac=1.0d0/dsqrt(1.0d0-costh*costh)
+ do k=1,3
+ uz(k,i)=fac*uz(k,i)
+ enddo
+ if (calc_grad) then
+C Compute the derivatives of uz
+ uzder(1,1,1)= 0.0d0
+ uzder(2,1,1)=-dc_norm(3,i-1)
+ uzder(3,1,1)= dc_norm(2,i-1)
+ uzder(1,2,1)= dc_norm(3,i-1)
+ uzder(2,2,1)= 0.0d0
+ uzder(3,2,1)=-dc_norm(1,i-1)
+ uzder(1,3,1)=-dc_norm(2,i-1)
+ uzder(2,3,1)= dc_norm(1,i-1)
+ uzder(3,3,1)= 0.0d0
+ uzder(1,1,2)= 0.0d0
+ uzder(2,1,2)= dc_norm(3,i)
+ uzder(3,1,2)=-dc_norm(2,i)
+ uzder(1,2,2)=-dc_norm(3,i)
+ uzder(2,2,2)= 0.0d0
+ uzder(3,2,2)= dc_norm(1,i)
+ uzder(1,3,2)= dc_norm(2,i)
+ uzder(2,3,2)=-dc_norm(1,i)
+ uzder(3,3,2)= 0.0d0
+ endif
+C Compute the Y-axis
+ facy=fac
+ do k=1,3
+ uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
+ enddo
+ if (calc_grad) then
+C Compute the derivatives of uy
+ do j=1,3
+ do k=1,3
+ uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
+ & -dc_norm(k,i)*dc_norm(j,i-1)
+ uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
+ enddo
+ uyder(j,j,1)=uyder(j,j,1)-costh
+ uyder(j,j,2)=1.0d0+uyder(j,j,2)
+ enddo
+ do j=1,2
+ do k=1,3
+ do l=1,3
+ uygrad(l,k,j,i)=uyder(l,k,j)
+ uzgrad(l,k,j,i)=uzder(l,k,j)
+ enddo
+ enddo
+ enddo
+ call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
+ call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
+ call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
+ call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
+ endif
+ else
+C Other residues
+C Compute the Z-axis
+ call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
+ costh=dcos(pi-theta(i+2))
+ fac=1.0d0/dsqrt(1.0d0-costh*costh)
+ do k=1,3
+ uz(k,i)=fac*uz(k,i)
+ enddo
+ if (calc_grad) then
+C Compute the derivatives of uz
+ uzder(1,1,1)= 0.0d0
+ uzder(2,1,1)=-dc_norm(3,i+1)
+ uzder(3,1,1)= dc_norm(2,i+1)
+ uzder(1,2,1)= dc_norm(3,i+1)
+ uzder(2,2,1)= 0.0d0
+ uzder(3,2,1)=-dc_norm(1,i+1)
+ uzder(1,3,1)=-dc_norm(2,i+1)
+ uzder(2,3,1)= dc_norm(1,i+1)
+ uzder(3,3,1)= 0.0d0
+ uzder(1,1,2)= 0.0d0
+ uzder(2,1,2)= dc_norm(3,i)
+ uzder(3,1,2)=-dc_norm(2,i)
+ uzder(1,2,2)=-dc_norm(3,i)
+ uzder(2,2,2)= 0.0d0
+ uzder(3,2,2)= dc_norm(1,i)
+ uzder(1,3,2)= dc_norm(2,i)
+ uzder(2,3,2)=-dc_norm(1,i)
+ uzder(3,3,2)= 0.0d0
+ endif
+C Compute the Y-axis
+ facy=fac
+ do k=1,3
+ uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
+ enddo
+ if (calc_grad) then
+C Compute the derivatives of uy
+ do j=1,3
+ do k=1,3
+ uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
+ & -dc_norm(k,i)*dc_norm(j,i+1)
+ uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
+ enddo
+ uyder(j,j,1)=uyder(j,j,1)-costh
+ uyder(j,j,2)=1.0d0+uyder(j,j,2)
+ enddo
+ do j=1,2
+ do k=1,3
+ do l=1,3
+ uygrad(l,k,j,i)=uyder(l,k,j)
+ uzgrad(l,k,j,i)=uzder(l,k,j)
+ enddo
+ enddo
+ enddo
+ call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
+ call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
+ call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
+ call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
+ endif
+ endif
+ enddo
+ if (calc_grad) then
+ do i=1,nres-1
+ vbld_inv_temp(1)=vbld_inv(i+1)
+ if (i.lt.nres-1) then
+ vbld_inv_temp(2)=vbld_inv(i+2)
+ else
+ vbld_inv_temp(2)=vbld_inv(i)
+ endif
+ do j=1,2
+ do k=1,3
+ do l=1,3
+ uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
+ uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
+ enddo
+ enddo
+ enddo
+ enddo
+ endif
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine vec_and_deriv_test
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'sizesclu.dat'
+ 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 'sizesclu.dat'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.VECTORS'
+ dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
+ dimension uyt(3,maxres),uzt(3,maxres)
+ dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
+ double precision delta /1.0d-7/
+ call vec_and_deriv
+cd do i=1,nres
+crc write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
+crc write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
+crc write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
+cd write(iout,'(2i5,2(3f10.5,5x))') i,1,
+cd & (dc_norm(if90,i),if90=1,3)
+cd write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
+cd write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
+cd write(iout,'(a)')
+cd enddo
+ do i=1,nres
+ do j=1,2
+ do k=1,3
+ do l=1,3
+ uygradt(l,k,j,i)=uygrad(l,k,j,i)
+ uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
+ enddo
+ enddo
+ enddo
+ enddo
+ call vec_and_deriv
+ do i=1,nres
+ do j=1,3
+ uyt(j,i)=uy(j,i)
+ uzt(j,i)=uz(j,i)
+ enddo
+ enddo
+ do i=1,nres
+cd write (iout,*) 'i=',i
+ do k=1,3
+ erij(k)=dc_norm(k,i)
+ enddo
+ do j=1,3
+ do k=1,3
+ dc_norm(k,i)=erij(k)
+ enddo
+ dc_norm(j,i)=dc_norm(j,i)+delta
+c fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
+c do k=1,3
+c dc_norm(k,i)=dc_norm(k,i)/fac
+c enddo
+c write (iout,*) (dc_norm(k,i),k=1,3)
+c write (iout,*) (erij(k),k=1,3)
+ call vec_and_deriv
+ do k=1,3
+ uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
+ uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
+ uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
+ uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
+ enddo
+c write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
+c & j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
+c & (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
+ enddo
+ do k=1,3
+ dc_norm(k,i)=erij(k)
+ enddo
+cd do k=1,3
+cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
+cd & k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
+cd & (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
+cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
+cd & k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
+cd & (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
+cd write (iout,'(a)')
+cd enddo
+ enddo
+ return
+ end
+C--------------------------------------------------------------------------
+ subroutine set_matrices
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'sizesclu.dat'
+ 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. nnt+2 .and. i.lt.nct+2) then
+ if (itype(i-2).le.ntyp) then
+ iti = itortyp(itype(i-2))
+ else
+ iti=ntortyp+1
+ endif
+ else
+ iti=ntortyp+1
+ endif
+ if (i.gt. nnt+1 .and. i.lt.nct+1) then
+ if (itype(i-1).le.ntyp) then
+ iti1 = itortyp(itype(i-1))
+ else
+ iti1=ntortyp+1
+ endif
+ 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)
+c print *,"itilde1 i iti iti1",i,iti,iti1
+ 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
+c print *,"itilde2 i iti iti1",i,iti,iti1
+ 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))
+c print *,"itilde3 i iti iti1",i,iti,iti1
+ do k=1,2
+ muder(k,i-2)=Ub2der(k,i-2)
+ enddo
+ if (i.gt. nnt+1 .and. i.lt.nct+1) then
+ if (itype(i-1).le.ntyp) then
+ iti1 = itortyp(itype(i-1))
+ else
+ iti1=ntortyp+1
+ endif
+ 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 'sizesclu.dat'
+ 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.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)
+ 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
+C if (i.eq.1) then
+ if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1
+C & .or. itype(i+2).eq.ntyp1) cycle
+C else
+C if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
+C & .or. itype(i+2).eq.ntyp1
+C & .or. itype(i-1).eq.ntyp1
+ &) cycle
+C endif
+ 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
+ xmedi=mod(xmedi,boxxsize)
+ if (xmedi.lt.0) xmedi=xmedi+boxxsize
+ ymedi=mod(ymedi,boxysize)
+ if (ymedi.lt.0) ymedi=ymedi+boxysize
+ zmedi=mod(zmedi,boxzsize)
+ if (zmedi.lt.0) zmedi=zmedi+boxzsize
+ num_conti=0
+c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
+ do j=ielstart(i),ielend(i)
+C if (j.le.1) cycle
+C if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
+C & .or.itype(j+2).eq.ntyp1
+C &) cycle
+C else
+ if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
+C & .or.itype(j+2).eq.ntyp1
+C & .or.itype(j-1).eq.ntyp1
+ &) cycle
+C endif
+ 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
+ yj=c(2,j)+0.5D0*dyj
+ zj=c(3,j)+0.5D0*dzj
+ xj=mod(xj,boxxsize)
+ if (xj.lt.0) xj=xj+boxxsize
+ yj=mod(yj,boxysize)
+ if (yj.lt.0) yj=yj+boxysize
+ zj=mod(zj,boxzsize)
+ if (zj.lt.0) zj=zj+boxzsize
+ dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
+ xj_safe=xj
+ yj_safe=yj
+ zj_safe=zj
+ isubchap=0
+ do xshift=-1,1
+ do yshift=-1,1
+ do zshift=-1,1
+ xj=xj_safe+xshift*boxxsize
+ yj=yj_safe+yshift*boxysize
+ zj=zj_safe+zshift*boxzsize
+ dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
+ if(dist_temp.lt.dist_init) then
+ dist_init=dist_temp
+ xj_temp=xj
+ yj_temp=yj
+ zj_temp=zj
+ isubchap=1
+ endif
+ enddo
+ enddo
+ enddo
+ if (isubchap.eq.1) then
+ xj=xj_temp-xmedi
+ yj=yj_temp-ymedi
+ zj=zj_temp-zmedi
+ else
+ xj=xj_safe-xmedi
+ yj=yj_safe-ymedi
+ zj=zj_safe-zmedi
+ endif
+
+ rij=xj*xj+yj*yj+zj*zj
+ sss=sscale(sqrt(rij))
+ sssgrad=sscagrad(sqrt(rij))
+ rrmij=1.0D0/rij
+ rij=dsqrt(rij)
+ rmij=1.0D0/rij
+ 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)
+ if (shield_mode.gt.0) then
+C fac_shield(i)=0.4
+C fac_shield(j)=0.6
+C#define DEBUG
+#ifdef DEBUG
+ write(iout,*) "ees_compon",i,j,el1,el2,
+ & fac_shield(i),fac_shield(j)
+#endif
+C#undef DEBUG
+ el1=el1*fac_shield(i)**2*fac_shield(j)**2
+ el2=el2*fac_shield(i)**2*fac_shield(j)**2
+ eesij=(el1+el2)
+ ees=ees+eesij
+ else
+ fac_shield(i)=1.0
+ fac_shield(j)=1.0
+ eesij=(el1+el2)
+ ees=ees+eesij
+ endif
+C ees=ees+eesij
+ evdw1=evdw1+evdwij*sss
+cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
+cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
+cd & 1.0D0/dsqrt(rrmij),evdwij,eesij,
+cd & xmedi,ymedi,zmedi,xj,yj,zj
+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
+ if (calc_grad) then
+*
+* Radial derivatives. First process both termini of the fragment (i,j)
+*
+ ggg(1)=facel*xj
+ ggg(2)=facel*yj
+ ggg(3)=facel*zj
+
+ if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
+ & (shield_mode.gt.0)) then
+C print *,i,j
+ do ilist=1,ishield_list(i)
+ iresshield=shield_list(ilist,i)
+ do k=1,3
+ rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
+ & *2.0
+ gshieldx(k,iresshield)=gshieldx(k,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
+ gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
+C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
+C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
+C if (iresshield.gt.i) then
+C do ishi=i+1,iresshield-1
+C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
+C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
+C
+C enddo
+C else
+C do ishi=iresshield,i
+C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
+C & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
+C
+C enddo
+C endif
+C enddo
+C enddo
+ enddo
+ enddo
+ do ilist=1,ishield_list(j)
+ iresshield=shield_list(ilist,j)
+ do k=1,3
+ rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
+ & *2.0
+ gshieldx(k,iresshield)=gshieldx(k,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
+ gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
+ enddo
+ enddo
+
+ do k=1,3
+ gshieldc(k,i)=gshieldc(k,i)+
+ & grad_shield(k,i)*eesij/fac_shield(i)*2.0
+ gshieldc(k,j)=gshieldc(k,j)+
+ & grad_shield(k,j)*eesij/fac_shield(j)*2.0
+ gshieldc(k,i-1)=gshieldc(k,i-1)+
+ & grad_shield(k,i)*eesij/fac_shield(i)*2.0
+ gshieldc(k,j-1)=gshieldc(k,j-1)+
+ & grad_shield(k,j)*eesij/fac_shield(j)*2.0
+
+ enddo
+ endif
+
+ do k=1,3
+ ghalf=0.5D0*ggg(k)
+ gelc(k,i)=gelc(k,i)+ghalf
+ 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
+C ggg(1)=facvdw*xj
+C ggg(2)=facvdw*yj
+C ggg(3)=facvdw*zj
+ if (sss.gt.0.0) then
+ ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
+ ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
+ ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
+ else
+ ggg(1)=0.0
+ ggg(2)=0.0
+ ggg(3)=0.0
+ endif
+ do k=1,3
+ ghalf=0.5D0*ggg(k)
+ gvdwpp(k,i)=gvdwpp(k,i)+ghalf
+ gvdwpp(k,j)=gvdwpp(k,j)+ghalf
+ enddo
+*
+* Loop over residues i+1 thru j-1.
+*
+ do k=i+1,j-1
+ do l=1,3
+ gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
+ enddo
+ enddo
+#else
+ facvdw=(ev1+evdwij)*sss
+ facel=el1+eesij
+ fac1=fac
+ fac=-3*rrmij*(facvdw+facvdw+facel)
+ erij(1)=xj*rmij
+ erij(2)=yj*rmij
+ erij(3)=zj*rmij
+ if (calc_grad) then
+*
+* Radial derivatives. First process both termini of the fragment (i,j)
+*
+ ggg(1)=fac*xj
+ ggg(2)=fac*yj
+ ggg(3)=fac*zj
+ do k=1,3
+ ghalf=0.5D0*ggg(k)
+ gelc(k,i)=gelc(k,i)+ghalf
+ gelc(k,j)=gelc(k,j)+ghalf
+ enddo
+*
+* Loop over residues i+1 thru j-1.
+*
+ do k=i+1,j-1
+ do l=1,3
+ gelc(l,k)=gelc(l,k)+ggg(l)
+ enddo
+ enddo
+#endif
+*
+* Angular part
+*
+ ecosa=2.0D0*fac3*fac1+fac4
+ fac4=-3.0D0*fac4
+ fac3=-6.0D0*fac3
+ ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
+ ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
+ do k=1,3
+ dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
+ dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
+ enddo
+cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
+cd & (dcosg(k),k=1,3)
+ do k=1,3
+ ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
+ & *fac_shield(i)**2*fac_shield(j)**2
+ enddo
+ do k=1,3
+ ghalf=0.5D0*ggg(k)
+ gelc(k,i)=gelc(k,i)+ghalf
+ & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
+ & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
+ & *fac_shield(i)**2*fac_shield(j)**2
+
+ gelc(k,j)=gelc(k,j)+ghalf
+ & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
+ & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
+ & *fac_shield(i)**2*fac_shield(j)**2
+ enddo
+ do k=i+1,j-1
+ do l=1,3
+ 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)
+ if (shield_mode.eq.0) then
+ fac_shield(i)=1.0
+ fac_shield(j)=1.0
+C else
+C fac_shield(i)=0.4
+C fac_shield(j)=0.6
+ endif
+ eel_loc_ij=eel_loc_ij
+ & *fac_shield(i)*fac_shield(j)
+ eel_loc=eel_loc+eel_loc_ij
+C Partial derivatives in virtual-bond dihedral angles gamma
+ if (calc_grad) then
+ if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
+ & (shield_mode.gt.0)) then
+C print *,i,j
+
+ do ilist=1,ishield_list(i)
+ iresshield=shield_list(ilist,i)
+ do k=1,3
+ rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
+ & /fac_shield(i)
+C & *2.0
+ gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
+ gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
+ & +rlocshield
+ enddo
+ enddo
+ do ilist=1,ishield_list(j)
+ iresshield=shield_list(ilist,j)
+ do k=1,3
+ rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
+ & /fac_shield(j)
+C & *2.0
+ gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
+ gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
+ & +rlocshield
+
+ enddo
+ enddo
+ do k=1,3
+ gshieldc_ll(k,i)=gshieldc_ll(k,i)+
+ & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
+ gshieldc_ll(k,j)=gshieldc_ll(k,j)+
+ & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
+ gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
+ & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
+ gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
+ & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
+ enddo
+ endif
+ if (i.gt.1)
+ & gel_loc_loc(i-1)=gel_loc_loc(i-1)+
+ & a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
+ & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
+ & *fac_shield(i)*fac_shield(j)
+ gel_loc_loc(j-1)=gel_loc_loc(j-1)+
+ & a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
+ & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
+ & *fac_shield(i)*fac_shield(j)
+
+cd call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
+cd write(iout,*) 'agg ',agg
+cd write(iout,*) 'aggi ',aggi
+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)
+ & *fac_shield(i)*fac_shield(j)
+
+ 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)
+ & *fac_shield(i)*fac_shield(j)
+
+ gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
+ & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
+ & *fac_shield(i)*fac_shield(j)
+
+ gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
+ & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
+ & *fac_shield(i)*fac_shield(j)
+
+ gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
+ & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
+ & *fac_shield(i)*fac_shield(j)
+
+ enddo
+ endif
+ ENDIF
+ 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)
+ if (shield_mode.eq.0) then
+ fac_shield(i)=1.0d0
+ fac_shield(j)=1.0d0
+ else
+ ees0plist(num_conti,i)=j
+C fac_shield(i)=0.4d0
+C fac_shield(j)=0.6d0
+ endif
+c ees0mij=0.0D0
+ ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
+ & *fac_shield(i)*fac_shield(j)
+
+ ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
+ & *fac_shield(i)*fac_shield(j)
+
+C Diagnostics. Comment out or remove after debugging!
+c ees0p(num_conti,i)=0.5D0*fac3*ees0pij
+c ees0m(num_conti,i)=0.5D0*fac3*ees0mij
+c ees0m(num_conti,i)=0.0D0
+C End diagnostics.
+c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
+c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
+ facont_hb(num_conti,i)=fcont
+ if (calc_grad) then
+C Angular derivatives of the contact function
+ ees0pij1=fac3/ees0pij
+ ees0mij1=fac3/ees0mij
+ fac3p=-3.0D0*fac3*rrmij
+ ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
+ ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
+c ees0mij1=0.0D0
+ ecosa1= ees0pij1*( 1.0D0+0.5D0*wij)
+ ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
+ ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
+ ecosa2= ees0mij1*(-1.0D0+0.5D0*wij)
+ ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
+ ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
+ ecosap=ecosa1+ecosa2
+ ecosbp=ecosb1+ecosb2
+ ecosgp=ecosg1+ecosg2
+ ecosam=ecosa1-ecosa2
+ ecosbm=ecosb1-ecosb2
+ ecosgm=ecosg1-ecosg2
+C Diagnostics
+c ecosap=ecosa1
+c ecosbp=ecosb1
+c ecosgp=ecosg1
+c ecosam=0.0D0
+c ecosbm=0.0D0
+c ecosgm=0.0D0
+C End diagnostics
+ fprimcont=fprimcont/rij
+cd facont_hb(num_conti,i)=1.0D0
+C Following line is for diagnostics.
+cd fprimcont=0.0D0
+ do k=1,3
+ dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
+ dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
+ enddo
+ do k=1,3
+ gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
+ gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
+ enddo
+ gggp(1)=gggp(1)+ees0pijp*xj
+ gggp(2)=gggp(2)+ees0pijp*yj
+ gggp(3)=gggp(3)+ees0pijp*zj
+ gggm(1)=gggm(1)+ees0mijp*xj
+ gggm(2)=gggm(2)+ees0mijp*yj
+ gggm(3)=gggm(3)+ees0mijp*zj
+C Derivatives due to the contact function
+ gacont_hbr(1,num_conti,i)=fprimcont*xj
+ gacont_hbr(2,num_conti,i)=fprimcont*yj
+ gacont_hbr(3,num_conti,i)=fprimcont*zj
+ do k=1,3
+ ghalfp=0.5D0*gggp(k)
+ ghalfm=0.5D0*gggm(k)
+ gacontp_hb1(k,num_conti,i)=ghalfp
+ & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
+ & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
+ & *fac_shield(i)*fac_shield(j)
+
+ gacontp_hb2(k,num_conti,i)=ghalfp
+ & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
+ & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
+ & *fac_shield(i)*fac_shield(j)
+
+ gacontp_hb3(k,num_conti,i)=gggp(k)
+ & *fac_shield(i)*fac_shield(j)
+
+ gacontm_hb1(k,num_conti,i)=ghalfm
+ & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
+ & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
+ & *fac_shield(i)*fac_shield(j)
+
+ gacontm_hb2(k,num_conti,i)=ghalfm
+ & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
+ & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
+ & *fac_shield(i)*fac_shield(j)
+
+ gacontm_hb3(k,num_conti,i)=gggm(k)
+ & *fac_shield(i)*fac_shield(j)
+
+ enddo
+ endif
+C Diagnostics. Comment out or remove after debugging!
+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 'sizesclu.dat'
+ 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.SHIELD'
+ include 'COMMON.CONTROL'
+
+ dimension ggg(3)
+ double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
+ & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
+ & 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
+ if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
+C changes suggested by Ana to avoid out of bounds
+C & .or.((i+5).gt.nres)
+C & .or.((i-1).le.0)
+C end of changes suggested by Ana
+ & .or. itype(i+2).eq.ntyp1
+ & .or. itype(i+3).eq.ntyp1
+C & .or. itype(i+5).eq.ntyp1
+C & .or. itype(i).eq.ntyp1
+C & .or. itype(i-1).eq.ntyp1
+ & ) goto 179
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C Third-order contributions
+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))
+ if (shield_mode.eq.0) then
+ fac_shield(i)=1.0
+ fac_shield(j)=1.0
+C else
+C fac_shield(i)=0.4
+C fac_shield(j)=0.6
+ endif
+ eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
+ & *fac_shield(i)*fac_shield(j)
+ eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
+ & *fac_shield(i)*fac_shield(j)
+
+cd write (2,*) 'i,',i,' j',j,'eello_turn3',
+cd & 0.5d0*(pizda(1,1)+pizda(2,2)),
+cd & ' eello_turn3_num',4*eello_turn3_num
+ if (calc_grad) then
+C Derivatives in shield mode
+ if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
+ & (shield_mode.gt.0)) then
+C print *,i,j
+
+ do ilist=1,ishield_list(i)
+ iresshield=shield_list(ilist,i)
+ do k=1,3
+ rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
+C & *2.0
+ gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
+ gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
+ & +rlocshield
+ enddo
+ enddo
+ do ilist=1,ishield_list(j)
+ iresshield=shield_list(ilist,j)
+ do k=1,3
+ rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
+C & *2.0
+ gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
+ gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
+ & +rlocshield
+
+ enddo
+ enddo
+
+ do k=1,3
+ gshieldc_t3(k,i)=gshieldc_t3(k,i)+
+ & grad_shield(k,i)*eello_t3/fac_shield(i)
+ gshieldc_t3(k,j)=gshieldc_t3(k,j)+
+ & grad_shield(k,j)*eello_t3/fac_shield(j)
+ gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
+ & grad_shield(k,i)*eello_t3/fac_shield(i)
+ gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
+ & grad_shield(k,j)*eello_t3/fac_shield(j)
+ enddo
+ endif
+
+C Derivatives in gamma(i)
+ call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
+ call transpose2(auxmat2(1,1),pizda(1,1))
+ call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
+ gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
+ & *fac_shield(i)*fac_shield(j)
+
+C Derivatives in gamma(i+1)
+ call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
+ call transpose2(auxmat2(1,1),pizda(1,1))
+ call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
+ gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
+ & +0.5d0*(pizda(1,1)+pizda(2,2))
+ & *fac_shield(i)*fac_shield(j)
+
+C Cartesian derivatives
+ do l=1,3
+ a_temp(1,1)=aggi(l,1)
+ 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))
+ & *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(a_temp(1,1),auxmat1(1,1),pizda(1,1))
+ gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
+ & +0.5d0*(pizda(1,1)+pizda(2,2))
+ & *fac_shield(i)*fac_shield(j)
+
+ a_temp(1,1)=aggj(l,1)
+ a_temp(1,2)=aggj(l,2)
+ a_temp(2,1)=aggj(l,3)
+ 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))
+ & *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
+ 179 continue
+ else if (j.eq.i+3 .and. itype(i+2).ne.ntyp1) then
+ if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
+C changes suggested by Ana to avoid out of bounds
+C & .or.((i+5).gt.nres)
+C & .or.((i-1).le.0)
+C end of changes suggested by Ana
+ & .or. itype(i+3).eq.ntyp1
+ & .or. itype(i+4).eq.ntyp1
+C & .or. itype(i+5).eq.ntyp1
+ & .or. itype(i).eq.ntyp1
+C & .or. itype(i-1).eq.ntyp1
+ & ) goto 178
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C Fourth-order contributions
+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))
+ if (shield_mode.eq.0) then
+ fac_shield(i)=1.0
+ fac_shield(j)=1.0
+C else
+C fac_shield(i)=0.4
+C fac_shield(j)=0.6
+ endif
+ eello_turn4=eello_turn4-(s1+s2+s3)
+ & *fac_shield(i)*fac_shield(j)
+ eello_t4=-(s1+s2+s3)
+ & *fac_shield(i)*fac_shield(j)
+
+cd write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
+cd & ' eello_turn4_num',8*eello_turn4_num
+C Derivatives in gamma(i)
+ if (calc_grad) then
+ if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
+ & (shield_mode.gt.0)) then
+C print *,i,j
+
+ do ilist=1,ishield_list(i)
+ iresshield=shield_list(ilist,i)
+ do k=1,3
+ rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
+C & *2.0
+ gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
+ gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
+ & +rlocshield
+ enddo
+ enddo
+ do ilist=1,ishield_list(j)
+ iresshield=shield_list(ilist,j)
+ do k=1,3
+ rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
+C & *2.0
+ gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
+ gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
+ & +rlocshield
+
+ enddo
+ enddo
+
+ do k=1,3
+ gshieldc_t4(k,i)=gshieldc_t4(k,i)+
+ & grad_shield(k,i)*eello_t4/fac_shield(i)
+ gshieldc_t4(k,j)=gshieldc_t4(k,j)+
+ & grad_shield(k,j)*eello_t4/fac_shield(j)
+ gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
+ & grad_shield(k,i)*eello_t4/fac_shield(i)
+ gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
+ & grad_shield(k,j)*eello_t4/fac_shield(j)
+ enddo
+ endif
+
+ call transpose2(EUgder(1,1,i+1),e1tder(1,1))
+ call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
+ call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
+ 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)
+ & *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,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)
+ & *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,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)
+ & *fac_shield(i)*fac_shield(j)
+
+C Cartesian derivatives
+C Derivatives of this turn contributions in DC(i+2)
+ if (j.lt.nres-1) then
+ 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)
+ & *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,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)
+ & *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,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)
+ & *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,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)
+ & *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,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)
+ & *fac_shield(i)*fac_shield(j)
+
+ enddo
+ endif
+ 178 continue
+ 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 'sizesclu.dat'
+ 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,*) i,j,evdwij
+ evdw2=evdw2+evdwij*sss
+ if (calc_grad) then
+C
+C Calculate contributions to the gradient in the virtual-bond and SC vectors.
+C
+ fac=-(evdwij+e1)*rrij*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
+ 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 'sizesclu.dat'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.VAR'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTROL'
+ dimension ggg(3)
+ ehpb=0.0D0
+cd print *,'edis: nhpb=',nhpb,' fbr=',fbr
+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 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
+C call ssbond_ene(iii,jjj,eij)
+C ehpb=ehpb+2*eij
+C else
+ if (.not.dyn_ss .and. i.le.nss) then
+ if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
+ & iabs(itype(jjj)).eq.1) then
+ call ssbond_ene(iii,jjj,eij)
+ ehpb=ehpb+2*eij
+ endif !ii.gt.neres
+ else if (ii.gt.nres .and. jj.gt.nres) then
+c Restraints from contact prediction
+ dd=dist(ii,jj)
+ if (constr_dist.eq.11) then
+C ehpb=ehpb+fordepth(i)**4.0d0
+C & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
+ ehpb=ehpb+fordepth(i)**4.0d0
+ & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
+ fac=fordepth(i)**4.0d0
+ & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
+C write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
+C & ehpb,fordepth(i),dd
+C print *,"TUTU"
+C write(iout,*) ehpb,"atu?"
+C ehpb,"tu?"
+C fac=fordepth(i)**4.0d0
+C & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
+ else !constr_dist.eq.11
+ if (dhpb1(i).gt.0.0d0) then
+ ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
+ fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
+c write (iout,*) "beta nmr",
+c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
+ else !dhpb(i).gt.0.00
+
+C Calculate the distance between the two points and its difference from the
+C target distance.
+ dd=dist(ii,jj)
+ 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
+ endif !dhpb(i).gt.0
+ endif
+cd print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
+cd & ' waga=',waga,' fac=',fac
+ do j=1,3
+ ggg(j)=fac*(c(j,jj)-c(j,ii))
+ enddo
+cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
+C If this is a SC-SC distance, we need to calculate the contributions to the
+C Cartesian gradient in the SC vectors (ghpbx).
+ if (iii.lt.ii) then
+ do j=1,3
+ ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
+ ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
+ enddo
+ endif
+ else !ii.gt.nres
+C write(iout,*) "before"
+ dd=dist(ii,jj)
+C write(iout,*) "after",dd
+ if (constr_dist.eq.11) then
+ ehpb=ehpb+fordepth(i)**4.0d0
+ & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
+ fac=fordepth(i)**4.0d0
+ & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
+C ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
+C fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
+C print *,ehpb,"tu?"
+C write(iout,*) ehpb,"btu?",
+C & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
+C write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
+C & ehpb,fordepth(i),dd
+ else
+ if (dhpb1(i).gt.0.0d0) then
+ ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
+ fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
+c write (iout,*) "alph nmr",
+c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
+ else
+ rdis=dd-dhpb(i)
+C Get the force constant corresponding to this distance.
+ waga=forcon(i)
+C Calculate the contribution to energy.
+ ehpb=ehpb+waga*rdis*rdis
+c write (iout,*) "alpha reg",dd,waga*rdis*rdis
+C
+C Evaluate gradient.
+C
+ fac=waga*rdis/dd
+ endif
+ endif
+ do j=1,3
+ ggg(j)=fac*(c(j,jj)-c(j,ii))
+ enddo
+cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
+C If this is a SC-SC distance, we need to calculate the contributions to the
+C Cartesian gradient in the SC vectors (ghpbx).
+ if (iii.lt.ii) then
+ do j=1,3
+ ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
+ ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
+ enddo
+ endif
+ do j=iii,jjj-1
+ do k=1,3
+ ghpbc(k,j)=ghpbc(k,j)+ggg(k)
+ enddo
+ enddo
+ endif
+ enddo
+ if (constr_dist.ne.11) ehpb=0.5D0*ehpb
+ return
+ end
+C--------------------------------------------------------------------------
+ subroutine ssbond_ene(i,j,eij)
+C
+C Calculate the distance and angle dependent SS-bond potential energy
+C using a free-energy function derived based on RHF/6-31G** ab initio
+C calculations of diethyl disulfide.
+C
+C A. Liwo and U. Kozlowska, 11/24/03
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'sizesclu.dat'
+ 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--------------------------------------------------------------------------
+ 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 'sizesclu.dat'
+ 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'
+ logical energy_dec /.false./
+ double precision u(3),ud(3)
+ estr=0.0d0
+ estr1=0.0d0
+ do i=nnt+1,nct
+ if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
+C estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
+C do j=1,3
+C gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
+C & *dc(j,i-1)/vbld(i)
+C enddo
+C if (energy_dec) write(iout,*)
+C & "estr1",i,vbld(i),distchainmax,
+C & gnmr1(vbld(i),-1.0d0,distchainmax)
+C else
+ if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
+ diff = vbld(i)-vbldpDUM
+ else
+ diff = vbld(i)-vbldp0
+c write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
+ endif
+ estr=estr+diff*diff
+ do j=1,3
+ gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
+ enddo
+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 'sizesclu.dat'
+ 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
+ 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,'(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
+C Ufff.... We've done all this!!!
+C now constrains
+ ethetacnstr=0.0d0
+C print *,ithetaconstr_start,ithetaconstr_end,"TU"
+ do i=1,ntheta_constr
+ itheta=itheta_constr(i)
+ thetiii=theta(itheta)
+ difi=pinorm(thetiii-theta_constr0(i))
+ if (difi.gt.theta_drange(i)) then
+ difi=difi-theta_drange(i)
+ ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
+ gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
+ & +for_thet_constr(i)*difi**3
+ else if (difi.lt.-drange(i)) then
+ difi=difi+drange(i)
+ ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
+ gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
+ & +for_thet_constr(i)*difi**3
+ else
+ difi=0.0
+ endif
+C if (energy_dec) then
+C write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
+C & i,itheta,rad2deg*thetiii,
+C & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
+C & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
+C & gloc(itheta+nphi-2,icg)
+C endif
+ enddo
+ return
+ end
+C---------------------------------------------------------------------------
+ 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,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 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 'sizesclu.dat'
+ 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
+ if (i.le.2) cycle
+ if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
+ & .or.itype(i).eq.ntyp1) cycle
+c if (itype(i-1).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
+C now constrains
+ ethetacnstr=0.0d0
+C print *,ithetaconstr_start,ithetaconstr_end,"TU"
+ do i=1,ntheta_constr
+ itheta=itheta_constr(i)
+ thetiii=theta(itheta)
+ difi=pinorm(thetiii-theta_constr0(i))
+ if (difi.gt.theta_drange(i)) then
+ difi=difi-theta_drange(i)
+ ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
+ gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
+ & +for_thet_constr(i)*difi**3
+ else if (difi.lt.-drange(i)) then
+ difi=difi+drange(i)
+ ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
+ gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
+ & +for_thet_constr(i)*difi**3
+ else
+ difi=0.0
+ endif
+C if (energy_dec) then
+C write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
+C & i,itheta,rad2deg*thetiii,
+C & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
+C & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
+C & gloc(itheta+nphi-2,icg)
+C endif
+ enddo
+ return
+ end
+#endif
+#ifdef CRYST_SC
+c-----------------------------------------------------------------------------
+ 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 'sizesclu.dat'
+ 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.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)
+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,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 'sizesclu.dat'
+ 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))
+c zz1 = -dsin(alph(2))*dsin(omeg(2))
+ zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
+ write(2,'(3f8.1,3f9.3,1x,3f9.3)')
+ & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
+ & xx1,yy1,zz1
+C," --- ", xx_w,yy_w,zz_w
+c end diagnostics
+#endif
+ sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
+ & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
+ & + x(10)*yy*zz
+ sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
+ & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
+ & + x(20)*yy*zz
+ sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
+ & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
+ & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
+ & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
+ & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
+ & +x(40)*xx*yy*zz
+ sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
+ & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
+ & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
+ & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
+ & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
+ & +x(60)*xx*yy*zz
+ dsc_i = 0.743d0+x(61)
+ dp2_i = 1.9d0+x(62)
+ dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
+ & *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
+ dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
+ & *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
+ s1=(1+x(63))/(0.1d0 + dscp1)
+ s1_6=(1+x(64))/(0.1d0 + dscp1**6)
+ s2=(1+x(65))/(0.1d0 + dscp2)
+ s2_6=(1+x(65))/(0.1d0 + dscp2**6)
+ sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
+ & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
+c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
+c & sumene4,
+c & dscp1,dscp2,sumene
+c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
+ escloc = escloc + sumene
+c write (2,*) "escloc",escloc
+ if (.not. calc_grad) goto 1
+#ifdef DEBUG
+C
+C This section to check the numerical derivatives of the energy of ith side
+C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
+C #define DEBUG in the code to turn it on.
+C
+ write (2,*) "sumene =",sumene
+ aincr=1.0d-7
+ xxsave=xx
+ xx=xx+aincr
+ write (2,*) xx,yy,zz
+ sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
+ de_dxx_num=(sumenep-sumene)/aincr
+ xx=xxsave
+ write (2,*) "xx+ sumene from enesc=",sumenep
+ yysave=yy
+ yy=yy+aincr
+ write (2,*) xx,yy,zz
+ sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
+ de_dyy_num=(sumenep-sumene)/aincr
+ yy=yysave
+ write (2,*) "yy+ sumene from enesc=",sumenep
+ zzsave=zz
+ zz=zz+aincr
+ write (2,*) xx,yy,zz
+ sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
+ de_dzz_num=(sumenep-sumene)/aincr
+ zz=zzsave
+ write (2,*) "zz+ sumene from enesc=",sumenep
+ costsave=cost2tab(i+1)
+ sintsave=sint2tab(i+1)
+ cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
+ sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
+ sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
+ de_dt_num=(sumenep-sumene)/aincr
+ write (2,*) " t+ sumene from enesc=",sumenep
+ cost2tab(i+1)=costsave
+ sint2tab(i+1)=sintsave
+C End of diagnostics section.
+#endif
+C
+C Compute the gradient of esc
+C
+ pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
+ pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
+ pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
+ pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
+ pom_dx=dsc_i*dp2_i*cost2tab(i+1)
+ pom_dy=dsc_i*dp2_i*sint2tab(i+1)
+ pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
+ pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
+ pom1=(sumene3*sint2tab(i+1)+sumene1)
+ & *(pom_s1/dscp1+pom_s16*dscp1**4)
+ pom2=(sumene4*cost2tab(i+1)+sumene2)
+ & *(pom_s2/dscp2+pom_s26*dscp2**4)
+ sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
+ sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
+ & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
+ & +x(40)*yy*zz
+ sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
+ sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
+ & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
+ & +x(60)*yy*zz
+ de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
+ & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
+ & +(pom1+pom2)*pom_dx
+#ifdef DEBUG
+ write(2,*), "de_dxx = ", de_dxx,de_dxx_num
+#endif
+C
+ sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
+ sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
+ & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
+ & +x(40)*xx*zz
+ sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
+ sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
+ & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
+ & +x(59)*zz**2 +x(60)*xx*zz
+ de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
+ & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
+ & +(pom1-pom2)*pom_dy
+#ifdef DEBUG
+ write(2,*), "de_dyy = ", de_dyy,de_dyy_num
+#endif
+C
+ de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
+ & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
+ & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
+ & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6)
+ & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2
+ & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
+ & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
+ & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6)
+#ifdef DEBUG
+ write(2,*), "de_dzz = ", de_dzz,de_dzz_num
+#endif
+C
+ de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
+ & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
+ & +pom1*pom_dt1+pom2*pom_dt2
+#ifdef DEBUG
+ write(2,*), "de_dt = ", de_dt,de_dt_num
+#endif
+c
+C
+ cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
+ cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
+ cosfac2xx=cosfac2*xx
+ sinfac2yy=sinfac2*yy
+ do k = 1,3
+ dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
+ & vbld_inv(i+1)
+ dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
+ & vbld_inv(i)
+ pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
+ pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
+c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
+c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
+c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
+c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
+ dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
+ dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
+ dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
+ dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
+ dZZ_Ci1(k)=0.0d0
+ dZZ_Ci(k)=0.0d0
+ do j=1,3
+ dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
+ & *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 'sizesclu.dat'
+ include 'COMMON.VAR'
+ include 'COMMON.GEO'
+ thetup=pi-delta
+ thetlow=delta
+ if (theti.gt.pipol) then
+ call gcont(theti,thetup,1.0d0,delta,ss,ssder)
+ else
+ call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
+ ssder=-ssder
+ endif
+ return
+ end
+c------------------------------------------------------------------------------
+ subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
+ implicit none
+ double precision x,x0,delta,f0,f1,fprim0,f,fprim
+ double precision ksi,ksi2,ksi3,a1,a2,a3
+ a1=fprim0*delta/(f1-f0)
+ a2=3.0d0-2.0d0*a1
+ a3=a1-2.0d0
+ ksi=(x-x0)/delta
+ ksi2=ksi*ksi
+ ksi3=ksi2*ksi
+ f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
+ fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
+ return
+ end
+c------------------------------------------------------------------------------
+ subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
+ implicit none
+ double precision x,x0,delta,f0x,f1x,fprim0x,fx
+ double precision ksi,ksi2,ksi3,a1,a2,a3
+ ksi=(x-x0)/delta
+ ksi2=ksi*ksi
+ ksi3=ksi2*ksi
+ a1=fprim0x*delta
+ a2=3*(f1x-f0x)-2*fprim0x*delta
+ a3=fprim0x*delta-2*(f1x-f0x)
+ fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
+ return
+ end
+C-----------------------------------------------------------------------------
+#ifdef CRYST_TOR
+C-----------------------------------------------------------------------------
+ subroutine etor(etors,edihcnstr,fact)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'sizesclu.dat'
+ 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
+! 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(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
+ endif
+! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
+! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
+ enddo
+! write (iout,*) 'edihcnstr',edihcnstr
+ return
+ end
+c------------------------------------------------------------------------------
+#else
+ subroutine etor(etors,edihcnstr,fact)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'sizesclu.dat'
+ 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
+ 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
+ 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
+! 6/20/98 - dihedral angle constraints
+ edihcnstr=0.0d0
+ do i=1,ndih_constr
+ itori=idih_constr(i)
+ phii=phi(itori)
+ difi=pinorm(phii-phi0(i))
+ edihi=0.0d0
+ if (difi.gt.drange(i)) then
+ difi=difi-drange(i)
+ edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
+ gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
+ edihi=0.25d0*ftors(i)*difi**4
+ else if (difi.lt.-drange(i)) then
+ difi=difi+drange(i)
+ edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
+ gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
+ edihi=0.25d0*ftors(i)*difi**4
+ else
+ difi=0.0d0
+ endif
+c write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
+c & drange(i),edihi
+! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
+! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
+ enddo
+! write (iout,*) 'edihcnstr',edihcnstr
+ return
+ end
+c----------------------------------------------------------------------------
+ subroutine etor_d(etors_d,fact2)
+C 6/23/01 Compute double torsional energy
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'sizesclu.dat'
+ 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
+ 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------------------------------------------------------------------------------
+ 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 'sizesclu.dat'
+ 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
+c gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
+ enddo
+c write (iout,*) "EBACK_SC_COR",i,esccor,intertyp
+c gloc_sc(intertyp,i-3)=gloc_sc(intertyp,i-3)+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)
+ 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------------------------------------------------------------------------------
+#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,ntyp,maxres,7),
+ & facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres),
+ & num_cont_hb(maxres),jcont_hb(ntyp,maxres)
+ num_kont=buffer(1,indx+26)
+ num_kont_old=num_cont_hb(atom)
+ num_cont_hb(atom)=num_kont+num_kont_old
+ 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 'sizesclu.dat'
+ 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 'sizesclu.dat'
+ 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'
+ include 'COMMON.SHIELD'
+
+ 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
+ if (shield_mode.gt.0) then
+ j=ees0plist(jj,i)
+ l=ees0plist(kk,k)
+C print *,i,j,fac_shield(i),fac_shield(j),
+C &fac_shield(k),fac_shield(l)
+ if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
+ & (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
+ do ilist=1,ishield_list(i)
+ iresshield=shield_list(ilist,i)
+ do m=1,3
+ rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
+C & *2.0
+ gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
+ gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
+ &+rlocshield
+ enddo
+ enddo
+ do ilist=1,ishield_list(j)
+ iresshield=shield_list(ilist,j)
+ do m=1,3
+ rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
+C & *2.0
+ gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
+ gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
+ & +rlocshield
+ enddo
+ enddo
+ do ilist=1,ishield_list(k)
+ iresshield=shield_list(ilist,k)
+ do m=1,3
+ rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
+C & *2.0
+ gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
+ gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
+ & +rlocshield
+ enddo
+ enddo
+ do ilist=1,ishield_list(l)
+ iresshield=shield_list(ilist,l)
+ do m=1,3
+ rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
+C & *2.0
+ gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
+ gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
+ & +rlocshield
+ enddo
+ enddo
+C print *,gshieldx(m,iresshield)
+ do m=1,3
+ gshieldc_ec(m,i)=gshieldc_ec(m,i)+
+ & grad_shield(m,i)*ehbcorr/fac_shield(i)
+ gshieldc_ec(m,j)=gshieldc_ec(m,j)+
+ & grad_shield(m,j)*ehbcorr/fac_shield(j)
+ gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
+ & grad_shield(m,i)*ehbcorr/fac_shield(i)
+ gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
+ & grad_shield(m,j)*ehbcorr/fac_shield(j)
+
+ gshieldc_ec(m,k)=gshieldc_ec(m,k)+
+ & grad_shield(m,k)*ehbcorr/fac_shield(k)
+ gshieldc_ec(m,l)=gshieldc_ec(m,l)+
+ & grad_shield(m,l)*ehbcorr/fac_shield(l)
+ gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
+ & grad_shield(m,k)*ehbcorr/fac_shield(k)
+ gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
+ & grad_shield(m,l)*ehbcorr/fac_shield(l)
+
+ enddo
+ endif
+ endif
+ endif
+ ehbcorr=ekont*ees
+ return
+ end
+C---------------------------------------------------------------------------
+ subroutine dipole(i,j,jj)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'sizesclu.dat'
+ 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
+ if (itype(j).le.ntyp) then
+ itj1 = itortyp(itype(j+1))
+ else
+ itj1=ntortyp+1
+ endif
+ 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 'sizesclu.dat'
+ 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.
+c if (i.gt.1) then
+ if (i.gt.1 .and. itype(i).le.ntyp) then
+ iti=itortyp(itype(i))
+ else
+ iti=ntortyp+1
+ endif
+ itk1=itortyp(itype(k+1))
+ itj=itortyp(itype(j))
+c if (l.lt.nres-1) then
+ if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
+ itl1=itortyp(itype(l+1))
+ else
+ itl1=ntortyp+1
+ 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.
+c if (i.gt.1) then
+ if (i.gt.1 .and. itype(i).le.ntyp) then
+ iti=itortyp(itype(i))
+ else
+ iti=ntortyp+1
+ endif
+ itk1=itortyp(itype(k+1))
+ itl=itortyp(itype(l))
+ itj=itortyp(itype(j))
+c if (j.lt.nres-1) then
+ if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
+ itj1=itortyp(itype(j+1))
+ else
+ itj1=ntortyp+1
+ endif
+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 'sizesclu.dat'
+ 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 'sizesclu.dat'
+ 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 'sizesclu.dat'
+ 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 'sizesclu.dat'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.TORSION'
+ include 'COMMON.VAR'
+ include 'COMMON.GEO'
+ double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
+ logical swap
+ logical lprn
+ common /kutas/ lprn
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C C
+C Parallel Antiparallel C
+C C
+C o o C
+C /l\ /j\ C
+C / \ / \ C
+C /| o | | o |\ C
+C \ j|/k\| / \ |/k\|l / C
+C \ / \ / \ / \ / C
+C o o o o C
+C i i C
+C C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ itk=itortyp(itype(k))
+ s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
+ s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
+ s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
+ call transpose2(EUgC(1,1,k),auxmat(1,1))
+ call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
+ vv1(1)=pizda1(1,1)-pizda1(2,2)
+ vv1(2)=pizda1(1,2)+pizda1(2,1)
+ s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
+ vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
+ vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
+ s5=scalar2(vv(1),Dtobr2(1,i))
+cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
+ eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
+ if (.not. calc_grad) return
+ if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
+ & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
+ & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
+ & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
+ & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
+ & +scalar2(vv(1),Dtobr2der(1,i)))
+ call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
+ vv1(1)=pizda1(1,1)-pizda1(2,2)
+ vv1(2)=pizda1(1,2)+pizda1(2,1)
+ vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
+ vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
+ if (l.eq.j+1) then
+ g_corr6_loc(l-1)=g_corr6_loc(l-1)
+ & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
+ & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
+ & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
+ & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
+ else
+ g_corr6_loc(j-1)=g_corr6_loc(j-1)
+ & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
+ & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
+ & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
+ & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
+ endif
+ call transpose2(EUgCder(1,1,k),auxmat(1,1))
+ call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
+ vv1(1)=pizda1(1,1)-pizda1(2,2)
+ vv1(2)=pizda1(1,2)+pizda1(2,1)
+ if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
+ & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
+ & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
+ & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
+ do iii=1,2
+ if (swap) then
+ ind=3-iii
+ else
+ ind=iii
+ endif
+ do kkk=1,5
+ do lll=1,3
+ s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
+ s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
+ s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
+ call transpose2(EUgC(1,1,k),auxmat(1,1))
+ call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
+ & pizda1(1,1))
+ vv1(1)=pizda1(1,1)-pizda1(2,2)
+ vv1(2)=pizda1(1,2)+pizda1(2,1)
+ s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
+ vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
+ & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
+ vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
+ & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
+ s5=scalar2(vv(1),Dtobr2(1,i))
+ derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
+ enddo
+ enddo
+ enddo
+ return
+ end
+c----------------------------------------------------------------------------
+ double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'sizesclu.dat'
+ 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
+ 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 'sizesclu.dat'
+ 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))
+c if (j.lt.nres-1) then
+ if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
+ itj1=itortyp(itype(j+1))
+ else
+ itj1=ntortyp+1
+ endif
+ itk=itortyp(itype(k))
+ itk1=itortyp(itype(k+1))
+c if (l.lt.nres-1) then
+ if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
+ itl1=itortyp(itype(l+1))
+ else
+ itl1=ntortyp+1
+ 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 'sizesclu.dat'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.TORSION'
+ include 'COMMON.VAR'
+ include 'COMMON.GEO'
+ include 'COMMON.FFIELD'
+ double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
+ & auxvec1(2),auxmat1(2,2)
+ logical swap
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C C
+C Parallel Antiparallel C
+C C
+C o o C
+C /l\ / \ /j\ C
+C / \ / \ / \ C
+C /| o |o o| o |\ C
+C \ j|/k\| \ |/k\|l C
+C \ / \ \ / \ C
+C o \ o \ C
+C i i C
+C C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C 4/7/01 AL Component s1 was removed, because it pertains to the respective
+C energy moment and not to the cluster cumulant.
+cd write (2,*) 'eello_graph4: wturn6',wturn6
+ iti=itortyp(itype(i))
+ itj=itortyp(itype(j))
+c if (j.lt.nres-1) then
+ if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
+ itj1=itortyp(itype(j+1))
+ else
+ itj1=ntortyp+1
+ endif
+ itk=itortyp(itype(k))
+c if (k.lt.nres-1) then
+ if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then
+ itk1=itortyp(itype(k+1))
+ else
+ itk1=ntortyp+1
+ 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 'sizesclu.dat'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.TORSION'
+ include 'COMMON.VAR'
+ include 'COMMON.GEO'
+ double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
+ & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
+ & ggg1(3),ggg2(3)
+ double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
+ & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
+C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
+C the respective energy moment and not to the cluster cumulant.
+ eello_turn6=0.0d0
+ j=i+4
+ k=i+1
+ l=i+3
+ iti=itortyp(itype(i))
+ itk=itortyp(itype(k))
+ itk1=itortyp(itype(k+1))
+ itl=itortyp(itype(l))
+ itj=itortyp(itype(j))
+cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
+cd write (2,*) 'i',i,' k',k,' j',j,' l',l
+cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
+cd eello6=0.0d0
+cd return
+cd endif
+cd write (iout,*)
+cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
+cd & ' and',k,l
+cd call checkint_turn6(i,jj,kk,eel_turn6_num)
+ do iii=1,2
+ do kkk=1,5
+ do lll=1,3
+ derx_turn(lll,kkk,iii)=0.0d0
+ enddo
+ enddo
+ enddo
+cd eij=1.0d0
+cd ekl=1.0d0
+cd ekont=1.0d0
+ eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
+cd eello6_5=0.0d0
+cd write (2,*) 'eello6_5',eello6_5
+#ifdef MOMENT
+ call transpose2(AEA(1,1,1),auxmat(1,1))
+ call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
+ ss1=scalar2(Ub2(1,i+2),b1(1,itl))
+ s1 = (auxmat(1,1)+auxmat(2,2))*ss1
+#else
+ s1 = 0.0d0
+#endif
+ call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
+ call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
+ s2 = scalar2(b1(1,itk),vtemp1(1))
+#ifdef MOMENT
+ call transpose2(AEA(1,1,2),atemp(1,1))
+ call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
+ call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
+ s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
+#else
+ s8=0.0d0
+#endif
+ call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
+ call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
+ s12 = scalar2(Ub2(1,i+2),vtemp3(1))
+#ifdef MOMENT
+ call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
+ call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
+ call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
+ call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
+ ss13 = scalar2(b1(1,itk),vtemp4(1))
+ s13 = (gtemp(1,1)+gtemp(2,2))*ss13
+#else
+ s13=0.0d0
+#endif
+c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
+c s1=0.0d0
+c s2=0.0d0
+c s8=0.0d0
+c s12=0.0d0
+c s13=0.0d0
+ eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
+ if (calc_grad) then
+C Derivatives in gamma(i+2)
+#ifdef MOMENT
+ call transpose2(AEA(1,1,1),auxmatd(1,1))
+ call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
+ s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
+ call transpose2(AEAderg(1,1,2),atempd(1,1))
+ call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
+ s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
+#else
+ s8d=0.0d0
+#endif
+ call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
+ call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
+ s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
+c s1d=0.0d0
+c s2d=0.0d0
+c s8d=0.0d0
+c s12d=0.0d0
+c s13d=0.0d0
+ gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
+C Derivatives in gamma(i+3)
+#ifdef MOMENT
+ call transpose2(AEA(1,1,1),auxmatd(1,1))
+ call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
+ ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
+ s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
+#else
+ s1d=0.0d0
+#endif
+ call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
+ call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
+ s2d = scalar2(b1(1,itk),vtemp1d(1))
+#ifdef MOMENT
+ call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
+ s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
+#endif
+ s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
+#ifdef MOMENT
+ call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
+ call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
+ s13d = (gtempd(1,1)+gtempd(2,2))*ss13
+#else
+ s13d=0.0d0
+#endif
+c s1d=0.0d0
+c s2d=0.0d0
+c s8d=0.0d0
+c s12d=0.0d0
+c s13d=0.0d0
+#ifdef MOMENT
+ gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
+ & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
+#else
+ gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
+ & -0.5d0*ekont*(s2d+s12d)
+#endif
+C Derivatives in gamma(i+4)
+ call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
+ call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
+ s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
+#ifdef MOMENT
+ call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
+ call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
+ s13d = (gtempd(1,1)+gtempd(2,2))*ss13
+#else
+ s13d = 0.0d0
+#endif
+c s1d=0.0d0
+c s2d=0.0d0
+c s8d=0.0d0
+C s12d=0.0d0
+c s13d=0.0d0
+#ifdef MOMENT
+ gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
+#else
+ gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
+#endif
+C Derivatives in gamma(i+5)
+#ifdef MOMENT
+ call transpose2(AEAderg(1,1,1),auxmatd(1,1))
+ call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
+ s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
+#else
+ s1d = 0.0d0
+#endif
+ call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
+ call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
+ s2d = scalar2(b1(1,itk),vtemp1d(1))
+#ifdef MOMENT
+ call transpose2(AEA(1,1,2),atempd(1,1))
+ call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
+ s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
+#else
+ s8d = 0.0d0
+#endif
+ call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
+ s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
+#ifdef MOMENT
+ call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
+ ss13d = scalar2(b1(1,itk),vtemp4d(1))
+ s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
+#else
+ s13d = 0.0d0
+#endif
+c s1d=0.0d0
+c s2d=0.0d0
+c s8d=0.0d0
+c s12d=0.0d0
+c s13d=0.0d0
+#ifdef MOMENT
+ gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
+ & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
+#else
+ gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
+ & -0.5d0*ekont*(s2d+s12d)
+#endif
+C Cartesian derivatives
+ do iii=1,2
+ do kkk=1,5
+ do lll=1,3
+#ifdef MOMENT
+ call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
+ call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
+ s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
+#else
+ s1d = 0.0d0
+#endif
+ call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
+ call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
+ & vtemp1d(1))
+ s2d = scalar2(b1(1,itk),vtemp1d(1))
+#ifdef MOMENT
+ call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
+ call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
+ s8d = -(atempd(1,1)+atempd(2,2))*
+ & scalar2(cc(1,1,itl),vtemp2(1))
+#else
+ s8d = 0.0d0
+#endif
+ call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
+ & auxmatd(1,1))
+ call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
+ s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
+c s1d=0.0d0
+c s2d=0.0d0
+c s8d=0.0d0
+c s12d=0.0d0
+c s13d=0.0d0
+#ifdef MOMENT
+ derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
+ & - 0.5d0*(s1d+s2d)
+#else
+ derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
+ & - 0.5d0*s2d
+#endif
+#ifdef MOMENT
+ derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
+ & - 0.5d0*(s8d+s12d)
+#else
+ derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
+ & - 0.5d0*s12d
+#endif
+ enddo
+ enddo
+ enddo
+#ifdef MOMENT
+ do kkk=1,5
+ do lll=1,3
+ call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
+ & achuj_tempd(1,1))
+ call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
+ call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
+ s13d=(gtempd(1,1)+gtempd(2,2))*ss13
+ derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
+ call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
+ & vtemp4d(1))
+ ss13d = scalar2(b1(1,itk),vtemp4d(1))
+ s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
+ derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
+ enddo
+ enddo
+#endif
+cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
+cd & 16*eel_turn6_num
+cd goto 1112
+ if (j.lt.nres-1) then
+ j1=j+1
+ j2=j-1
+ else
+ j1=j-1
+ j2=j-2
+ endif
+ if (l.lt.nres-1) then
+ l1=l+1
+ l2=l-1
+ else
+ l1=l-1
+ l2=l-2
+ endif
+ do ll=1,3
+ ggg1(ll)=eel_turn6*g_contij(ll,1)
+ ggg2(ll)=eel_turn6*g_contij(ll,2)
+ ghalf=0.5d0*ggg1(ll)
+cd ghalf=0.0d0
+ gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
+ & +ekont*derx_turn(ll,2,1)
+ gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
+ gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
+ & +ekont*derx_turn(ll,4,1)
+ gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
+ ghalf=0.5d0*ggg2(ll)
+cd ghalf=0.0d0
+ gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
+ & +ekont*derx_turn(ll,2,2)
+ gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
+ gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
+ & +ekont*derx_turn(ll,4,2)
+ gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
+ enddo
+cd goto 1112
+ do m=i+1,j-1
+ do ll=1,3
+ gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
+ enddo
+ enddo
+ do m=k+1,l-1
+ do ll=1,3
+ gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
+ enddo
+ enddo
+1112 continue
+ do m=i+2,j2
+ do ll=1,3
+ gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
+ enddo
+ enddo
+ do m=k+2,l2
+ do ll=1,3
+ gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
+ enddo
+ enddo
+cd do iii=1,nres-3
+cd write (2,*) iii,g_corr6_loc(iii)
+cd enddo
+ endif
+ eello_turn6=ekont*eel_turn6
+cd write (2,*) 'ekont',ekont
+cd write (2,*) 'eel_turn6',ekont*eel_turn6
+ return
+ end
+crc-------------------------------------------------
+ SUBROUTINE MATVEC2(A1,V1,V2)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ DIMENSION A1(2,2),V1(2),V2(2)
+c DO 1 I=1,2
+c VI=0.0
+c DO 3 K=1,2
+c 3 VI=VI+A1(I,K)*V1(K)
+c Vaux(I)=VI
+c 1 CONTINUE
+
+ vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
+ vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
+
+ v2(1)=vaux1
+ v2(2)=vaux2
+ END
+C---------------------------------------
+ SUBROUTINE MATMAT2(A1,A2,A3)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ DIMENSION A1(2,2),A2(2,2),A3(2,2)
+c DIMENSION AI3(2,2)
+c DO J=1,2
+c A3IJ=0.0
+c DO K=1,2
+c A3IJ=A3IJ+A1(I,K)*A2(K,J)
+c enddo
+c A3(I,J)=A3IJ
+c enddo
+c enddo
+
+ ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
+ ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
+ ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
+ ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
+
+ A3(1,1)=AI3_11
+ A3(2,1)=AI3_21
+ A3(1,2)=AI3_12
+ A3(2,2)=AI3_22
+ END
+
+c-------------------------------------------------------------------------
+ double precision function scalar2(u,v)
+ implicit none
+ double precision u(2),v(2)
+ double precision sc
+ integer i
+ scalar2=u(1)*v(1)+u(2)*v(2)
+ return
+ end
+
+C-----------------------------------------------------------------------------
+
+ subroutine transpose2(a,at)
+ implicit none
+ double precision a(2,2),at(2,2)
+ at(1,1)=a(1,1)
+ at(1,2)=a(2,1)
+ at(2,1)=a(1,2)
+ at(2,2)=a(2,2)
+ return
+ end
+c--------------------------------------------------------------------------
+ subroutine transpose(n,a,at)
+ implicit none
+ integer n,i,j
+ double precision a(n,n),at(n,n)
+ do i=1,n
+ do j=1,n
+ at(j,i)=a(i,j)
+ enddo
+ enddo
+ return
+ end
+C---------------------------------------------------------------------------
+ subroutine prodmat3(a1,a2,kk,transp,prod)
+ implicit none
+ integer i,j
+ double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
+ logical transp
+crc double precision auxmat(2,2),prod_(2,2)
+
+ if (transp) then
+crc call transpose2(kk(1,1),auxmat(1,1))
+crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
+crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
+
+ prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
+ & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
+ prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
+ & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
+ prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
+ & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
+ prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
+ & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
+
+ else
+crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
+crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
+
+ prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
+ & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
+ prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
+ & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
+ prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
+ & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
+ prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
+ & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
+
+ endif
+c call transpose2(a2(1,1),a2t(1,1))
+
+crc print *,transp
+crc print *,((prod_(i,j),i=1,2),j=1,2)
+crc print *,((prod(i,j),i=1,2),j=1,2)
+
+ return
+ end
+C-----------------------------------------------------------------------------
+ double precision function scalar(u,v)
+ implicit none
+ double precision u(3),v(3)
+ double precision sc
+ integer i
+ sc=0.0d0
+ do i=1,3
+ sc=sc+u(i)*v(i)
+ enddo
+ scalar=sc
+ return
+ end
+C-----------------------------------------------------------------------
+ double precision function sscale(r)
+ double precision r,gamm
+ include "COMMON.SPLITELE"
+ if(r.lt.r_cut-rlamb) then
+ sscale=1.0d0
+ else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
+ gamm=(r-(r_cut-rlamb))/rlamb
+ sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
+ else
+ sscale=0d0
+ endif
+ return
+ end
+C-----------------------------------------------------------------------
+C-----------------------------------------------------------------------
+ double precision function sscagrad(r)
+ double precision r,gamm
+ include "COMMON.SPLITELE"
+ if(r.lt.r_cut-rlamb) then
+ sscagrad=0.0d0
+ else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
+ gamm=(r-(r_cut-rlamb))/rlamb
+ sscagrad=gamm*(6*gamm-6.0d0)/rlamb
+ else
+ sscagrad=0.0d0
+ endif
+ return
+ end
+C-----------------------------------------------------------------------
+C first for shielding is setting of function of side-chains
+ subroutine set_shield_fac2
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.SHIELD'
+ include 'COMMON.INTERACT'
+C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
+ double precision div77_81/0.974996043d0/,
+ &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
+
+C the vector between center of side_chain and peptide group
+ double precision pep_side(3),long,side_calf(3),
+ &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
+ &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
+C the line belowe needs to be changed for FGPROC>1
+ do i=1,nres-1
+ if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
+ ishield_list(i)=0
+Cif there two consequtive dummy atoms there is no peptide group between them
+C the line below has to be changed for FGPROC>1
+ VolumeTotal=0.0
+ do k=1,nres
+ if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
+ dist_pep_side=0.0
+ dist_side_calf=0.0
+ do j=1,3
+C first lets set vector conecting the ithe side-chain with kth side-chain
+ pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
+C pep_side(j)=2.0d0
+C and vector conecting the side-chain with its proper calfa
+ side_calf(j)=c(j,k+nres)-c(j,k)
+C side_calf(j)=2.0d0
+ pept_group(j)=c(j,i)-c(j,i+1)
+C lets have their lenght
+ dist_pep_side=pep_side(j)**2+dist_pep_side
+ dist_side_calf=dist_side_calf+side_calf(j)**2
+ dist_pept_group=dist_pept_group+pept_group(j)**2
+ enddo
+ dist_pep_side=dsqrt(dist_pep_side)
+ dist_pept_group=dsqrt(dist_pept_group)
+ dist_side_calf=dsqrt(dist_side_calf)
+ do j=1,3
+ pep_side_norm(j)=pep_side(j)/dist_pep_side
+ side_calf_norm(j)=dist_side_calf
+ enddo
+C now sscale fraction
+ sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
+C print *,buff_shield,"buff"
+C now sscale
+ if (sh_frac_dist.le.0.0) cycle
+C If we reach here it means that this side chain reaches the shielding sphere
+C Lets add him to the list for gradient
+ ishield_list(i)=ishield_list(i)+1
+C ishield_list is a list of non 0 side-chain that contribute to factor gradient
+C this list is essential otherwise problem would be O3
+ shield_list(ishield_list(i),i)=k
+C Lets have the sscale value
+ if (sh_frac_dist.gt.1.0) then
+ scale_fac_dist=1.0d0
+ do j=1,3
+ sh_frac_dist_grad(j)=0.0d0
+ enddo
+ else
+ scale_fac_dist=-sh_frac_dist*sh_frac_dist
+ & *(2.0d0*sh_frac_dist-3.0d0)
+ fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
+ & /dist_pep_side/buff_shield*0.5d0
+C remember for the final gradient multiply sh_frac_dist_grad(j)
+C for side_chain by factor -2 !
+ do j=1,3
+ sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
+C sh_frac_dist_grad(j)=0.0d0
+C scale_fac_dist=1.0d0
+C print *,"jestem",scale_fac_dist,fac_help_scale,
+C & sh_frac_dist_grad(j)
+ enddo
+ endif
+C this is what is now we have the distance scaling now volume...
+ short=short_r_sidechain(itype(k))
+ long=long_r_sidechain(itype(k))
+ costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
+ sinthet=short/dist_pep_side*costhet
+C now costhet_grad
+C costhet=0.6d0
+C sinthet=0.8
+ costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
+C sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
+C & -short/dist_pep_side**2/costhet)
+C costhet_fac=0.0d0
+ do j=1,3
+ costhet_grad(j)=costhet_fac*pep_side(j)
+ enddo
+C remember for the final gradient multiply costhet_grad(j)
+C for side_chain by factor -2 !
+C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
+C pep_side0pept_group is vector multiplication
+ pep_side0pept_group=0.0d0
+ do j=1,3
+ pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
+ enddo
+ cosalfa=(pep_side0pept_group/
+ & (dist_pep_side*dist_side_calf))
+ fac_alfa_sin=1.0d0-cosalfa**2
+ fac_alfa_sin=dsqrt(fac_alfa_sin)
+ rkprim=fac_alfa_sin*(long-short)+short
+C rkprim=short
+
+C now costhet_grad
+ cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
+C cosphi=0.6
+ cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
+ sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
+ & dist_pep_side**2)
+C sinphi=0.8
+ do j=1,3
+ cosphi_grad_long(j)=cosphi_fac*pep_side(j)
+ &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
+ &*(long-short)/fac_alfa_sin*cosalfa/
+ &((dist_pep_side*dist_side_calf))*
+ &((side_calf(j))-cosalfa*
+ &((pep_side(j)/dist_pep_side)*dist_side_calf))
+C cosphi_grad_long(j)=0.0d0
+ cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
+ &*(long-short)/fac_alfa_sin*cosalfa
+ &/((dist_pep_side*dist_side_calf))*
+ &(pep_side(j)-
+ &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
+C cosphi_grad_loc(j)=0.0d0
+ enddo
+C print *,sinphi,sinthet
+ VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
+ & /VSolvSphere_div
+C & *wshield
+C now the gradient...
+ do j=1,3
+ grad_shield(j,i)=grad_shield(j,i)
+C gradient po skalowaniu
+ & +(sh_frac_dist_grad(j)*VofOverlap
+C gradient po costhet
+ & +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
+ &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
+ & sinphi/sinthet*costhet*costhet_grad(j)
+ & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
+ & )*wshield
+C grad_shield_side is Cbeta sidechain gradient
+ grad_shield_side(j,ishield_list(i),i)=
+ & (sh_frac_dist_grad(j)*-2.0d0
+ & *VofOverlap
+ & -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
+ &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
+ & sinphi/sinthet*costhet*costhet_grad(j)
+ & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
+ & )*wshield
+
+ grad_shield_loc(j,ishield_list(i),i)=
+ & scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
+ &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
+ & sinthet/sinphi*cosphi*cosphi_grad_loc(j)
+ & ))
+ & *wshield
+ enddo
+ VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
+ enddo
+ fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
+C write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
+ enddo
+ return
+ end
+C first for shielding is setting of function of side-chains
+ subroutine set_shield_fac
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.SHIELD'
+ include 'COMMON.INTERACT'
+C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
+ double precision div77_81/0.974996043d0/,
+ &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
+
+C the vector between center of side_chain and peptide group
+ double precision pep_side(3),long,side_calf(3),
+ &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
+ &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
+C the line belowe needs to be changed for FGPROC>1
+ do i=1,nres-1
+ if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
+ ishield_list(i)=0
+Cif there two consequtive dummy atoms there is no peptide group between them
+C the line below has to be changed for FGPROC>1
+ VolumeTotal=0.0
+ do k=1,nres
+ if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
+ dist_pep_side=0.0
+ dist_side_calf=0.0
+ do j=1,3
+C first lets set vector conecting the ithe side-chain with kth side-chain
+ pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
+C pep_side(j)=2.0d0
+C and vector conecting the side-chain with its proper calfa
+ side_calf(j)=c(j,k+nres)-c(j,k)
+C side_calf(j)=2.0d0
+ pept_group(j)=c(j,i)-c(j,i+1)
+C lets have their lenght
+ dist_pep_side=pep_side(j)**2+dist_pep_side
+ dist_side_calf=dist_side_calf+side_calf(j)**2
+ dist_pept_group=dist_pept_group+pept_group(j)**2
+ enddo
+ dist_pep_side=dsqrt(dist_pep_side)
+ dist_pept_group=dsqrt(dist_pept_group)
+ dist_side_calf=dsqrt(dist_side_calf)
+ do j=1,3
+ pep_side_norm(j)=pep_side(j)/dist_pep_side
+ side_calf_norm(j)=dist_side_calf
+ enddo
+C now sscale fraction
+ sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
+C print *,buff_shield,"buff"
+C now sscale
+ if (sh_frac_dist.le.0.0) cycle
+C If we reach here it means that this side chain reaches the shielding sphere
+C Lets add him to the list for gradient
+ ishield_list(i)=ishield_list(i)+1
+C ishield_list is a list of non 0 side-chain that contribute to factor gradient
+C this list is essential otherwise problem would be O3
+ shield_list(ishield_list(i),i)=k
+C Lets have the sscale value
+ if (sh_frac_dist.gt.1.0) then
+ scale_fac_dist=1.0d0
+ do j=1,3
+ sh_frac_dist_grad(j)=0.0d0
+ enddo
+ else
+ scale_fac_dist=-sh_frac_dist*sh_frac_dist
+ & *(2.0*sh_frac_dist-3.0d0)
+ fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
+ & /dist_pep_side/buff_shield*0.5
+C remember for the final gradient multiply sh_frac_dist_grad(j)
+C for side_chain by factor -2 !
+ do j=1,3
+ sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
+C print *,"jestem",scale_fac_dist,fac_help_scale,
+C & sh_frac_dist_grad(j)
+ enddo
+ endif
+C if ((i.eq.3).and.(k.eq.2)) then
+C print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
+C & ,"TU"
+C endif
+
+C this is what is now we have the distance scaling now volume...
+ short=short_r_sidechain(itype(k))
+ long=long_r_sidechain(itype(k))
+ costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
+C now costhet_grad
+C costhet=0.0d0
+ costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
+C costhet_fac=0.0d0
+ do j=1,3
+ costhet_grad(j)=costhet_fac*pep_side(j)
+ enddo
+C remember for the final gradient multiply costhet_grad(j)
+C for side_chain by factor -2 !
+C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
+C pep_side0pept_group is vector multiplication
+ pep_side0pept_group=0.0
+ do j=1,3
+ pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
+ enddo
+ cosalfa=(pep_side0pept_group/
+ & (dist_pep_side*dist_side_calf))
+ fac_alfa_sin=1.0-cosalfa**2
+ fac_alfa_sin=dsqrt(fac_alfa_sin)
+ rkprim=fac_alfa_sin*(long-short)+short
+C now costhet_grad
+ cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
+ cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
+
+ do j=1,3
+ cosphi_grad_long(j)=cosphi_fac*pep_side(j)
+ &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
+ &*(long-short)/fac_alfa_sin*cosalfa/
+ &((dist_pep_side*dist_side_calf))*
+ &((side_calf(j))-cosalfa*
+ &((pep_side(j)/dist_pep_side)*dist_side_calf))
+
+ cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
+ &*(long-short)/fac_alfa_sin*cosalfa
+ &/((dist_pep_side*dist_side_calf))*
+ &(pep_side(j)-
+ &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
+ enddo
+
+ VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
+ & /VSolvSphere_div
+ & *wshield
+C now the gradient...
+C grad_shield is gradient of Calfa for peptide groups
+C write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
+C & costhet,cosphi
+C write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
+C & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
+ do j=1,3
+ grad_shield(j,i)=grad_shield(j,i)
+C gradient po skalowaniu
+ & +(sh_frac_dist_grad(j)
+C gradient po costhet
+ &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
+ &-scale_fac_dist*(cosphi_grad_long(j))
+ &/(1.0-cosphi) )*div77_81
+ &*VofOverlap
+C grad_shield_side is Cbeta sidechain gradient
+ grad_shield_side(j,ishield_list(i),i)=
+ & (sh_frac_dist_grad(j)*-2.0d0
+ & +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
+ & +scale_fac_dist*(cosphi_grad_long(j))
+ & *2.0d0/(1.0-cosphi))
+ & *div77_81*VofOverlap
+
+ grad_shield_loc(j,ishield_list(i),i)=
+ & scale_fac_dist*cosphi_grad_loc(j)
+ & *2.0d0/(1.0-cosphi)
+ & *div77_81*VofOverlap
+ enddo
+ VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
+ enddo
+ fac_shield(i)=VolumeTotal*div77_81+div4_81
+C write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
+ enddo
+ return
+ end
+C--------------------------------------------------------------------------
+C-----------------------------------------------------------------------
+ double precision function sscalelip(r)
+ double precision r,gamm
+ include "COMMON.SPLITELE"
+C if(r.lt.r_cut-rlamb) then
+C sscale=1.0d0
+C else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
+C gamm=(r-(r_cut-rlamb))/rlamb
+ sscalelip=1.0d0+r*r*(2*r-3.0d0)
+C else
+C sscale=0d0
+C endif
+ return
+ end
+C-----------------------------------------------------------------------
+ double precision function sscagradlip(r)
+ double precision r,gamm
+ include "COMMON.SPLITELE"
+C if(r.lt.r_cut-rlamb) then
+C sscagrad=0.0d0
+C else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
+C gamm=(r-(r_cut-rlamb))/rlamb
+ sscagradlip=r*(6*r-6.0d0)
+C else
+C sscagrad=0.0d0
+C endif
+ return
+ end
+
+C-----------------------------------------------------------------------
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ subroutine Eliptransfer(eliptran)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CALC'
+ include 'COMMON.CONTROL'
+ include 'COMMON.SPLITELE'
+ include 'COMMON.SBRIDGE'
+C this is done by Adasko
+C print *,"wchodze"
+C structure of box:
+C water
+C--bordliptop-- buffore starts
+C--bufliptop--- here true lipid starts
+C lipid
+C--buflipbot--- lipid ends buffore starts
+C--bordlipbot--buffore ends
+ eliptran=0.0
+ write(iout,*) "I am in?"
+ do i=1,nres
+C do i=1,1
+ if (itype(i).eq.ntyp1) cycle
+
+ positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
+ if (positi.le.0) positi=positi+boxzsize
+C print *,i
+C first for peptide groups
+c for each residue check if it is in lipid or lipid water border area
+ if ((positi.gt.bordlipbot)
+ &.and.(positi.lt.bordliptop)) then
+C the energy transfer exist
+ if (positi.lt.buflipbot) then
+C what fraction I am in
+ fracinbuf=1.0d0-
+ & ((positi-bordlipbot)/lipbufthick)
+C lipbufthick is thickenes of lipid buffore
+ sslip=sscalelip(fracinbuf)
+ ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
+ eliptran=eliptran+sslip*pepliptran
+ gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
+ gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
+C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
+ elseif (positi.gt.bufliptop) then
+ fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
+ sslip=sscalelip(fracinbuf)
+ ssgradlip=sscagradlip(fracinbuf)/lipbufthick
+ eliptran=eliptran+sslip*pepliptran
+ gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
+ gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
+C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
+C print *, "doing sscalefor top part"
+C print *,i,sslip,fracinbuf,ssgradlip
+ else
+ eliptran=eliptran+pepliptran
+C print *,"I am in true lipid"
+ endif
+C else
+C eliptran=elpitran+0.0 ! I am in water
+ endif
+ enddo
+C print *, "nic nie bylo w lipidzie?"
+C now multiply all by the peptide group transfer factor
+C eliptran=eliptran*pepliptran
+C now the same for side chains
+CV do i=1,1
+ do i=1,nres
+ if (itype(i).eq.ntyp1) cycle
+ positi=(mod(c(3,i+nres),boxzsize))
+ if (positi.le.0) positi=positi+boxzsize
+C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
+c for each residue check if it is in lipid or lipid water border area
+C respos=mod(c(3,i+nres),boxzsize)
+C print *,positi,bordlipbot,buflipbot
+ if ((positi.gt.bordlipbot)
+ & .and.(positi.lt.bordliptop)) then
+C the energy transfer exist
+ if (positi.lt.buflipbot) then
+ fracinbuf=1.0d0-
+ & ((positi-bordlipbot)/lipbufthick)
+C lipbufthick is thickenes of lipid buffore
+ sslip=sscalelip(fracinbuf)
+ ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
+ eliptran=eliptran+sslip*liptranene(itype(i))
+ gliptranx(3,i)=gliptranx(3,i)
+ &+ssgradlip*liptranene(itype(i))
+ gliptranc(3,i-1)= gliptranc(3,i-1)
+ &+ssgradlip*liptranene(itype(i))
+C print *,"doing sccale for lower part"
+ elseif (positi.gt.bufliptop) then
+ fracinbuf=1.0d0-
+ &((bordliptop-positi)/lipbufthick)
+ sslip=sscalelip(fracinbuf)
+ ssgradlip=sscagradlip(fracinbuf)/lipbufthick
+ eliptran=eliptran+sslip*liptranene(itype(i))
+ gliptranx(3,i)=gliptranx(3,i)
+ &+ssgradlip*liptranene(itype(i))
+ gliptranc(3,i-1)= gliptranc(3,i-1)
+ &+ssgradlip*liptranene(itype(i))
+C print *, "doing sscalefor top part",sslip,fracinbuf
+ else
+ eliptran=eliptran+liptranene(itype(i))
+C print *,"I am in true lipid"
+ endif
+ endif ! if in lipid or buffor
+C else
+C eliptran=elpitran+0.0 ! I am in water
+ enddo
+ return
+ end
+C-------------------------------------------------------------------------------------
--- /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(etot,rmsd,tytul)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.NAMES'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.HEADER'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.TEMPFAC'
+ character*50 tytul
+ character*1 chainid(10) /'A','B','C','D','E','F','G','H','I','J'/
+ dimension ica(maxres)
+ write (ipdb,'(3a,1pe15.5,a,0pf7.2)') 'REMARK ',tytul(:20),
+ & ' ENERGY ',etot,' RMS ',rmsd
+ 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),1.0d0,tempfac(1,i)
+ if (iti.ne.10) then
+ iatom=iatom+1
+ write (ipdb,20) iatom,restyp(iti),chainid(ichain),
+ & ires,(c(j,nres+i),j=1,3),1.0d0,tempfac(2,i)
+ 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
+ write (ipdb,30) ica(ihpb(i)-nres)+1,ica(jhpb(i)-nres)+1
+ enddo
+ write (ipdb,'(a6)') 'ENDMDL'
+ 10 FORMAT ('ATOM',I7,' CA ',A3,1X,A1,I4,4X,3F8.3,2f6.2)
+ 20 FORMAT ('ATOM',I7,' CB ',A3,1X,A1,I4,4X,3F8.3,2f6.2)
+ 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 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.NAMES'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.HEADER'
+ include 'COMMON.SBRIDGE'
+ character*32 tytul,fd
+ character*4 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,nct-nnt+1,0,0
+ write (imol2,'(a)') 'SMALL'
+ write (imol2,'(a)') 'USER_CHARGES'
+ write (imol2,'(a)') '@<TRIPOS>ATOM'
+ do i=nnt,nct
+c write (liczba,*) i
+ pom=ucase(restyp(itype(i)))
+c res_num = pom(:3)//liczba(2:)
+ write (imol2,10) i-nnt+1,(c(j,i),j=1,3),i-nnt+1,pom,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
+ write (imol2,'(i5,2i6,i2)') nct-nnt+i,ihpb(i),jhpb(i),1
+ enddo
+ write (imol2,'(a)') '@<TRIPOS>SUBSTRUCTURE'
+ do i=nnt,nct
+ write (liczba,'(i4)') i
+ pom = ucase(restyp(itype(i)))
+c res_num = pom(:3)//liczba(2:)
+ write (imol2,30) i-nnt+1,pom,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 '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,'(6a)') ' Res ',' Theta',' Phi',
+ & ' Dsc',' Alpha',' Omega'
+ do i=1,nres
+ iti=itype(i)
+ write (iout,'(a3,i4,5f10.3)') restyp(iti),i,rad2deg*theta(i),
+ & rad2deg*phi(i),dsc(iti),rad2deg*alph(i),rad2deg*omeg(i)
+ enddo
+ return
+ end
+c---------------------------------------------------------------------------
+ subroutine briefout(it,klasa,ener,free,nss,ihpb,jhpb,plik)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.NAMES'
+ include 'COMMON.GEO'
+ dimension ihpb(maxss),jhpb(maxss)
+ character*80 plik
+c print '(a,i5)',intname,igeom
+#ifdef AIX
+ open (igeom,file=plik,position='append')
+#else
+ open (igeom,file=plik,position='append')
+#endif
+ IF (NSS.LT.9) THEN
+ WRITE (igeom,180) IT,ENER,free,NSS,(IHPB(I),JHPB(I),I=1,NSS)
+ ELSE
+ WRITE (igeom,180) IT,ENER,free,NSS,(IHPB(I),JHPB(I),I=1,8)
+ write (igeom,'(a)')
+ WRITE (igeom,190) (IHPB(I),JHPB(I),I=9,NSS)
+ ENDIF
+ write (igeom,'(i10)') klasa
+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,2F12.3,I2,$,8(1X,2I3,$))
+ 190 format (3X,11(1X,2I3,$))
+ 200 format (8F10.4)
+ return
+ end
+c---------------------------------------------------------------------------
+ subroutine cartout(igr,i,etot,free,rmsd,plik)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'sizesclu.dat'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.NAMES'
+ include 'COMMON.GEO'
+ include 'COMMON.CLUSTER'
+ character*80 plik
+ open (igeom,file=plik,position='append')
+ write (igeom,'(2e15.5,f10.5,$)') etot,free,rmsd
+ write (igeom,'(i4,$)')
+ & nss_all(i),(ihpb_all(j,i),jhpb_all(j,i),j=1,nss_all(i))
+ write (igeom,'(i10)') iscore(i)
+ write (igeom,'(8f10.5)')
+ & ((allcart(k,j,i),k=1,3),j=1,nres),
+ & ((allcart(k,j+nres,i),k=1,3),j=nnt,nct)
+ 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---------------------------------------------------------------------------------
+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
+C*********************** Contents ****************************************
+C* Sample driver program, VAX-11 Fortran; **********************************
+C* HC: O(n^2) time, O(n^2) space hierarchical clustering, Fortran 77 *******
+C* HCASS: determine cluster-memberships, Fortran 77. ***********************
+C* HCDEN: draw upper part of dendrogram, VAX-11 Fortran. *******************
+C* Sample data set: last 36 lines. *****************************************
+C***************************************************************************
+C REAL DATA(18,16),CRIT(18),MEMBR(18)
+C REAL CRITVAL(9)
+C INTEGER IA(18),IB(18)
+C INTEGER ICLASS(18,9),HVALS(9)
+C INTEGER IORDER(9),HEIGHT(9)
+C DIMENSION NN(18),DISNN(18)
+C REAL D(153)
+C LOGICAL FLAG(18)
+C IN ABOVE, 18=N, 16=M, 9=LEV, 153=N(N-1)/2.
+C
+C
+C OPEN(UNIT=21,STATUS='OLD',FILE='SPECTR.DAT')
+C
+C
+C N = 18
+C M = 16
+C DO I=1,N
+C READ(21,100)(DATA(I,J),J=1,M)
+C ENDDO
+C 100 FORMAT(8F7.1)
+C
+C
+C LEN = (N*(N-1))/2
+C IOPT=1
+C CALL HC(N,M,LEN,IOPT,DATA,IA,IB,CRIT,MEMBR,NN,DISNN,FLAG,D)
+C
+C
+C LEV = 9
+C CALL HCASS(N,IA,IB,CRIT,LEV,ICLASS,HVALS,IORDER,CRITVAL,HEIGHT)
+C
+C
+C CALL HCDEN(LEV,IORDER,HEIGHT,CRITVAL)
+C
+C
+C END
+C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++C
+C C
+C HIERARCHICAL CLUSTERING using (user-specified) criterion. C
+C C
+C Parameters: C
+C C
+Cremoved DATA(N,M) input data matrix, C
+C DISS(LEN) dissimilarities in lower half diagonal C
+C storage; LEN = N.N-1/2, C
+C IOPT clustering criterion to be used, C
+C IA, IB, CRIT history of agglomerations; dimensions C
+C N, first N-1 locations only used, C
+C MEMBR, NN, DISNN vectors of length N, used to store C
+C cluster cardinalities, current nearest C
+C neighbour, and the dissimilarity assoc. C
+C with the latter. C
+C FLAG boolean indicator of agglomerable obj./ C
+C clusters. C
+C C
+C F. Murtagh, ESA/ESO/STECF, Garching, February 1986. C
+C C
+C------------------------------------------------------------C
+ SUBROUTINE HC(N,M,LEN,IOPT,IA,IB,CRIT,MEMBR,NN,DISNN,
+ X FLAG,DISS)
+ REAL MEMBR(N)
+ REAL DISS(LEN)
+ INTEGER IA(N),IB(N)
+ REAL CRIT(N)
+ DIMENSION NN(N),DISNN(N)
+ LOGICAL FLAG(N)
+ REAL INF
+ DATA INF/1.E+20/
+C
+C Initializations
+C
+ DO I=1,N
+ MEMBR(I)=1.
+ FLAG(I)=.TRUE.
+ ENDDO
+ NCL=N
+C
+C Construct dissimilarity matrix
+C
+ DO I=1,N-1
+ DO J=I+1,N
+ IND=IOFFSET(N,I,J)
+cinput DISS(IND)=0.
+cinput DO K=1,M
+cinput DISS(IND)=DISS(IND)+(DATA(I,K)-DATA(J,K))**2
+cinput ENDDO
+ IF (IOPT.EQ.1) DISS(IND)=DISS(IND)/2.
+C (Above is done for the case of the min. var. method
+C where merging criteria are defined in terms of variances
+C rather than distances.)
+ ENDDO
+ ENDDO
+C
+C Carry out an agglomeration - first create list of NNs
+C
+ DO I=1,N-1
+ DMIN=INF
+ DO J=I+1,N
+ IND=IOFFSET(N,I,J)
+ IF (DISS(IND).GE.DMIN) GOTO 500
+ DMIN=DISS(IND)
+ JM=J
+ 500 CONTINUE
+ ENDDO
+ NN(I)=JM
+ DISNN(I)=DMIN
+ ENDDO
+C
+ 400 CONTINUE
+C Next, determine least diss. using list of NNs
+ DMIN=INF
+ DO I=1,N-1
+ IF (.NOT.FLAG(I)) GOTO 600
+ IF (DISNN(I).GE.DMIN) GOTO 600
+ DMIN=DISNN(I)
+ IM=I
+ JM=NN(I)
+ 600 CONTINUE
+ ENDDO
+ NCL=NCL-1
+C
+C This allows an agglomeration to be carried out.
+C
+ I2=MIN0(IM,JM)
+ J2=MAX0(IM,JM)
+ IA(N-NCL)=I2
+ IB(N-NCL)=J2
+ CRIT(N-NCL)=DMIN
+C
+C Update dissimilarities from new cluster.
+C
+ FLAG(J2)=.FALSE.
+ DMIN=INF
+ DO K=1,N
+ IF (.NOT.FLAG(K)) GOTO 800
+ IF (K.EQ.I2) GOTO 800
+ X=MEMBR(I2)+MEMBR(J2)+MEMBR(K)
+ IF (I2.LT.K) THEN
+ IND1=IOFFSET(N,I2,K)
+ ELSE
+ IND1=IOFFSET(N,K,I2)
+ ENDIF
+ IF (J2.LT.K) THEN
+ IND2=IOFFSET(N,J2,K)
+ ELSE
+ IND2=IOFFSET(N,K,J2)
+ ENDIF
+ IND3=IOFFSET(N,I2,J2)
+ XX=DISS(IND3)
+C
+C WARD'S MINIMUM VARIANCE METHOD - IOPT=1.
+C
+ IF (IOPT.EQ.1) THEN
+ DISS(IND1)=(MEMBR(I2)+MEMBR(K))*DISS(IND1)+
+ X (MEMBR(J2)+MEMBR(K))*DISS(IND2)-
+ X MEMBR(K)*XX
+ DISS(IND1)=DISS(IND1)/X
+ ENDIF
+C
+C SINGLE LINK METHOD - IOPT=2.
+C
+ IF (IOPT.EQ.2) THEN
+ DISS(IND1)=MIN(DISS(IND1),DISS(IND2))
+ ENDIF
+C
+C COMPLETE LINK METHOD - IOPT=3.
+C
+ IF (IOPT.EQ.3) THEN
+ DISS(IND1)=MAX(DISS(IND1),DISS(IND2))
+ ENDIF
+C
+C AVERAGE LINK (OR GROUP AVERAGE) METHOD - IOPT=4.
+C
+ IF (IOPT.EQ.4) THEN
+ DISS(IND1)=(MEMBR(I2)*DISS(IND1)+MEMBR(J2)*DISS(IND2))/
+ X (MEMBR(I2)+MEMBR(J2))
+ ENDIF
+C
+C MCQUITTY'S METHOD - IOPT=5.
+C
+ IF (IOPT.EQ.5) THEN
+ DISS(IND1)=0.5*DISS(IND1)+0.5*DISS(IND2)
+ ENDIF
+C
+C MEDIAN (GOWER'S) METHOD - IOPT=6.
+C
+ IF (IOPT.EQ.6) THEN
+ DISS(IND1)=0.5*DISS(IND1)+0.5*DISS(IND2)-0.25*XX
+ ENDIF
+C
+C CENTROID METHOD - IOPT=7.
+C
+ IF (IOPT.EQ.7) THEN
+ DISS(IND1)=(MEMBR(I2)*DISS(IND1)+MEMBR(J2)*DISS(IND2)-
+ X MEMBR(I2)*MEMBR(J2)*XX/(MEMBR(I2)+MEMBR(J2)))/
+ X (MEMBR(I2)+MEMBR(J2))
+ ENDIF
+C
+ IF (I2.GT.K) GOTO 800
+ IF (DISS(IND1).GE.DMIN) GOTO 800
+ DMIN=DISS(IND1)
+ JJ=K
+ 800 CONTINUE
+ ENDDO
+ MEMBR(I2)=MEMBR(I2)+MEMBR(J2)
+ DISNN(I2)=DMIN
+ NN(I2)=JJ
+C
+C Update list of NNs insofar as this is required.
+C
+ DO I=1,N-1
+ IF (.NOT.FLAG(I)) GOTO 900
+ IF (NN(I).EQ.I2) GOTO 850
+ IF (NN(I).EQ.J2) GOTO 850
+ GOTO 900
+ 850 CONTINUE
+C (Redetermine NN of I:)
+ DMIN=INF
+ DO J=I+1,N
+ IND=IOFFSET(N,I,J)
+ IF (.NOT.FLAG(J)) GOTO 870
+ IF (I.EQ.J) GOTO 870
+ IF (DISS(IND).GE.DMIN) GOTO 870
+ DMIN=DISS(IND)
+ JJ=J
+ 870 CONTINUE
+ ENDDO
+ NN(I)=JJ
+ DISNN(I)=DMIN
+ 900 CONTINUE
+ ENDDO
+C
+C Repeat previous steps until N-1 agglomerations carried out.
+C
+ IF (NCL.GT.1) GOTO 400
+C
+C
+ RETURN
+ END
+C
+C
+ FUNCTION IOFFSET(N,I,J)
+C Map row I and column J of upper half diagonal symmetric matrix
+C onto vector.
+ IOFFSET=J+(I-1)*N-(I*(I+1))/2
+ RETURN
+ END
+C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++C
+C C
+C Given a HIERARCHIC CLUSTERING, described as a sequence of C
+C agglomerations, derive the assignments into clusters for the C
+C top LEV-1 levels of the hierarchy. C
+C Prepare also the required data for representing the C
+C dendrogram of this top part of the hierarchy. C
+C C
+C Parameters: C
+C C
+C IA, IB, CRIT: vectors of dimension N defining the agglomer- C
+C ations. C
+C LEV: number of clusters in largest partition. C
+C HVALS: vector of dim. LEV, used internally only. C
+C ICLASS: array of cluster assignments; dim. N by LEV. C
+C IORDER, CRITVAL, HEIGHT: vectors describing the dendrogram, C
+C all of dim. LEV. C
+C C
+C F. Murtagh, ESA/ESO/STECF, Garching, February 1986. C
+C C
+C HISTORY C
+C C
+C Bounds bug fix, Oct. 1990, F. Murtagh. C
+C Inserted line "IF (LOC.GT.LEV) GOTO 58" on line 48. This was C
+C occassioned by incorrect termination of this loop when I C
+C reached its (lower) extremity, i.e. N-LEV. Without the C
+C /CHECK=(BOUNDS) option on VAX/VMS compilation, this inserted C
+C statement was not necessary. C
+C---------------------------------------------------------------C
+ SUBROUTINE HCASS(N,IA,IB,CRIT,LEV,ICLASS,HVALS,IORDER,
+ X CRITVAL,HEIGHT)
+ include 'sizesclu.dat'
+ include 'COMMON.IOUNITS'
+ integer ICLASS(maxconf,maxconf-1)
+ INTEGER IA(N),IB(N),HVALS(LEV),IORDER(LEV),
+ X HEIGHT(LEV)
+ REAL CRIT(N),CRITVAL(LEV)
+C
+C Pick out the clusters which the N objects belong to,
+C at levels N-2, N-3, ... N-LEV+1 of the hierarchy.
+C The clusters are identified by the lowest seq. no. of
+C their members.
+C There are 2, 3, ... LEV clusters, respectively, for the
+C above levels of the hierarchy.
+C
+ HVALS(1)=1
+ HVALS(2)=IB(N-1)
+ LOC=3
+ DO 59 I=N-2,N-LEV,-1
+ DO 52 J=1,LOC-1
+ IF (IA(I).EQ.HVALS(J)) GOTO 54
+ 52 CONTINUE
+ HVALS(LOC)=IA(I)
+ LOC=LOC+1
+ 54 CONTINUE
+ DO 56 J=1,LOC-1
+ IF (IB(I).EQ.HVALS(J)) GOTO 58
+ 56 CONTINUE
+ IF (LOC.GT.LEV) GOTO 58
+ HVALS(LOC)=IB(I)
+ LOC=LOC+1
+ 58 CONTINUE
+ 59 CONTINUE
+C
+ DO 400 LEVEL=N-LEV,N-2
+ DO 200 I=1,N
+ ICL=I
+ DO 100 ILEV=1,LEVEL
+ 100 IF (IB(ILEV).EQ.ICL) ICL=IA(ILEV)
+ NCL=N-LEVEL
+ ICLASS(I,NCL-1)=ICL
+ 200 CONTINUE
+ 400 CONTINUE
+C
+ DO 120 I=1,N
+ DO 120 J=1,LEV-1
+ DO 110 K=2,LEV
+ IF (ICLASS(I,J).NE.HVALS(K)) GOTO 110
+ ICLASS(I,J)=K
+ GOTO 120
+ 110 CONTINUE
+ 120 CONTINUE
+C
+c WRITE (iout,450) (j,j=2,LEV)
+ 450 FORMAT(4X,' SEQ NOS',8(i2,'CL'),10000(i3,'CL'))
+c WRITE (iout,470) (' ---',j=2,LEV)
+ 470 FORMAT(4X,' -------',10000a4)
+ DO 500 I=1,N
+c WRITE (iout,600) I,(ICLASS(I,J),J=1,LEV-1)
+ 600 FORMAT(I11,8I4,10000i5)
+ 500 CONTINUE
+C
+C Determine an ordering of the LEV clusters (at level LEV-1)
+C for later representation of the dendrogram.
+C These are stored in IORDER.
+C Determine the associated ordering of the criterion values
+C for the vertical lines in the dendrogram.
+C The ordinal values of these criterion values may be used in
+C preference, and these are stored in HEIGHT.
+C Finally, note that the LEV clusters are renamed so that they
+C have seq. nos. 1 to LEV.
+C
+ IORDER(1)=IA(N-1)
+ IORDER(2)=IB(N-1)
+ CRITVAL(1)=0.0
+ CRITVAL(2)=CRIT(N-1)
+ HEIGHT(1)=LEV
+ HEIGHT(2)=LEV-1
+ LOC=2
+ DO 700 I=N-2,N-LEV+1,-1
+ DO 650 J=1,LOC
+ IF (IA(I).EQ.IORDER(J)) THEN
+C Shift rightwards and insert IB(I) beside IORDER(J):
+ DO 630 K=LOC+1,J+1,-1
+ IORDER(K)=IORDER(K-1)
+ CRITVAL(K)=CRITVAL(K-1)
+ HEIGHT(K)=HEIGHT(K-1)
+ 630 CONTINUE
+ IORDER(J+1)=IB(I)
+ CRITVAL(J+1)=CRIT(I)
+ HEIGHT(J+1)=I-(N-LEV)
+ LOC=LOC+1
+ ENDIF
+ 650 CONTINUE
+ 700 CONTINUE
+ DO 705 I=1,LEV
+ DO 703 J=1,LEV
+ IF (HVALS(I).EQ.IORDER(J)) THEN
+ IORDER(J)=I
+ GOTO 705
+ ENDIF
+ 703 CONTINUE
+ 705 CONTINUE
+C
+ RETURN
+ END
+C+++++++++++++++++++++++++++++++++++++++++++++++++C
+C C
+C Construct a DENDROGRAM of the top 8 levels of C
+C a HIERARCHIC CLUSTERING. C
+C C
+C Parameters: C
+C C
+C IORDER, HEIGHT, CRITVAL: vectors of length LEV C
+C defining the dendrogram. C
+C These are: the ordering of objects C
+C along the bottom of the dendrogram C
+C (IORDER); the height of the vertical C
+C above each object, in ordinal values C
+C (HEIGHT); and in real values (CRITVAL).C
+C C
+C NOTE: these vectors MUST have been set up with C
+C LEV = 9 in the prior call to routine C
+C HCASS.
+C C
+C F. Murtagh, ESA/ESO/STECF, Garching, Feb. 1986.C
+C C
+C-------------------------------------------------C
+ SUBROUTINE HCDEN(LEV,IORDER,HEIGHT,CRITVAL)
+ include 'COMMON.IOUNITS'
+ CHARACTER*80 LINE
+ INTEGER IORDER(LEV),HEIGHT(LEV)
+ REAL CRITVAL(LEV)
+c INTEGER OUT(3*LEV,3*LEV)
+c INTEGER UP,ACROSS,BLANK
+ CHARACTER*1 OUT(3*LEV,3*LEV)
+ CHARACTER*1 UP,ACROSS,BLANK
+ DATA UP,ACROSS,BLANK/'|','-',' '/
+C
+C
+ DO I=1,3*LEV
+ DO J=1,3*LEV
+ OUT(I,J)=BLANK
+ ENDDO
+ ENDDO
+C
+C
+ DO I=3,3*LEV,3
+ I2=I/3
+C
+ J2=3*LEV+1-3*HEIGHT(I2)
+ DO J=3*LEV,J2,-1
+ OUT(J,I)=UP
+ ENDDO
+C
+ DO K=I,3,-1
+ I3=INT((K+2)/3)
+ IF ( (3*LEV+1-HEIGHT(I3)*3).LT.J2) GOTO 100
+ OUT(J2,K)=ACROSS
+ ENDDO
+ 100 CONTINUE
+C
+ ENDDO
+C
+C
+ IC=3
+ DO I=1,3*LEV
+ IF (I.EQ.IC+1) THEN
+ IDUM=IC/3
+ IDUM=LEV-IDUM
+ DO L=1,LEV
+ IF (HEIGHT(L).EQ.IDUM) GOTO 190
+ ENDDO
+ 190 IDUM=L
+c WRITE(iout,200) CRITVAL(IDUM),(OUT(I,J),J=1,3*LEV)
+ IC=IC+3
+ ELSE
+ LINE = ' '
+c WRITE(iout,210) (OUT(I,J),J=1,3*LEV)
+ ENDIF
+ 200 FORMAT(1H ,8X,F12.2,4X,27000A1)
+ 210 FORMAT(1H ,24X,27000A1)
+ ENDDO
+ WRITE(iout,250)
+c WRITE(iout,220)(IORDER(J),J=1,LEV)
+c WRITE(iout,250)
+ 220 FORMAT(1H ,24X,9000I3)
+c WRITE(iout,230) LEV
+ 230 FORMAT(1H ,13X,'CRITERION CLUSTERS 1 TO ',i3)
+c WRITE(iout,240) LEV-1
+ 240 FORMAT(1H ,13X,'VALUES. (TOP ',i3,' LEVELS OF HIERARCHY).')
+ 250 FORMAT(/)
+C
+C
+ RETURN
+ END
--- /dev/null
+ integer function icant(i,j)
+ integer 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,gg_lipi,gg_lipj
+ common /calc/ erij(3),rij,xj,yj,zj,dxi,dyi,dzi,dxj,dyj,dzj,
+ & chi1,chi2,chi12,chip1,chip2,chip12,alf1,alf2,alf12,om1,om2,om12,
+ & om1om2,chiom1,chiom2,chiom12,chipom1,chipom2,chipom12,eps1,
+ & faceps1,faceps1_inv,eps1_om12,facsig,sigsq,sigsq_om1,sigsq_om2,
+ & sigsq_om12,facp,facp_inv,facp1,eps2rt,eps2rt_om1,eps2rt_om2,
+ & eps2rt_om12,eps3rt,eom1,eom2,eom12,evdwij,eps2der,eps3der,sigder,
+ & dsci_inv,dscj_inv,gg(3),gg_lipi(3),gg_lipj(3),i,j
--- /dev/null
+C Change 12/1/95 - common block CONTACTS1 included.
+ integer ncont,ncont_ref,icont,icont_ref,num_cont,jcont,
+ & num_cont_hb,jcont_hb
+ double precision facont,gacont,g_contij,ekont,
+ & gacontp_hb1,gacontp_hb2,gacontp_hb3,gacontm_hb1,gacontm_hb2,
+ & gacontm_hb3,gacont_hbr,grij_hb_cont,facont_hb,ees0p,
+ & ees0m,d_cont
+ 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,
+ & Ug2DtEUg,Ug2DtEUgder
+ common /precomp2/ Ug2Db1t(2,maxres),Ug2Db1tder(2,maxres),
+ & CUgb2(2,maxres),CUgb2der(2,maxres),EUgC(2,2,maxres),
+ & EUgCder(2,2,maxres),EUgD(2,2,maxres),EUgDder(2,2,maxres),
+ & DtUg2EUg(2,2,maxres),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,ADtEA1,ADtEA1derg,ADtEA1derx,
+ & EAEA, EAEAderg, EAEAderx
+ 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
+C Change 12/1/95 - common block CONTACTS1 included.
+ integer ncont,ncont_ref,icont,icont_ref,num_cont,jcont
+ double precision facont,gacont
+ common /contacts/ ncont,ncont_ref,icont(2,maxcont),
+ & icont_ref(2,maxcont)
+ common /contacts1/ facont(maxconts,maxres),
+ & gacont(3,maxconts,maxres),
+ & num_cont(maxres),jcont(maxconts,maxres)
+C 12/26/95 - H-bonding contacts
+ common /contacts_hb/
+ & gacontp_hb1(3,maxconts,maxres),gacontp_hb2(3,maxconts,maxres),
+ & gacontp_hb3(3,maxconts,maxres),
+ & gacontm_hb1(3,maxconts,maxres),gacontm_hb2(3,maxconts,maxres),
+ & gacontm_hb3(3,maxconts,maxres),
+ & gacont_hbr(3,maxconts,maxres),
+ & grij_hb_cont(3,maxconts,maxres),
+ & facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
+ & ees0m(maxconts,maxres),d_cont(maxconts,maxres),
+ & num_cont_hb(maxres),jcont_hb(maxconts,maxres)
+C 9/23/99 Added improper rotation matrices and matrices of dipole-dipole
+C interactions
+C Interactions of pseudo-dipoles generated by loc-el interactions.
+ double precision dip,dipderg,dipderx
+ common /dipint/ dip(4,maxconts,maxres),dipderg(4,maxconts,maxres),
+ & dipderx(3,5,4,maxconts,maxres)
+C 10/30/99 Added other pre-computed vectors and matrices needed
+C to calculate three - six-order el-loc correlation terms
+ double precision Ug,Ugder,Ug2,Ug2der,obrot,obrot2,obrot_der,
+ & obrot2_der,Ub2,Ub2der,mu,muder,EUg,EUgder,CUg,CUgder,
+ & DUg,DUgder,DtUg2,DtUg2der,Ctobr,Ctobrder,Dtobr2,Dtobr2der
+ common /rotat/ Ug(2,2,maxres),Ugder(2,2,maxres),Ug2(2,2,maxres),
+ & Ug2der(2,2,maxres),obrot(2,maxres),obrot2(2,maxres),
+ & obrot_der(2,maxres),obrot2_der(2,maxres)
+C This common block contains vectors and matrices dependent on a single
+C amino-acid residue.
+ common /precomp1/ Ub2(2,maxres),Ub2der(2,maxres),mu(2,maxres),
+ & EUg(2,2,maxres),EUgder(2,2,maxres),CUg(2,2,maxres),
+ & CUgder(2,2,maxres),DUg(2,2,maxres),Dugder(2,2,maxres),
+ & DtUg2(2,2,maxres),DtUg2der(2,2,maxres),Ctobr(2,maxres),
+ & Ctobrder(2,maxres),Dtobr2(2,maxres),Dtobr2der(2,maxres)
+C This common block contains vectors and matrices dependent on two
+C consecutive amino-acid residues.
+ double precision Ug2Db1t,Ug2Db1tder,CUgb2,CUgb2der,EUgC,
+ & EUgCder,EUgD,EUgDder,DtUg2EUg,DtUg2EUgder
+ common /precomp2/ Ug2Db1t(2,maxres),Ug2Db1tder(2,maxres),
+ & CUgb2(2,maxres),CUgb2der(2,maxres),EUgC(2,2,maxres),
+ & EUgCder(2,2,maxres),EUgD(2,2,maxres),EUgDder(2,2,maxres),
+ & DtUg2EUg(2,2,maxres),DtUg2EUgder(2,2,2,maxres),
+ & Ug2DtEUg(2,2,maxres),Ug2DtEUgder(2,2,2,maxres)
+ double precision costab,sintab,costab2,sintab2
+ common /rotat_old/ costab(maxres),sintab(maxres),
+ & costab2(maxres),sintab2(maxres),muder(2,maxres)
+C This common block contains dipole-interaction matrices and their
+C Cartesian derivatives.
+ double precision a_chuj,a_chuj_der
+ common /dipmat/ a_chuj(2,2,maxconts,maxres),
+ & a_chuj_der(2,2,3,5,maxconts,maxres)
+ double precision AEA,AEAderg,AEAderx,AECA,AECAderg,AECAderx,
+ & ADtEA,ADtEAderg,ADtEAderx,AEAb1,AEAb1derg,AEAb1derx,
+ & AEAb2,AEAb2derg,AEAb2derx
+ common /diploc/ AEA(2,2,2),AEAderg(2,2,2),AEAderx(2,2,3,5,2,2),
+ & EAEA(2,2,2), EAEAderg(2,2,2,2), EAEAderx(2,2,3,5,2,2),
+ & AECA(2,2,2),AECAderg(2,2,2),AECAderx(2,2,3,5,2,2),
+ & ADtEA(2,2,2),ADtEAderg(2,2,2,2),ADtEAderx(2,2,3,5,2,2),
+ & ADtEA1(2,2,2),ADtEA1derg(2,2,2,2),ADtEA1derx(2,2,3,5,2,2),
+ & AEAb1(2,2,2),AEAb1derg(2,2,2),AEAb1derx(2,3,5,2,2,2),
+ & AEAb2(2,2,2),AEAb2derg(2,2,2,2),AEAb2derx(2,3,5,2,2,2),
+ & g_contij(3,2),ekont
--- /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,
+ & 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,
+ & gelc_long,gvdwpp,gradxorr,gradcorr5,gradcorr6,gcorr3_turn,
+ & gcorr4_turn,gradb,gel_loc_loc,gel_loc_turn3,gel_loc_turn4,
+ & g_corr5_loc,g_corr6_loc,gsccorc,gsccorx,gsccor_loc,gcorr6_turn,
+ & gradbx,gel_loc_turn6,gcorr_loc,
+ & 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),
+ & ghpbc(3,-1:maxres),gloc(maxvar,2),gradcorr(3,-1:maxres),
+ & gsaxsC(3,-1:maxres),gsaxsX(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,
+ & gradcorr5,gradcorr6,gel_loc,gcorr3_turn,gcorr4_turn,gcorr6_turn,
+ & gel_loc_loc,gel_loc_turn3,gel_loc_turn4,gel_loc_turn6,gcorr_loc,
+ & g_corr5_loc,g_corr6_loc,gradb,gradbx,gsccorc,gsccorx,gsccor_loc,
+ & gscloc,gsclocx
+ integer nfl,icg
+ logical calc_grad
+ common /derivat/ dcdv(6,maxdim),dxdv(6,maxdim),dxds(6,maxres),
+ & gradx(3,maxres,2),gradc(3,maxres,2),gvdwx(3,maxres),
+ & gvdwc(3,maxres),gelc(3,maxres),gvdwpp(3,maxres),
+ & gradx_scp(3,maxres),
+ & gvdwc_scp(3,maxres),ghpbx(3,maxres),ghpbc(3,maxres),
+ & gloc(maxvar,2),gradcorr(3,maxres),gradxorr(3,maxres),
+ & gradcorr5(3,maxres),gradcorr6(3,maxres),
+ & gel_loc(3,maxres),gcorr3_turn(3,maxres),gcorr4_turn(3,maxres),
+ & gcorr6_turn(3,maxres),gradb(3,maxres),gradbx(3,maxres),
+ & gel_loc_loc(maxvar),gel_loc_turn3(maxvar),gel_loc_turn4(maxvar),
+ & gel_loc_turn6(maxvar),gcorr_loc(maxvar),
+ & g_corr5_loc(maxvar),g_corr6_loc(maxvar),gsccorc(3,maxres),
+ & gsccorx(3,maxres),gsccor_loc(maxres),
+ & gscloc(3,maxres),gsclocx(3,maxres),nfl,icg,calc_grad
+ double precision derx,derx_turn
+ common /deriv_loc/ derx(3,5,2),derx_turn(3,5,2)
+ double precision dXX_C1tab(3,maxres),dYY_C1tab(3,maxres),
+ & dZZ_C1tab(3,maxres),dXX_Ctab(3,maxres),dYY_Ctab(3,maxres),
+ & dZZ_Ctab(3,maxres),dXX_XYZtab(3,maxres),dYY_XYZtab(3,maxres),
+ & dZZ_XYZtab(3,maxres)
+ common /deriv_scloc/ dXX_C1tab,dYY_C1tab,dZZ_C1tab,dXX_Ctab,
+ & dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,dZZ_XYZtab
--- /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,epslip,sigma,sigmaii,rs0,chi,chip,chip0,
+ & alp,signa0,
+ & sigii,sigma0,rr0,r0,r0e,r0d,rpp,epp,elpp6,elpp3,eps_scp,rscp,
+ & eps_orig
+ common /body/eps(ntyp,ntyp),epslip(ntyp,ntyp),
+ & sigma(ntyp,ntyp),sigmaii(ntyp,ntyp),
+ & rs0(ntyp,ntyp),chi(ntyp,ntyp),chip(ntyp),chip0(ntyp),alp(ntyp),
+ & sigma0(ntyp),sigii(ntyp),rr0(ntyp),r0(ntyp,ntyp),r0e(ntyp,ntyp),
+ & r0d(ntyp,2),rpp(2,2),epp(2,2),elpp6(2,2),elpp3(2,2),
+ & eps_scp(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,vbl,vblinv,vblinv2,
+ & vbl_cis,vbl0,vbld_inv
+ integer nlob,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 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 ab initio-derived potential of virtual-bond-angle bending
+ integer nthetyp,ntheterm,ntheterm2,ntheterm3,nsingle,ndouble,
+ & ithetyp(-ntyp1:ntyp1),nntheterm
+ double precision aa0thet(-maxthetyp1:maxthetyp1,
+ &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2),
+ & aathet(maxtheterm,-maxthetyp1:maxthetyp1,
+ &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2),
+ & bbthet(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1,
+ &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2),
+ & ccthet(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1,
+ &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2),
+ & ddthet(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1,
+ &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2),
+ & eethet(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1,
+ &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2),
+ & ffthet(maxdouble,maxdouble,maxtheterm3,-maxthetyp1:maxthetyp1,
+ &-maxthetyp1:maxthetyp1, -maxthetyp1:maxthetyp1,2),
+ & ggthet(maxdouble,maxdouble,maxtheterm3,-maxthetyp1:maxthetyp1,
+ &-maxthetyp1:maxthetyp1, -maxthetyp1:maxthetyp1,2)
+ common /theta_abinitio/aa0thet,aathet,bbthet,ccthet,ddthet,eethet,
+ & ffthet,
+ & ggthet,ithetyp,nthetyp,ntheterm,ntheterm2,ntheterm3,nsingle,
+ & ndouble,nntheterm
+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 Virtual-bond lenghts
+ common /peptbond/ vbl,vblinv,vblinv2,vbl_cis,vbl0
+ common /indices/ loc_start,loc_end,ithet_start,ithet_end,
+ & iphi_start,iphi_end,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
+C Parameters of the SCCOR term
+ double precision v1sccor,v2sccor
+ integer nterm_sccor
+ common/torsion/v1sccor(maxterm_sccor,ntyp,ntyp),
+ & v2sccor(maxterm_sccor,ntyp,ntyp),
+ & nterm_sccor
--- /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 r_cut,rlamb
+ common /splitele/ r_cut,rlamb
--- /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
+ integer itortyp,ntortyp,nterm,nlor,nterm_old
+ common/torsion/v0(maxtor,maxtor),v1(maxterm,maxtor,maxtor),
+ & v2(maxterm,maxtor,maxtor),vlor1(maxlor,maxtor,maxtor),
+ & vlor2(maxlor,maxtor,maxtor),vlor3(maxlor,maxtor,maxtor),
+ & itortyp(ntyp),ntortyp,nterm(maxtor,maxtor),
+ & nlor(maxtor,maxtor),nterm_old
+C 6/23/01 - constants for double torsionals
+ double precision v1c,v1s,v2c,v2s
+ integer ntermd_1,ntermd_2
+ common /torsiond/ v1c(2,maxtermd_1,maxtor,maxtor,maxtor),
+ & v1s(2,maxtermd_1,maxtor,maxtor,maxtor),
+ & v2c(maxtermd_2,maxtermd_2,maxtor,maxtor,maxtor),
+ & v2s(maxtermd_2,maxtermd_2,maxtor,maxtor,maxtor),
+ & ntermd_1(maxtor,maxtor,maxtor),ntermd_2(maxtor,maxtor,maxtor)
+C 9/18/99 - added Fourier coeffficients of the expansion of local energy
+C surface
+ double precision b1,b2,cc,dd,ee,ctilde,dtilde,b1tilde
+ integer nloctyp
+ common/fourier/ b1(2,maxtor),b2(2,maxtor),cc(2,2,maxtor),
+ & dd(2,2,maxtor),ee(2,2,maxtor),ctilde(2,2,maxtor),
+ & dtilde(2,2,maxtor),b1tilde(2,maxtor),nloctyp
+ double precision b
+ common /fourier1/ b(13,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 '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'
+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=pi/3.0D0
+ pipol=0.5D0*pi
+ deg2rad=pi/180.0D0
+ rad2deg=1.0D0/deg2rad
+ angmin=10.0D0*deg2rad
+C Assign virtual-bond length
+ vbl=3.8D0
+ vblinv=1.0D0/vbl
+ vblinv2=vblinv*vblinv
+C
+C Define I/O units.
+C
+ inp= 1
+ iout= 2
+ ipdbin= 3
+ ipdb= 7
+ igeom= 8
+ intin= 9
+ istat= 17
+ imol2= 18
+ jplot= 19
+ jstatin=10
+ jstatout=11
+C
+C Zero out tables.
+C
+ 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
+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
+ return
+ end
+c-------------------------------------------------------------------------
+ block data chuj
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.NAMES'
+ include 'COMMON.FFIELD'
+ data restyp /
+ &'DD','DAU','DAI','DDB','DSM','DPR','DLY','DAR','DHI','DAS','DGL',
+ & 'DSG','DGN','DSN','DTH',
+ &'DYY','DAL','DTY','DTR','DVA','DLE','DIL','DPN','MED','DCY','ZER',
+ &'CYS','MET','PHE','ILE','LEU','VAL','TRP','TYR','ALA','GLY','THR',
+ &'SER','GLN','ASN','GLU','ASP','HIS','ARG','LYS','PRO','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 potname /'LJ','LJK','BP','GB','GBV'/
+ end
--- /dev/null
+ subroutine initialize
+C
+C Define constants and zero out tables.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ 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'
+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=pi/3.0D0
+ pipol=0.5D0*pi
+ deg2rad=pi/180.0D0
+ rad2deg=1.0D0/deg2rad
+ angmin=10.0D0*deg2rad
+C Assign virtual-bond length
+ vbl=3.8D0
+ vblinv=1.0D0/vbl
+ vblinv2=vblinv*vblinv
+C
+C Define I/O units.
+C
+ inp= 1
+ iout= 2
+ ipdbin= 3
+ ipdb= 7
+ igeom= 8
+ intin= 9
+ istat= 17
+ imol2= 18
+ jplot= 19
+ jstatin=10
+ jstatout=11
+C
+C Zero out tables.
+C
+ 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
+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
+ return
+ end
+c-------------------------------------------------------------------------
+ block data chuj
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ 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'/
+ end
--- /dev/null
+ subroutine initialize
+C
+C Define constants and zero out tables.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'sizesclu.dat'
+ 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.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
+ Rgas = 1.987D-3
+C
+C Define I/O units.
+C
+ inp= 1
+ iout= 2
+ ipdbin= 3
+ ipdb= 7
+ imol2= 18
+ jplot= 19
+ jstatin=10
+ 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
+ ibond=28
+ isccor=29
+ jrms=30
+ iliptran=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_aq(i,j)=0.0D0
+ bb_aq(i,j)=0.0D0
+ aa_lip(i,j)=0.0D0
+ bb_lip(i,j)=0.0D0
+ augm(i,j)=0.0D0
+ sigma(i,j)=0.0D0
+ r0(i,j)=0.0D0
+ 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,maxss
+ dhpb(i)=0.0D0
+ enddo
+ do i=1,maxss
+ ihpb(i)=0
+ jhpb(i)=0
+ enddo
+C
+C Initialize timing.
+C
+ call set_timers
+C
+C Initialize variables used in minimization.
+C
+c maxfun=5000
+c maxit=2000
+ maxfun=500
+ maxit=200
+ tolf=1.0D-2
+ rtolf=5.0D-4
+C
+C Initialize the variables responsible for the mode of gradient storage.
+C
+ nfl=0
+ icg=1
+ do i=1,14
+ do j=1,14
+ if (print_order(i).eq.j) then
+ iw(print_order(i))=j
+ goto 1121
+ endif
+ enddo
+1121 continue
+ enddo
+ calc_grad=.false.
+C Set timers and counters for the respective routines
+ t_func = 0.0d0
+ t_grad = 0.0d0
+ t_fhel = 0.0d0
+ t_fbet = 0.0d0
+ t_ghel = 0.0d0
+ t_gbet = 0.0d0
+ t_viol = 0.0d0
+ t_gviol = 0.0d0
+ n_func = 0
+ n_grad = 0
+ n_fhel = 0
+ n_fbet = 0
+ n_ghel = 0
+ n_gbet = 0
+ n_viol = 0
+ n_gviol = 0
+ n_map = 0
+#ifndef SPLITELE
+ nprint_ene=nprint_ene-1
+#endif
+ return
+ end
+c-------------------------------------------------------------------------
+ block data nazwy
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'sizesclu.dat'
+ include 'COMMON.NAMES'
+ include 'COMMON.FFIELD'
+ data restyp /
+ &'DD','DAU','DAI','DDB','DSM','DPR','DLY','DAR','DHI','DAS','DGL',
+ & 'DSG','DGN','DSN','DTH',
+ &'DYY','DAL','DTY','DTR','DVA','DLE','DIL','DPN','MED','DCY','ZER',
+ &'CYS','MET','PHE','ILE','LEU','VAL','TRP','TYR','ALA','GLY','THR',
+ &'SER','GLN','ASN','GLU','ASP','HIS','ARG','LYS','PRO','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"/
+#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 '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
+ isaxs_start=1
+ isaxs_end=nsaxs
+ write (iout,*) "OSAXS_START",isaxs_start," ISAXS_END",isaxs_end
+ 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 '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 int_from_cart1(lprn)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'sizesclu.dat'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.VAR'
+ include 'COMMON.CHAIN'
+ include 'COMMON.GEO'
+ include 'COMMON.INTERACT'
+ include 'COMMON.LOCAL'
+ include 'COMMON.NAMES'
+ 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 '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 '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
+ 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 '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
+gfortran -O -c -I. -Iinclude_unres -I/users/software/mpich2-1.0.7/include readpdb.f
+cc -o compinfo compinfo.c
+./compinfo | true
+gfortran -O -c -I. -Iinclude_unres -I/users/software/mpich2-1.0.7/include cinfo.f
+gfortran -O main_clust.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o matmult.o readrtns.o pinorm.o rescode.o intcor.o timing.o misc.o geomout.o readpdb.o read_coords.o parmread.o probabl.o fitsq.o hc.o track.o wrtclust.o srtclust.o noyes.o contact.o printmat.o int_from_cart1.o energy_p_new.o icant.o proc_proc.o work_partition.o setup_var.o read_ref_str.o gnmr1.o permut.o -L/users/software/mpich2-1.0.7/lib -lmpich -lpthread xdrf/libxdrf.a -o ../../../../bin/cluster/unres_clustMD-mult_ifort_MPICH_NEWCORR.exe
+readrtns.o: In function `molread_':
+readrtns.F:(.text+0x498f): relocation truncated to fit: R_X86_64_PC32 against symbol `torcnstr_' defined in COMMON section in readrtns.o
+readrtns.F:(.text+0x49c6): relocation truncated to fit: R_X86_64_PC32 against symbol `torcnstr_' defined in COMMON section in readrtns.o
+readrtns.F:(.text+0x49e9): relocation truncated to fit: R_X86_64_32S against symbol `torcnstr_' defined in COMMON section in readrtns.o
+readrtns.F:(.text+0x4a06): relocation truncated to fit: R_X86_64_32S against symbol `torcnstr_' defined in COMMON section in readrtns.o
+readrtns.F:(.text+0x4a23): relocation truncated to fit: R_X86_64_32S against symbol `torcnstr_' defined in COMMON section in readrtns.o
+readrtns.F:(.text+0x4a40): relocation truncated to fit: R_X86_64_32S against symbol `torcnstr_' defined in COMMON section in readrtns.o
+readrtns.F:(.text+0x4ae2): relocation truncated to fit: R_X86_64_PC32 against symbol `torcnstr_' defined in COMMON section in readrtns.o
+readrtns.F:(.text+0x4b40): relocation truncated to fit: R_X86_64_32S against symbol `torcnstr_' defined in COMMON section in readrtns.o
+readrtns.F:(.text+0x4b5d): relocation truncated to fit: R_X86_64_32S against symbol `torcnstr_' defined in COMMON section in readrtns.o
+readrtns.F:(.text+0x4b7a): relocation truncated to fit: R_X86_64_32S against symbol `torcnstr_' defined in COMMON section in readrtns.o
+readrtns.F:(.text+0x4b97): additional relocation overflows omitted from the output
+energy_p_new.o: In function `egb_':
+energy_p_new.F:(.text+0xfc29): undefined reference to `dyn_ssbond_ene_'
+energy_p_new.F:(.text+0xfca0): undefined reference to `triple_ssbond_ene_'
+energy_p_new.o: In function `etotal_':
+energy_p_new.F:(.text+0x118fd): undefined reference to `dyn_set_nss_'
+collect2: ld returned 1 exit status
+make: *** [NEWCORR] Error 1
--- /dev/null
+C
+C Program to cluster united-residue MCM results.
+C
+ implicit none
+ include 'DIMENSIONS'
+ include 'sizesclu.dat'
+#ifdef MPI
+ include "mpif.h"
+ integer IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE)
+ include "COMMON.MPI"
+#endif
+ include 'COMMON.TIME1'
+ include 'COMMON.INTERACT'
+ include 'COMMON.NAMES'
+ include 'COMMON.GEO'
+ include 'COMMON.HEADER'
+ include 'COMMON.CONTROL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.VAR'
+ include 'COMMON.CLUSTER'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.FREE'
+ logical printang(max_cut)
+ integer printpdb(max_cut)
+ integer printmol2(max_cut)
+ character*240 lineh
+ REAL CRIT(maxconf),MEMBR(maxconf)
+ REAL CRITVAL(maxconf-1)
+ INTEGER IA(maxconf),IB(maxconf)
+ INTEGER ICLASS(maxconf,maxconf-1),HVALS(maxconf-1)
+ INTEGER IORDER(maxconf-1),HEIGHT(maxconf-1)
+ integer nn,ndis,scount_buf
+ real*4 DISNN, diss_buf(maxdist)
+ DIMENSION NN(maxconf),DISNN(maxconf)
+ LOGICAL FLAG(maxconf)
+ integer i,j,k,l,m,n,len,lev,idum,ii,ind,ioffset,jj,icut,ncon,
+ & it,ncon_work,ind1,kkk, ijk, is,ie
+ double precision t1,t2,tcpu,difconf
+
+ double precision varia(maxvar)
+ double precision hrtime,mintime,sectime
+ logical eof
+#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
+
+ call initialize
+ call openunits
+ call cinfo
+ call read_control
+ call parmread
+ call molread
+c write (iout,*) "Main: refstr ",refstr
+ if (refstr) call read_ref_structure(*30)
+ do i=1,nres
+ phi(i)=0.0D0
+ theta(i)=0.0D0
+ alph(i)=0.0D0
+ omeg(i)=0.0D0
+ enddo
+ if (nclust.gt.0) then
+ PRINTANG(1)=.TRUE.
+ PRINTPDB(1)=outpdb
+ printmol2(1)=outmol2
+ ncut=0
+ else
+ DO I=1,NCUT
+ PRINTANG(I)=.FALSE.
+ PRINTPDB(I)=0
+ printmol2(i)=0
+ IF (RCUTOFF(I).LT.0.0) THEN
+ RCUTOFF(I)=ABS(RCUTOFF(I))
+ PRINTANG(I)=.TRUE.
+ PRINTPDB(I)=outpdb
+ printmol2(i)=outmol2
+ ENDIF
+ ENDDO
+ endif
+ if (ncut.gt.0) then
+ write (iout,*) 'Number of cutoffs:',NCUT
+ write (iout,*) 'Cutoff values:'
+ DO ICUT=1,NCUT
+ WRITE(IOUT,'(8HRCUTOFF(,I2,2H)=,F8.1,2i2)')ICUT,RCUTOFF(ICUT),
+ & printpdb(icut),printmol2(icut)
+ ENDDO
+ else if (nclust.gt.0) then
+ write (iout,'("Number of clusters requested",i5)') nclust
+ else
+ if (me.eq.Master)
+ & write (iout,*) "ERROR: Either nclust or ncut must be >0"
+ stop
+ endif
+ DO I=1,NRES-3
+ MULT(I)=1
+ ENDDO
+ do i=1,maxconf
+ list_conf(i)=i
+ enddo
+ call read_coords(ncon,*20)
+ write (iout,*) 'from read_coords: ncon',ncon
+
+ write (iout,*) "nT",nT
+ do iT=1,nT
+ write (iout,*) "Temperature",1.0d0/(beta_h(iT)*1.987D-3)
+#ifdef MPI
+ call work_partition(.true.,ncon)
+#endif
+ call probabl(iT,ncon_work,ncon,*20)
+
+ if (ncon_work.lt.2) then
+ write (iout,*) "Too few conformations; clustering skipped"
+ exit
+ endif
+#ifdef MPI
+ ndis=ncon_work*(ncon_work-1)/2
+ call work_partition(.true.,ndis)
+#endif
+ DO I=1,NCON_work
+ ICC(I)=I
+ ENDDO
+ WRITE (iout,'(A80)') TITEL
+ t1=tcpu()
+C
+C CALCULATE DISTANCES
+C
+ call daread_ccoords(1,ncon_work)
+ ind1=0
+ DO I=1,NCON_work-1
+c if (mod(i,100).eq.0) print *,'Calculating RMS i=',i
+ DO J=I+1,NCON_work
+ IND=IOFFSET(NCON_work,I,J)
+#ifdef MPI
+ if (ind.ge.indstart(me) .and. ind.le.indend(me)) then
+#endif
+ ind1=ind1+1
+ DISS(IND1)=DIFCONF(I,J)
+c write (iout,'(2i4,i10,f10.5)') i,j,ind,DISS(IND)
+#ifdef MPI
+ endif
+#endif
+ ENDDO
+ ENDDO
+ t2=tcpu()
+ WRITE (iout,'(/a,1pe14.5,a/)')
+ & 'Time for distance calculation:',T2-T1,' sec.'
+ t1=tcpu()
+c PRINT '(a)','End of distance computation'
+
+ scount_buf=scount(me)
+
+ do ijk=1, ndis
+ diss_buf(ijk)=diss(ijk)
+ enddo
+
+
+#ifdef MPI
+ WRITE (iout,*) "Wchodze do call MPI_Gatherv"
+ call MPI_Gatherv(diss_buf(1),scount_buf,MPI_REAL,diss(1),
+ & scount(0),idispl(0),MPI_REAL,Master,MPI_COMM_WORLD, IERROR)
+ if (me.eq.master) then
+#endif
+ open(80,file='/tmp/distance',form='unformatted')
+ do i=1,ndis
+ write(80) diss(i)
+ enddo
+ if (punch_dist) then
+ do i=1,ncon_work-1
+ do j=i+1,ncon_work
+ IND=IOFFSET(NCON,I,J)
+ write (jrms,'(2i5,2f10.5)') i,j,diss(IND),
+ & energy(j)-energy(i)
+ enddo
+ enddo
+ endif
+C
+C Print out the RMS deviation matrix.
+C
+ if (print_dist) CALL DISTOUT(NCON_work)
+C
+C call hierarchical clustering HC from F. Murtagh
+C
+ N=NCON_work
+ LEN = (N*(N-1))/2
+ write(iout,*) "-------------------------------------------"
+ write(iout,*) "HIERARCHICAL CLUSTERING using"
+ if (iopt.eq.1) then
+ write(iout,*) "WARD'S MINIMUM VARIANCE METHOD"
+ elseif (iopt.eq.2) then
+ write(iout,*) "SINGLE LINK METHOD"
+ elseif (iopt.eq.3) then
+ write(iout,*) "COMPLETE LINK METHOD"
+ elseif (iopt.eq.4) then
+ write(iout,*) "AVERAGE LINK (OR GROUP AVERAGE) METHOD"
+ elseif (iopt.eq.5) then
+ write(iout,*) "MCQUITTY'S METHOD"
+ elseif (iopt.eq.6) then
+ write(iout,*) "MEDIAN (GOWER'S) METHOD"
+ elseif (iopt.eq.7) then
+ write(iout,*) "CENTROID METHOD"
+ else
+ write(iout,*) "IOPT=",iopt," IS INVALID, use 1-7"
+ write(*,*) "IOPT=",iopt," IS INVALID, use 1-7"
+ stop
+ endif
+ write(iout,*)
+ write(iout,*) "hc.f by F. Murtagh, ESA/ESO/STECF, Garching"
+ write(iout,*) "February 1986"
+ write(iout,*) "References:"
+ write(iout,*) "1. Multidimensional clustering algorithms"
+ write(iout,*) " Fionn Murtagh"
+ write(iout,*) " Vienna : Physica-Verlag, 1985."
+ write(iout,*) "2. Multivariate data analysis"
+ write(iout,*) " Fionn Murtagh and Andre Heck"
+ write(iout,*) " Kluwer Academic Publishers, 1987"
+ write(iout,*) "-------------------------------------------"
+ write(iout,*)
+
+#ifdef DEBUG
+ write (iout,*) "The TOTFREE array"
+ do i=1,ncon_work
+ write (iout,'(2i5,f10.5)') i,list_conf(i),totfree(i)
+ enddo
+#endif
+ call flush(iout)
+ CALL HC(N,M,LEN,IOPT,IA,IB,CRIT,MEMBR,NN,DISNN,FLAG,DISS)
+ LEV = N-1
+ write (iout,*) "n",n," ncon_work",ncon_work," lev",lev
+ if (lev.lt.2) then
+ write (iout,*) "Too few conformations to cluster."
+ goto 192
+ endif
+ CALL HCASS(N,IA,IB,CRIT,LEV,ICLASS,HVALS,IORDER,CRITVAL,HEIGHT)
+c CALL HCDEN(LEV,IORDER,HEIGHT,CRITVAL)
+c 3/3/16 AL: added explicit number of cluters
+ if (nclust.gt.0) then
+ is=nclust-1
+ ie=nclust-1
+ icut=1
+ else
+ is=1
+ ie=lev-1
+ endif
+ do i=1,maxgr
+ licz(i)=0
+ enddo
+ icut=1
+ i=is
+ NGR=is+1
+ do j=1,n
+ licz(iclass(j,i))=licz(iclass(j,i))+1
+ nconf(iclass(j,i),licz(iclass(j,i)))=j
+c write (iout,*) i,j,iclass(j,i),licz(iclass(j,i)),
+c & nconf(iclass(j,i),licz(iclass(j,i)))
+ enddo
+c do i=1,lev-1
+ do i=is,ie
+ idum=lev-i
+ DO L=1,LEV
+ IF (HEIGHT(L).EQ.IDUM) GOTO 190
+ ENDDO
+ 190 IDUM=L
+ write(IOUT,*) "i+1",i+1," idum",idum," critval",CRITVAL(IDUM),
+ & " icut",icut," cutoff",rcutoff(icut)
+ IF (nclust.gt.0.or.CRITVAL(IDUM).LT. RCUTOFF(ICUT)) THEN
+ if (nclust.le.0)
+ & WRITE (iout,'(/a,f10.5)') 'AT CUTOFF:',rcutoff(icut)
+ write (iout,'(a,f8.2)') 'Maximum distance found:',
+ & CRITVAL(IDUM)
+ CALL SRTCLUST(ICUT,ncon_work,iT)
+ CALL TRACK(ICUT)
+ CALL WRTCLUST(ncon_work,ICUT,PRINTANG,PRINTPDB,PRINTMOL2,iT)
+ icut=icut+1
+ if (icut.gt.ncut) goto 191
+ ENDIF
+ NGR=i+1
+ do l=1,maxgr
+ licz(l)=0
+ enddo
+ do j=1,n
+ licz(iclass(j,i))=licz(iclass(j,i))+1
+ nconf(iclass(j,i),licz(iclass(j,i)))=j
+c write (iout,*) i,j,iclass(j,i),licz(iclass(j,i)),
+c & nconf(iclass(j,i),licz(iclass(j,i)))
+cd print *,j,iclass(j,i),
+cd & licz(iclass(j,i)),nconf(iclass(j,i),licz(iclass(j,i)))
+ enddo
+ enddo
+ 191 continue
+C
+ if (plot_tree) then
+ CALL WRITRACK
+ CALL PLOTREE
+ endif
+C
+ t2=tcpu()
+ WRITE (iout,'(/a,1pe14.5,a/)')
+ & 'Total time for clustering:',T2-T1,' sec.'
+
+#ifdef MPI
+ endif
+#endif
+ 192 continue
+ enddo
+C
+ close(icbase,status="delete")
+#ifdef MPI
+ call MPI_Finalize(IERROR)
+#endif
+ stop '********** Program terminated normally.'
+ 20 write (iout,*) "Error reading coordinates"
+#ifdef MPI
+ call MPI_Finalize(IERROR)
+#endif
+ stop
+ 30 write (iout,*) "Error reading reference structure"
+#ifdef MPI
+ call MPI_Finalize(IERROR)
+#endif
+ stop
+ end
+c---------------------------------------------------------------------------
+ double precision function difconf(icon,jcon)
+ implicit none
+ include 'DIMENSIONS'
+ include 'sizesclu.dat'
+ include 'COMMON.CONTROL'
+ include 'COMMON.CLUSTER'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.VAR'
+ include 'COMMON.IOUNITS'
+ integer ipermmin
+ double precision przes(3),obrot(3,3)
+ double precision rmscalc
+ integer icon,jcon,k,l
+c write (iout,*) "DIFCONF: ICON",icon," JCON",jcon
+ do k=1,2*nres
+ do l=1,3
+ cref(l,k)=allcart(l,k,icon)
+ c(l,k)=allcart(l,k,jcon)
+ enddo
+ enddo
+ difconf=rmscalc(c(1,1),cref(1,1),przes,obrot,ipermmin)
+ RETURN
+ END
+C------------------------------------------------------------------------------
+ subroutine distout(ncon)
+ implicit none
+ include 'DIMENSIONS'
+ include 'sizesclu.dat'
+ integer ncol,ncon
+ parameter (ncol=10)
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CLUSTER'
+ integer i,j,k,jlim,jlim1,nlim,ind,ioffset
+ real*4 b
+ dimension b(ncol)
+ write (iout,'(a)') 'The distance matrix'
+ do 1 i=1,ncon,ncol
+ nlim=min0(i+ncol-1,ncon)
+ write (iout,1000) (k,k=i,nlim)
+ write (iout,'(8h--------,10a)') ('-------',k=i,nlim)
+ 1000 format (/8x,10(i4,3x))
+ 1020 format (/1x,80(1h-)/)
+ do 2 j=i,ncon
+ jlim=min0(j,nlim)
+ if (jlim.eq.j) then
+ b(jlim-i+1)=0.0d0
+ jlim1=jlim-1
+ else
+ jlim1=jlim
+ endif
+ do 3 k=i,jlim1
+ if (j.lt.k) then
+ IND=IOFFSET(NCON,j,k)
+ else
+ IND=IOFFSET(NCON,k,j)
+ endif
+ 3 b(k-i+1)=diss(IND)
+ write (iout,1010) j,(b(k),k=1,jlim-i+1)
+ 2 continue
+ 1 continue
+ 1010 format (i5,3x,10(f6.2,1x))
+ return
+ end
--- /dev/null
+ SUBROUTINE MATMULT(A1,A2,A3)
+ 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
+ LOGICAL FUNCTION NOYES()
+ CHARACTER*1 ANSWER
+ 101 READ (*,'(A1)') ANSWER
+ IF ( (ANSWER.EQ.'y') .OR. (ANSWER.EQ.'Y') ) THEN
+ NOYES=.TRUE.
+ RETURN
+ ELSE IF ( (ANSWER.EQ.'n') .OR. (ANSWER.EQ.'N') ) THEN
+ NOYES=.FALSE.
+ RETURN
+ ELSE
+* PRINT *,CHAR(7)
+ PRINT *,'Incorrect keyword. Enter Y or N - '
+ GOTO 101
+ ENDIF
+ END
+
--- /dev/null
+ subroutine oligomer
+ implicit none
+ include "DIMENSIONS"
+ include "COMMON.CHAIN"
+ include "COMMON.INTERACT"
+ include "COMMON.IOUNITS"
+ integer nchain,i,ii,ipi,ipj,ipmin,j,jmin,k,ix,iy,iz,
+ & ixmin,iymin,izmin
+ logical newchain
+ integer ichain(2,20),iper(20),iaux
+ double precision dchain,dchainmin,cmchain(3,20)
+ nchain=1
+ newchain=.false.
+ ichain(1,nchain)=1
+ do i=2,nres
+ if (itype(i).eq.ntyp1) then
+ if (newchain) then
+ ichain(2,nchain)=i
+ nchain=nchain+1
+ newchain=.false.
+ else
+ newchain=.true.
+ ichain(1,nchain)=i
+ endif
+ endif
+ enddo
+ ichain(2,nchain)=nres
+ write (iout,*) "Chains"
+ do i=1,nchain
+ write (iout,*) i,ichain(1,i),ichain(2,i)
+ enddo
+ cmchain=0.0d0
+ do i=1,nchain
+ ii=0
+ do j=ichain(1,i),ichain(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
+ 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
+ if (dchain.lt.dchainmin) then
+ dchainmin=dchain
+ ixmin=ix
+ iymin=iy
+ izmin=iz
+ jmin=j
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ cmchain(1,jmin)=cmchain(1,jmin)+ixmin*boxxsize
+ cmchain(2,jmin)=cmchain(2,jmin)+iymin*boxysize
+ cmchain(3,jmin)=cmchain(3,jmin)+izmin*boxzsize
+ do k=ichain(1,jmin),ichain(2,jmin)
+ c(1,k)=c(1,k)+ixmin*boxxsize
+ c(2,k)=c(2,k)+iymin*boxysize
+ c(3,k)=c(3,k)+izmin*boxzsize
+ enddo
+ write (iout,*) "jmin",jmin," ixmin",ixmin," iymin",iymin,
+ & " izmin",izmin
+ iaux=iper(i+1)
+ iper(i+1)=iper(jmin)
+ iper(jmin)=iaux
+ enddo
+ return
+ end
--- /dev/null
+ subroutine parmread
+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 'sizesclu.dat'
+ 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.SCCOR'
+ include 'COMMON.SCROT'
+ 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*3 lancuch,ucase
+C
+C Body
+C
+ write (iout,*) "PARMREAD tor_mode",tor_mode
+ 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
+#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
+ read(iliptranpar,*,end=1161,err=1161) pepliptran
+ do i=1,ntyp
+ read(iliptranpar,*,end=1161,err=1161) liptranene(i)
+ enddo
+ close(iliptranpar)
+#ifdef CRYST_THETA
+C
+C Read the parameters of the probability distribution/energy expression
+C of the virtual-bond valence angles theta
+C
+ do i=1,ntyp
+ read (ithep,*,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 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
+ do iblock=1,2
+ write (iout,*) 'ityp',i,' jtyp',j," block",iblock
+ 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
+ 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)=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,*) "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_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 electrostatic energy parameters.Lip"
+ 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
+ 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 probabl(ib,nlist,ncon,*)
+! construct the conformational ensembles at REMD temperatures
+ implicit none
+ include "DIMENSIONS"
+ include "sizesclu.dat"
+#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.FFIELD"
+ include "COMMON.INTERACT"
+ include "COMMON.SBRIDGE"
+ include "COMMON.CHAIN"
+ include "COMMON.CLUSTER"
+ 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,evdw2,ees,evdw1,ebe,etors,escloc,
+ & ehpb,ecorr,ecorr5,ecorr6,eello_turn4,eello_turn3,
+ & eturn6,eel_loc,edihcnstr,etors_d,estr,evdw2_14,esccor,
+ & evdw_t,esaxs,eliptran,ethetacnstr,ehomology_constr,
+ & edfadis,edfator,edfanei,edfabet
+ integer i,ii,ik,iproc,iscor,j,k,l,ib,nlist,ncon
+ double precision qfree,sumprob,eini,efree,rmsdev
+ character*80 bxname
+ character*2 licz1
+ character*5 ctemper
+ integer ilen,ijk
+ external ilen
+ character*80 structure/'Structure'/
+ real*4 Fdimless(maxconf), Fdimless_buf(maxconf)
+ double precision energia(0:max_ene), totfree_buf(0:maxconf),
+ & entfac_buf(maxconf)
+ double precision buffer(maxconf)
+ do i=1,ncon
+ list_conf(i)=i
+ enddo
+c do i=1,ncon
+c write (iout,*) i,list_conf(i)
+c enddo
+#ifdef MPI
+ write (iout,*) me," indstart",indstart(me)," indend",indend(me)
+ call daread_ccoords(indstart(me),indend(me))
+#endif
+C write (iout,*) "ncon",ncon
+C call flush(iout)
+ temper=1.0d0/(beta_h(ib)*1.987D-3)
+ if (rescale_mode.eq.1) then
+ quot=1.0d0/(T0*beta_h(ib)*1.987D-3)
+ 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)
+ 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=1.0d0/(T0*beta_h(ib)*1.987D-3)
+ 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)*1.987D-3),ft
+c call flush(iout)
+#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
+ endif
+
+#ifdef MPI
+ do i=1,scount(me)
+ ii=i+indstart(me)-1
+#else
+ do i=1,ncon
+ ii=i
+#endif
+C write (iout,*) "i",i," ii",ii,"ib",ib,scount(me)
+c call flush(iout)
+c if (ib.eq.1) then
+ do j=1,nres
+ do k=1,3
+ c(k,j)=allcart(k,j,i)
+ c(k,j+nres)=allcart(k,j+nres,i)
+C write(iout,*) "coord",i,j,k,allcart(k,j,i),c(k,j),
+C & c(k,j+nres),allcart(k,j+nres,i)
+ enddo
+ enddo
+C write(iout,*) "out of j loop"
+C call flush(iout)
+ do k=1,3
+ c(k,nres+1)=c(k,1)
+ c(k,nres+nres)=c(k,nres)
+ enddo
+C write(iout,*) "after nres+nres",nss_all(i)
+C call flush(iout)
+ nss=nss_all(i)
+ do j=1,nss
+ ihpb(j)=ihpb_all(j,i)
+ jhpb(j)=jhpb_all(j,i)
+ enddo
+ call int_from_cart1(.false.)
+ call etotal(energia(0),fT)
+ if (refstr) then
+ write (structure(9:),'(bz,i6.6)') i
+ call TMscore_sub(rmsdev,gdt_ts_tb(i),
+ & gdt_ha_tb(i),tmscore_tb(i),Structure,.false.)
+#ifdef DEBUG
+ write (iout,*) rmsdev,gdt_ts_tb(i),gdt_ha_tb(i),
+ & tmscore_tb(i)
+#endif
+ endif
+ totfree(i)=energia(0)
+ totfree_buf(i)=totfree(i)
+c write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres)
+c write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct)
+c call pdbout(totfree(i),16,i)
+c call flush(iout)
+#ifdef DEBUG
+ write (iout,*) "conformation", i
+ call enerprint(energia(0),fT)
+#endif
+ etot=energia(0)
+ Fdimless(i)=beta_h(ib)*etot+entfac(ii)
+ Fdimless_buf(i)=Fdimless(i)
+ totfree(i)=etot
+ totfree_buf(i)=totfree(i)
+#ifdef DEBUG
+ write (iout,*) "fdim calc", i,ii,ib,
+ & 1.0d0/(1.987d-3*beta_h(ib)),totfree(i),
+ & entfac(ii),Fdimless(i)
+#endif
+ enddo ! i
+
+ do ijk=1,maxconf
+ entfac_buf(ijk)=entfac(ijk)
+ Fdimless_buf(ijk)=Fdimless(ijk)
+ enddo
+ do ijk=0,maxconf
+ totfree_buf(ijk)=totfree(ijk)
+ enddo
+
+
+c scount_buf=scount(me)
+c scount_buf2=scount(0)
+
+c entfac_buf(indstart(me)+1)=entfac(indstart(me)+1)
+
+#ifdef MPI
+c WRITE (iout,*) "Wchodze do call MPI_Gatherv1 (Propabl)"
+ call MPI_Gatherv(Fdimless_buf(1),scount(me),
+ & MPI_REAL,Fdimless(1),
+ & scount(0),idispl(0),MPI_REAL,Master,
+ & MPI_COMM_WORLD, IERROR)
+c WRITE (iout,*) "Wchodze do call MPI_Gatherv2 (Propabl)"
+ call MPI_Gatherv(totfree_buf(1),scount(me),
+ & MPI_DOUBLE_PRECISION,totfree(1),
+ & scount(0),idispl(0),MPI_DOUBLE_PRECISION,Master,
+ & MPI_COMM_WORLD, IERROR)
+c WRITE (iout,*) "Wchodze do call MPI_Gatherv3 (Propabl)"
+ call MPI_Gatherv(entfac_buf(indstart(me)+1),scount(me),
+ & MPI_DOUBLE_PRECISION,entfac(1),
+ & scount(0),idispl(0),MPI_DOUBLE_PRECISION,Master,
+ & MPI_COMM_WORLD, IERROR)
+c WRITE (iout,*) "Wychodze z call MPI_Gatherv (Propabl)"
+ if (refstr) then
+ do i=1,scount(me)
+ buffer(i)=gdt_ts_tb(i)
+ enddo
+ call MPI_Gatherv(buffer(1),scount(me),MPI_DOUBLE_PRECISION,
+ & gdt_ts_tb(1),scount(0),idispl(0),MPI_DOUBLE_PRECISION,Master,
+ & MPI_COMM_WORLD,IERROR)
+ do i=1,scount(me)
+ buffer(i)=gdt_ha_tb(i)
+ enddo
+ call MPI_Gatherv(buffer(1),scount(me),MPI_DOUBLE_PRECISION,
+ & gdt_ha_tb(1),scount(0),idispl(0),MPI_DOUBLE_PRECISION,Master,
+ & MPI_COMM_WORLD,IERROR)
+ do i=1,scount(me)
+ buffer(i)=tmscore_tb(i)
+ enddo
+ call MPI_Gatherv(buffer(1),scount(me),MPI_DOUBLE_PRECISION,
+ & tmscore_tb(1),scount(0),idispl(0),MPI_DOUBLE_PRECISION,Master,
+ & MPI_COMM_WORLD,IERROR)
+ endif
+ if (me.eq.Master) then
+c WRITE (iout,*) "me.eq.Master"
+#endif
+#ifdef DEBUG
+ write (iout,*) "The FDIMLESS array before sorting"
+ do i=1,ncon
+ write (iout,*) i,fdimless(i)
+ enddo
+#endif
+c WRITE (iout,*) "Wchodze do call mysort1"
+ call mysort1(ncon,Fdimless,list_conf)
+c WRITE (iout,*) "Wychodze z call mysort1"
+#ifdef DEBUG
+ write (iout,*) "The FDIMLESS array after sorting"
+ do i=1,ncon
+ write (iout,'(2i5,4f10.5)') i,list_conf(i),fdimless(i),
+ & gdt_ts_tb(i),gdt_ha_tb(i),tmscore_tb(i)
+ enddo
+#endif
+c WRITE (iout,*) "Wchodze do petli i=1,ncon totfree(i)=fdimless(i)"
+ do i=1,ncon
+ totfree(i)=fdimless(i)
+ enddo
+ qfree=0.0d0
+ do i=1,ncon
+ qfree=qfree+exp(-fdimless(i)+fdimless(1))
+c write (iout,*) "fdimless", fdimless(i)
+ enddo
+c write (iout,*) "qfree",qfree
+ nlist=1
+ sumprob=0.0
+ write (iout,*) "ncon", ncon,maxstr_proc
+ do i=1,min0(ncon,maxstr_proc)-1
+ sumprob=sumprob+exp(-fdimless(i)+fdimless(1))/qfree
+#ifdef DEBUG
+ write (iout,*) i,ib,beta_h(ib),
+ & 1.0d0/(1.987d-3*beta_h(ib)),list_conf(i),
+ & totfree(list_conf(i)),
+ & -entfac(list_conf(i)),fdimless(i),sumprob
+#endif
+ if (sumprob.gt.prob_limit) goto 122
+c if (sumprob.gt.1.00d0) goto 122
+ nlist=nlist+1
+ enddo
+ 122 continue
+#ifdef MPI
+ endif
+ call MPI_Bcast(nlist, 1, MPI_INTEGER, Master, MPI_COMM_WORLD,
+ & IERROR)
+ call MPI_Bcast(list_conf,nlist,MPI_INTEGER,Master,MPI_COMM_WORLD,
+ & IERROR)
+c do iproc=0,nprocs
+c write (iout,*) "iproc",iproc," indstart",indstart(iproc),
+c & " indend",indend(iproc)
+c enddo
+ write (iout,*) "nlist",nlist
+#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
+#include <stdlib.h>
+#include <math.h>
+#include <stdio.h>
+
+#ifdef CRAY
+void PROC_PROC(long int *f, int *i)
+#else
+#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
+#if defined(WIN) && !defined(WINIFL)
+void _stdcall PROC_PROC(long int *f, int *i)
+#endif
+#ifdef WINIFL
+void proc_proc(long int *f, int *i)
+#endif
+#if defined(AIX) || defined(WINPGI)
+void proc_proc(long int *f, int *i)
+#endif
+#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 CRAY
+void PROC_CONV(char *buf, int *i, int n)
+#endif
+#ifdef LINUX
+void proc_conv__(char *buf, int *i, int n)
+#endif
+#ifdef SGI
+void proc_conv_(char *buf, int *i, int n)
+#endif
+#if defined(AIX) || defined(WINPGI)
+void proc_conv(char *buf, int *i, int n)
+#endif
+#ifdef WIN
+void _stdcall PROC_CONV(char *buf, int *i, int n)
+#endif
+{
+int j;
+
+sscanf(buf,"%d",&j);
+*i=j;
+return;
+}
+
+#ifdef CRAY
+void PROC_CONV_R(char *buf, int *i, int n)
+#endif
+#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 CRAY
+void DSVRGP(int *n, double *tab1, double *tab2, int *itab)
+#endif
+#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 read_constr_homology
+
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.SETUP'
+ include 'COMMON.CONTROL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.INTERACT'
+ include 'COMMON.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)
+ 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)
+ write (iout,*) "homol_nset ",homol_nset
+ if (homol_nset.gt.1)then
+ call card_concat(controlcard)
+ 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(out_template_coord)
+ 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'
+#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)
+ write (iout,*) "read_klapaucjusz ",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_coords(ncon,*)
+ implicit none
+ include "DIMENSIONS"
+ include "sizesclu.dat"
+#ifdef MPI
+ include "mpif.h"
+ integer IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE)
+ include "COMMON.MPI"
+#endif
+ include "COMMON.CONTROL"
+ include "COMMON.CHAIN"
+ include "COMMON.INTERACT"
+ include "COMMON.IOUNITS"
+ include "COMMON.VAR"
+ include "COMMON.SBRIDGE"
+ include "COMMON.GEO"
+ include "COMMON.CLUSTER"
+ character*3 liczba
+ integer ncon
+ integer i,j,jj,jjj,jj_old,icount,k,kk,l,ii,if,ib,
+ & nn,nn1,inan
+ integer ixdrf,iret,itmp
+ real*4 prec,reini,refree,rmsdev
+ integer nrec,nlines,iscor,lenrec,lenrec_in
+ double precision energ,t_acq,tcpu
+ integer ilen,iroof
+ external ilen,iroof
+ double precision rjunk
+ integer ntot_all(0:maxprocs-1)
+ logical lerr
+ double precision energia(0:max_ene),etot
+ real*4 csingle(3,maxres2+2)
+ integer Previous,Next
+ character*256 bprotfiles
+c print *,"Processor",me," calls read_protein_data"
+#ifdef MPI
+ if (me.eq.master) then
+ Previous=MPI_PROC_NULL
+ else
+ Previous=me-1
+ endif
+ if (me.eq.nprocs-1) then
+ Next=MPI_PROC_NULL
+ else
+ Next=me+1
+ endif
+c Set the scratchfile names
+ write (liczba,'(bz,i3.3)') me
+#endif
+c 1/27/05 AL Change stored coordinates to single precision and don't store
+c energy components in the binary databases.
+ lenrec=12*(nres+nct-nnt+1)+4*(2*nss+2)+16
+ lenrec_in=12*(nres+nct-nnt+1)+4*(2*nss+2)+24
+#ifdef DEBUG
+ write (iout,*) "nres",nres," nnt",nnt," nct",nct," nss", nss
+ write (iout,*) "lenrec_in",lenrec_in
+#endif
+ bprotfiles=scratchdir(:ilen(scratchdir))//
+ & "/"//prefix(:ilen(prefix))//liczba//".xbin"
+
+#ifdef CHUJ
+ ICON=1
+ 123 continue
+ if (from_cart .and. .not. from_bx .and. .not. from_cx) then
+ if (lefree) then
+ read (intin,*,end=13,err=11) energy(icon),totfree(icon),
+ & rmstb(icon),
+ & nss_all(icon),(ihpb_all(ii,icon),jhpb_all(i,icon),
+ & i=1,nss_all(icon)),iscore(icon)
+ else
+ read (intin,*,end=13,err=11) energy(icon),rmstb(icon),
+ & nss_all(icon),(ihpb_all(ii,icon),jhpb_all(i,icon),
+ & i=1,nss_all(icon)),iscore(icon)
+ endif
+ read (intin,'(8f10.5)',end=13,err=10)
+ & ((allcart(j,i,icon),j=1,3),i=1,nres),
+ & ((allcart(j,i+nres,icon),j=1,3),i=nnt,nct)
+ print *,icon,energy(icon),nss_all(icon),rmstb(icon)
+ else
+ read(intin,'(a80)',end=13,err=12) lineh
+ read(lineh(:5),*,err=8) ic
+ if (lefree) then
+ read(lineh(6:),*,err=8) energy(icon)
+ else
+ read(lineh(6:),*,err=8) energy(icon)
+ endif
+ goto 9
+ 8 ic=1
+ print *,'error, assuming e=1d10',lineh
+ energy(icon)=1d10
+ nss=0
+ 9 continue
+cold read(lineh(18:),*,end=13,err=11) nss_all(icon)
+ ii = index(lineh(15:)," ")+15
+ read(lineh(ii:),*,end=13,err=11) nss_all(icon)
+ IF (NSS_all(icon).LT.9) THEN
+ read (lineh(20:),*,end=102)
+ & (IHPB_all(I,icon),JHPB_all(I,icon),I=1,NSS_all(icon)),
+ & iscore(icon)
+ ELSE
+ read (lineh(20:),*,end=102)
+ & (IHPB_all(I,icon),JHPB_all(I,icon),I=1,8)
+ read (intin,*) (IHPB_all(I,icon),JHPB_all(I,icon),
+ & I=9,NSS_all(icon)),iscore(icon)
+ ENDIF
+
+ 102 continue
+
+ PRINT *,'IC:',IC,' ENERGY:',ENERGY(ICON)
+ call read_angles(intin,*13)
+ do i=1,nres
+ phiall(i,icon)=phi(i)
+ thetall(i,icon)=theta(i)
+ alphall(i,icon)=alph(i)
+ omall(i,icon)=omeg(i)
+ enddo
+ endif
+ ICON=ICON+1
+ GOTO 123
+C
+C CALCULATE DISTANCES
+C
+ 10 print *,'something wrong with angles'
+ goto 13
+ 11 print *,'something wrong with NSS',nss
+ goto 13
+ 12 print *,'something wrong with header'
+
+ 13 NCON=ICON-1
+
+#endif
+ call flush(iout)
+ jj_old=1
+ open (icbase,file=bprotfiles,status="unknown",
+ & form="unformatted",access="direct",recl=lenrec)
+c Read conformations from binary DA files (one per batch) and write them to
+c a binary DA scratchfile.
+ jj=0
+ jjj=0
+#ifdef MPI
+ write (liczba,'(bz,i3.3)') me
+ IF (ME.EQ.MASTER) THEN
+c Only the master reads the database; it'll send it to the other procs
+c through a ring.
+#endif
+ t_acq = tcpu()
+ icount=0
+
+ if (from_bx) then
+
+ open (intin,file=intinname,status="old",form="unformatted",
+ & access="direct",recl=lenrec_in)
+
+ else if (from_cx) then
+#if (defined(AIX) && !defined(JUBL))
+ call xdrfopen_(ixdrf,intinname, "r", iret)
+#else
+ call xdrfopen(ixdrf,intinname, "r", iret)
+#endif
+ prec=10000.0
+ write (iout,*) "xdrfopen: iret",iret
+ if (iret.eq.0) then
+ write (iout,*) "Error: coordinate file ",
+ & intinname(:ilen(intinname))," does not exist."
+ call flush(iout)
+#ifdef MPI
+ call MPI_ABORT(MPI_COMM_WORLD,IERROR,ERRCODE)
+#endif
+ stop
+ endif
+ else
+ write (iout,*) "Error: coordinate format not specified"
+ call flush(iout)
+#ifdef MPI
+ call MPI_ABORT(MPI_COMM_WORLD,IERROR,ERRCODE)
+#else
+ stop
+#endif
+ endif
+
+C#define DEBUG
+#ifdef DEBUG
+ write (iout,*) "Opening file ",intinname(:ilen(intinname))
+ write (iout,*) "lenrec",lenrec_in
+ call flush(iout)
+#endif
+C#undef DEBUG
+c write (iout,*) "maxconf",maxconf
+ i=0
+ do while (.true.)
+ i=i+1
+ if (i.gt.maxconf) then
+ write (iout,*) "Error: too many conformations ",
+ & "(",maxconf,") maximum."
+#ifdef MPI
+ call MPI_Abort(MPI_COMM_WORLD,errcode,ierror)
+#endif
+ stop
+ endif
+c write (iout,*) "i",i
+c call flush(iout)
+ if (from_bx) then
+ read(intin,err=101,end=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),
+ & energy(jj+1),
+ & entfac(jj+1),rmstb(jj+1),iscor
+ do j=1,2*nres
+ do k=1,3
+ c(k,j)=csingle(k,j)
+ enddo
+ enddo
+ else
+#if (defined(AIX) && !defined(JUBL))
+ call xdrf3dfcoord_(ixdrf, csingle, itmp, prec, iret)
+ if (iret.eq.0) goto 101
+ call xdrfint_(ixdrf, nss, iret)
+ if (iret.eq.0) goto 101
+ do j=1,nss
+ if (dyn_ss) then
+ call xdrfint(ixdrf, idssb(j), iret)
+ call xdrfint(ixdrf, jdssb(j), iret)
+ idssb(j)=idssb(j)-nres
+ jdssb(j)=jdssb(j)-nres
+ else
+ call xdrfint_(ixdrf, ihpb(j), iret)
+ if (iret.eq.0) goto 101
+ call xdrfint_(ixdrf, jhpb(j), iret)
+ if (iret.eq.0) goto 101
+ endif
+ enddo
+ call xdrffloat_(ixdrf,reini,iret)
+ if (iret.eq.0) goto 101
+ call xdrffloat_(ixdrf,refree,iret)
+ if (iret.eq.0) goto 101
+ call xdrffloat_(ixdrf,rmsdev,iret)
+ if (iret.eq.0) goto 101
+ call xdrfint_(ixdrf,iscor,iret)
+ if (iret.eq.0) goto 101
+#else
+c write (iout,*) "calling xdrf3dfcoord"
+ call xdrf3dfcoord(ixdrf, csingle, itmp, prec, iret)
+c write (iout,*) "iret",iret
+c call flush(iout)
+ if (iret.eq.0) goto 101
+ call xdrfint(ixdrf, nss, iret)
+c write (iout,*) "iret",iret
+c write (iout,*) "nss",nss
+ call flush(iout)
+ if (iret.eq.0) goto 101
+ do k=1,nss
+ if (dyn_ss) then
+ call xdrfint(ixdrf, idssb(k), iret)
+ call xdrfint(ixdrf, jdssb(k), iret)
+ else
+ call xdrfint(ixdrf, ihpb(k), iret)
+ if (iret.eq.0) goto 101
+ call xdrfint(ixdrf, jhpb(k), iret)
+ if (iret.eq.0) goto 101
+ endif
+ enddo
+ call xdrffloat(ixdrf,reini,iret)
+ if (iret.eq.0) goto 101
+ call xdrffloat(ixdrf,refree,iret)
+ if (iret.eq.0) goto 101
+ call xdrffloat(ixdrf,rmsdev,iret)
+ if (iret.eq.0) goto 101
+ call xdrfint(ixdrf,iscor,iret)
+ if (iret.eq.0) goto 101
+#endif
+ energy(jj+1)=reini
+ entfac(jj+1)=refree
+ rmstb(jj+1)=rmsdev
+#ifdef DEBUG
+ write (iout,*) "jj",jj+1," energy",energy(jj+1),
+ & " entfac",entfac(jj+1)," rmsd",rmstb(jj+1)
+#endif
+ 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,nres+k)=csingle(l,nres+k-nnt+1)
+ enddo
+ enddo
+ endif
+C#define DEBUG
+#ifdef DEBUG
+ write (iout,'(5hREAD ,i5,3f15.4,i10)')
+ & jj+1,energy(jj+1),entfac(jj+1),
+ & rmstb(jj+1),iscor
+ write (iout,*) "Conformation",jjj+1,jj+1
+ 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)
+ call flush(iout)
+#endif
+C#undef DEBUG
+ call add_new_cconf(jjj,jj,jj_old,icount,Next)
+ enddo
+ 101 continue
+ write (iout,*) i-1," conformations read from DA file ",
+ & intinname(:ilen(intinname))
+ write (iout,*) jj," conformations read so far"
+ if (from_bx) then
+ close(intin)
+ else
+#if (defined(AIX) && !defined(JUBL))
+ call xdrfclose_(ixdrf, iret)
+#else
+ call xdrfclose(ixdrf, iret)
+#endif
+ endif
+#ifdef MPI
+#ifdef DEBUG
+ write (iout,*) "jj_old",jj_old," jj",jj
+#endif
+ call write_and_send_cconf(icount,jj_old,jj,Next)
+ call MPI_Send(0,1,MPI_INTEGER,Next,570,
+ & MPI_COMM_WORLD,IERROR)
+ jj_old=jj+1
+#else
+ call write_and_send_cconf(icount,jj_old,jj,Next)
+#endif
+ t_acq = tcpu() - t_acq
+#ifdef MPI
+ write (iout,*) "Processor",me,
+ & " time for conformation read/send",t_acq
+ ELSE
+c A worker gets the confs from the master and sends them to its neighbor
+ t_acq = tcpu()
+ call receive_and_pass_cconf(icount,jj_old,jj,
+ & Previous,Next)
+ t_acq = tcpu() - t_acq
+ ENDIF
+#endif
+ ncon=jj
+c close(icbase)
+ close(intin)
+
+ write(iout,*)"A total of",ncon," conformations read."
+
+#ifdef MPI
+c Check if everyone has the same number of conformations
+ call MPI_Allgather(ncon,1,MPI_INTEGER,
+ & ntot_all(0),1,MPI_INTEGER,MPI_Comm_World,IERROR)
+ lerr=.false.
+ do i=0,nprocs-1
+ if (i.ne.me) then
+ if (ncon.ne.ntot_all(i)) then
+ write (iout,*) "Number of conformations at processor",i,
+ & " differs from that at processor",me,
+ & ncon,ntot_all(i)
+ lerr = .true.
+ endif
+ endif
+ enddo
+ if (lerr) then
+ write (iout,*)
+ write (iout,*) "Number of conformations read by processors"
+ write (iout,*)
+ do i=0,nprocs-1
+ write (iout,'(8i10)') i,ntot_all(i)
+ enddo
+ write (iout,*) "Calculation terminated."
+ call flush(iout)
+ return1
+ endif
+ return
+#endif
+ 1111 write(iout,*) "Error opening coordinate file ",
+ & intinname(:ilen(intinname))
+ call flush(iout)
+ return1
+ end
+c------------------------------------------------------------------------------
+ subroutine add_new_cconf(jjj,jj,jj_old,icount,Next)
+ implicit none
+ include "DIMENSIONS"
+ include "sizesclu.dat"
+ include "COMMON.CLUSTER"
+ include "COMMON.CONTROL"
+ include "COMMON.CHAIN"
+ include "COMMON.INTERACT"
+ include "COMMON.LOCAL"
+ include "COMMON.IOUNITS"
+ include "COMMON.NAMES"
+ include "COMMON.VAR"
+ include "COMMON.SBRIDGE"
+ include "COMMON.GEO"
+ integer i,j,jj,jjj,jj_old,icount,k,kk,l,ii,ib
+ & nn,nn1,inan,Next,itj,chalen
+ double precision etot,energia(0:max_ene)
+ jjj=jjj+1
+ chalen=int((nct-nnt+2)/symetr)
+ call int_from_cart1(.false.)
+ do j=nnt+1,nct
+ if ((vbld(j).lt.2.0d0 .or. vbld(j).gt.5.0d0)
+ & .and.(itype(j).ne.ntyp1)) then
+ if (j.gt.2) then
+ if (itel(j).ne.0 .and. itel(j-1).ne.0) then
+ write (iout,*) "Conformation",jjj,jj+1
+ write (iout,*) "Bad CA-CA bond length",j," ",vbld(j),itel(j),
+ & chalen
+ 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,*)
+ & "This conformation WILL NOT be added to the database."
+ return
+ endif
+ endif
+ endif
+ enddo
+ do j=nnt,nct
+ itj=itype(j)
+ if (itype(j).ne.10 .and. (vbld(nres+j)-dsc(iabs(itj))).gt.2.0d0
+ & .and. itype(j).ne.ntyp1) then
+ write (iout,*) "Conformation",jjj,jj+1
+ write (iout,*) "Bad CA-SC bond length",j," ",vbld(nres+j)
+ write (iout,*) "The Cartesian geometry is:"
+ 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,*)
+ & "This conformation WILL NOT be added to the database."
+ return
+ endif
+ enddo
+ do j=3,nres
+ if (theta(j).le.0.0d0) then
+ write (iout,*)
+ & "Zero theta angle(s) in conformation",jjj,jj+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:"
+ 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,*)
+ & "This conformation WILL NOT be added to the database."
+ return
+ endif
+ if (theta(j).gt.179.97*deg2rad) theta(j)=179.97*deg2rad
+ enddo
+ jj=jj+1
+#ifdef DEBUG
+ write (iout,*) "Conformation",jjj,jj
+ 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,'(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)') (vbld(k+nres),k=nnt,nct)
+ 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,'(e15.5,16i5)') entfac(icount+1)
+c & iscore(icount+1,0)
+#endif
+ icount=icount+1
+ call store_cconf_from_file(jj,icount)
+ if (icount.eq.maxstr_proc) then
+#ifdef DEBUG
+ write (iout,* ) "jj_old",jj_old," jj",jj
+#endif
+ call write_and_send_cconf(icount,jj_old,jj,Next)
+ jj_old=jj+1
+ icount=0
+ endif
+ return
+ end
+c------------------------------------------------------------------------------
+ subroutine store_cconf_from_file(jj,icount)
+ implicit none
+ include "DIMENSIONS"
+ include "sizesclu.dat"
+ include "COMMON.CLUSTER"
+ include "COMMON.CHAIN"
+ include "COMMON.SBRIDGE"
+ include "COMMON.INTERACT"
+ include "COMMON.IOUNITS"
+ include "COMMON.VAR"
+ integer i,j,jj,icount
+c Store the conformation that has been read in
+ do i=1,2*nres
+ do j=1,3
+ allcart(j,i,icount)=c(j,i)
+ enddo
+ enddo
+ nss_all(icount)=nss
+ do i=1,nss
+ ihpb_all(i,icount)=ihpb(i)
+ jhpb_all(i,icount)=jhpb(i)
+ enddo
+ return
+ end
+c------------------------------------------------------------------------------
+ subroutine write_and_send_cconf(icount,jj_old,jj,Next)
+ implicit none
+ include "DIMENSIONS"
+ include "sizesclu.dat"
+#ifdef MPI
+ include "mpif.h"
+ integer IERROR
+ include "COMMON.MPI"
+#endif
+ include "COMMON.CHAIN"
+ include "COMMON.SBRIDGE"
+ include "COMMON.INTERACT"
+ include "COMMON.IOUNITS"
+ include "COMMON.CLUSTER"
+ include "COMMON.VAR"
+ integer icount,jj_old,jj,Next
+c Write the structures to a scratch file
+#ifdef MPI
+c Master sends the portion of conformations that have been read in to the neighbor
+#ifdef DEBUG
+ write (iout,*) "Processor",me," entered WRITE_AND_SEND_CONF"
+ call flush(iout)
+#endif
+ call MPI_Send(icount,1,MPI_INTEGER,Next,570,MPI_COMM_WORLD,IERROR)
+ call MPI_Send(nss_all(1),icount,MPI_INTEGER,
+ & Next,571,MPI_COMM_WORLD,IERROR)
+ call MPI_Send(ihpb_all(1,1),icount,MPI_INTEGER,
+ & Next,572,MPI_COMM_WORLD,IERROR)
+ call MPI_Send(jhpb_all(1,1),icount,MPI_INTEGER,
+ & Next,573,MPI_COMM_WORLD,IERROR)
+ call MPI_Send(rmstb(jj_old),icount,MPI_DOUBLE_PRECISION,
+ & Next,577,MPI_COMM_WORLD,IERROR)
+ call MPI_Send(entfac(jj_old),icount,MPI_DOUBLE_PRECISION,
+ & Next,579,MPI_COMM_WORLD,IERROR)
+ call MPI_Send(allcart(1,1,1),3*icount*maxres2,
+ & MPI_REAL,Next,580,MPI_COMM_WORLD,IERROR)
+#endif
+ call dawrite_ccoords(jj_old,jj,icbase)
+#ifdef DEBUG
+ write (iout,*) "Processor",me," exit WRITE_AND_SEND_CONF"
+ call flush(iout)
+#endif
+ return
+ end
+c------------------------------------------------------------------------------
+#ifdef MPI
+ subroutine receive_and_pass_cconf(icount,jj_old,jj,Previous,
+ & Next)
+ implicit none
+ include "DIMENSIONS"
+ include "sizesclu.dat"
+ include "mpif.h"
+ integer IERROR,STATUS(MPI_STATUS_SIZE)
+ include "COMMON.MPI"
+ include "COMMON.CHAIN"
+ include "COMMON.SBRIDGE"
+ include "COMMON.INTERACT"
+ include "COMMON.IOUNITS"
+ include "COMMON.VAR"
+ include "COMMON.GEO"
+ include "COMMON.CLUSTER"
+ integer i,j,k,l,icount,jj_old,jj,Previous,Next
+ icount=1
+#ifdef DEBUG
+ write (iout,*) "Processor",me," entered RECEIVE_AND_PASS_CONF"
+ call flush(iout)
+#endif
+ do while (icount.gt.0)
+ call MPI_Recv(icount,1,MPI_INTEGER,Previous,570,MPI_COMM_WORLD,
+ & STATUS,IERROR)
+ call MPI_Send(icount,1,MPI_INTEGER,Next,570,MPI_COMM_WORLD,
+ & IERROR)
+#ifdef DEBUG
+ write (iout,*) "Processor",me," icount",icount
+#endif
+ if (icount.eq.0) return
+ call MPI_Recv(nss_all(1),icount,MPI_INTEGER,
+ & Previous,571,MPI_COMM_WORLD,STATUS,IERROR)
+ call MPI_Send(nss_all(1),icount,MPI_INTEGER,
+ & Next,571,MPI_COMM_WORLD,IERROR)
+ call MPI_Recv(ihpb_all(1,1),icount,MPI_INTEGER,
+ & Previous,572,MPI_COMM_WORLD,STATUS,IERROR)
+ call MPI_Send(ihpb_all(1,1),icount,MPI_INTEGER,
+ & Next,572,MPI_COMM_WORLD,IERROR)
+ call MPI_Recv(jhpb_all(1,1),icount,MPI_INTEGER,
+ & Previous,573,MPI_COMM_WORLD,STATUS,IERROR)
+ call MPI_Send(jhpb_all(1,1),icount,MPI_INTEGER,
+ & Next,573,MPI_COMM_WORLD,IERROR)
+ call MPI_Recv(rmstb(jj_old),icount,MPI_DOUBLE_PRECISION,
+ & Previous,577,MPI_COMM_WORLD,STATUS,IERROR)
+ call MPI_Send(rmstb(jj_old),icount,MPI_DOUBLE_PRECISION,
+ & Next,577,MPI_COMM_WORLD,IERROR)
+ call MPI_Recv(entfac(jj_old),icount,MPI_DOUBLE_PRECISION,
+ & Previous,579,MPI_COMM_WORLD,STATUS,IERROR)
+ call MPI_Send(entfac(jj_old),icount,MPI_DOUBLE_PRECISION,
+ & Next,579,MPI_COMM_WORLD,IERROR)
+ call MPI_Recv(allcart(1,1,1),3*icount*maxres2,
+ & MPI_REAL,Previous,580,MPI_COMM_WORLD,STATUS,IERROR)
+ call MPI_Send(allcart(1,1,1),3*icount*maxres2,
+ & MPI_REAL,Next,580,MPI_COMM_WORLD,IERROR)
+ jj=jj_old+icount-1
+ call dawrite_ccoords(jj_old,jj,icbase)
+ jj_old=jj+1
+#ifdef DEBUG
+ write (iout,*) "Processor",me," received",icount," conformations"
+ do i=1,icount
+ write (iout,'(8f10.4)') ((allcart(l,k,i),l=1,3),k=1,nres)
+ write (iout,'(8f10.4)')((allcart(l,k,i+nres),l=1,3),k=nnt,nct)
+ write (iout,'(e15.5,16i5)') entfac(i)
+ enddo
+#endif
+ enddo
+ return
+ end
+#endif
+c------------------------------------------------------------------------------
+ subroutine daread_ccoords(istart_conf,iend_conf)
+ implicit none
+ include "DIMENSIONS"
+ include "sizesclu.dat"
+#ifdef MPI
+ include "mpif.h"
+ include "COMMON.MPI"
+#endif
+ include "COMMON.CHAIN"
+ include "COMMON.CLUSTER"
+ include "COMMON.IOUNITS"
+ include "COMMON.INTERACT"
+ include "COMMON.VAR"
+ include "COMMON.SBRIDGE"
+ include "COMMON.GEO"
+ integer istart_conf,iend_conf
+ integer i,j,ij,ii,iii
+ integer len
+ character*16 form,acc
+ character*80 nam
+c
+c Read conformations off a DA scratchfile.
+c
+C#define DEBUG
+#ifdef DEBUG
+ write (iout,*) "DAREAD_COORDS"
+ write (iout,*) "istart_conf",istart_conf," iend_conf",iend_conf
+ inquire(unit=icbase,name=nam,recl=len,form=form,access=acc)
+ write (iout,*) "len=",len," form=",form," acc=",acc
+ write (iout,*) "nam=",nam
+ call flush(iout)
+#endif
+ do ii=istart_conf,iend_conf
+ ij = ii - istart_conf + 1
+ iii=list_conf(ii)
+#ifdef DEBUG
+ write (iout,*) "Reading binary file, record",iii," ii",ii
+ call flush(iout)
+#endif
+ if (dyn_ss) then
+ read(icbase,rec=iii) ((allcart(j,i,ij),j=1,3),i=1,nres),
+ & ((allcart(j,i,ij),j=1,3),i=nnt+nres,nct+nres),
+c & nss_all(ij),(ihpb_all(i,ij),jhpb_all(i,ij),i=1,nss),
+ & entfac(ii),rmstb(ii)
+ else
+ read(icbase,rec=iii) ((allcart(j,i,ij),j=1,3),i=1,nres),
+ & ((allcart(j,i,ij),j=1,3),i=nnt+nres,nct+nres),
+ & nss_all(ij),(ihpb_all(i,ij),jhpb_all(i,ij),i=1,nss),
+ & entfac(ii),rmstb(ii)
+ endif
+#ifdef DEBUG
+ write (iout,*) ii,iii,ij,entfac(ii)
+ write (iout,'(8f10.5)') ((allcart(j,i,ij),j=1,3),i=1,nres)
+ write (iout,'(8f10.4)') ((allcart(j,i,ij),j=1,3),
+ & i=nnt+nres,nct+nres)
+ write (iout,'(2e15.5)') entfac(ij)
+ write (iout,'(16i5)') nss_all(ij),(ihpb_all(i,ij),
+ & jhpb_all(i,ij),i=1,nss)
+ call flush(iout)
+#endif
+C#undef DEBUG
+ enddo
+c write (iout,*) "just before leave"
+ call flush(iout)
+ return
+ end
+c------------------------------------------------------------------------------
+ subroutine dawrite_ccoords(istart_conf,iend_conf,unit_out)
+ implicit none
+ include "DIMENSIONS"
+ include "sizesclu.dat"
+#ifdef MPI
+ include "mpif.h"
+ include "COMMON.MPI"
+#endif
+ include "COMMON.CHAIN"
+ include "COMMON.INTERACT"
+ include "COMMON.IOUNITS"
+ include "COMMON.VAR"
+ include "COMMON.SBRIDGE"
+ include "COMMON.GEO"
+ include "COMMON.CLUSTER"
+ integer istart_conf,iend_conf
+ integer i,j,ii,ij,iii,unit_out
+ integer len
+ character*16 form,acc
+ character*32 nam
+c
+c Write conformations to a DA scratchfile.
+c
+#ifdef DEBUG
+ write (iout,*) "DAWRITE_COORDS"
+ write (iout,*) "istart_conf",istart_conf," iend_conf",iend_conf
+ write (iout,*) "lenrec",lenrec
+ inquire(unit=unit_out,name=nam,recl=len,form=form,access=acc)
+ write (iout,*) "len=",len," form=",form," acc=",acc
+ write (iout,*) "nam=",nam
+ call flush(iout)
+#endif
+ do ii=istart_conf,iend_conf
+ iii=list_conf(ii)
+ ij = ii - istart_conf + 1
+#ifdef DEBUG
+ write (iout,*) "Writing binary file, record",iii," ii",ii
+ call flush(iout)
+#endif
+ if (dyn_ss) then
+ write(unit_out,rec=iii) ((allcart(j,i,ij),j=1,3),i=1,nres),
+ & ((allcart(j,i,ij),j=1,3),i=nnt+nres,nct+nres),
+c & nss_all(ij),(ihpb_all(i,ij),jhpb_all(i,ij),i=1,nss_all(ij))
+ & entfac(ii),rmstb(ii)
+ else
+ write(unit_out,rec=iii) ((allcart(j,i,ij),j=1,3),i=1,nres),
+ & ((allcart(j,i,ij),j=1,3),i=nnt+nres,nct+nres),
+ & nss_all(ij),(ihpb_all(i,ij),jhpb_all(i,ij),i=1,nss_all(ij)),
+ & entfac(ii),rmstb(ii)
+ endif
+#ifdef DEBUG
+ write (iout,'(8f10.5)') ((allcart(j,i,ij),j=1,3),i=1,nres)
+ write (iout,'(8f10.4)') ((allcart(j,i,ij),j=1,3),i=nnt+nres,
+ & nct+nres)
+ write (iout,'(2e15.5)') entfac(ij)
+ write (iout,'(16i5)') nss_all(ij),(ihpb(i,ij),jhpb(i,ij),i=1,
+ & nss_all(ij))
+ call flush(iout)
+#endif
+ enddo
+ 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 'sizesclu.dat'
+ 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.TIME1'
+ character*4 sequence(maxres)
+ integer rescode
+ double precision x(maxvar)
+ integer itype_pdb(maxres)
+ logical seq_comp
+ integer i,j,k,nres_pdb,iaux
+ double precision ddsc,dist
+ integer ilen
+ external ilen
+C
+ nres0=nres
+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,2*nres
+ do j=1,3
+ cref_pdb(j,i)=c(j,i)
+ enddo
+ enddo
+ 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_pdb(k,nres+j+i)=cref_pdb(k,nres_pdb+j)
+ enddo
+ enddo
+ do j=nnt+nsup-1,nnt,-1
+ do k=1,3
+ cref_pdb(k,j+i)=cref_pdb(k,j)
+ enddo
+ phi_ref(j+i)=phi_ref(j)
+ theta_ref(j+i)=theta_ref(j)
+ alph_ref(j+i)=alph_ref(j)
+ omeg_ref(j+i)=omeg_ref(j)
+ enddo
+#ifdef DEBUG
+ do j=nnt,nct
+ write (iout,'(i5,3f10.5,5x,3f10.5)')
+ & j,(cref_pdb(k,j),k=1,3),(cref_pdb(k,j+nres),k=1,3)
+ enddo
+#endif
+ nstart_seq=nnt+i
+ nstart_sup=nnt+i
+ goto 111
+ endif
+ enddo
+ write (iout,'(a)')
+ & 'Error - sequences to be superposed do not match.'
+ return1
+ else
+ do i=0,nsup-(nct-nnt+1)
+ if (seq_comp(itype(nnt),itype_pdb(nstart_sup+i),
+ & nct-nnt+1))
+ & then
+ nstart_sup=nstart_sup+i
+ nsup=nct-nnt+1
+ goto 111
+ endif
+ enddo
+ write (iout,'(a)')
+ & 'Error - sequences to be superposed do not match.'
+ endif
+ 111 continue
+ write (iout,'(a,i5)')
+ & 'Experimental structure begins at residue',nstart_seq
+ else
+ call read_angles(inp,*38)
+ goto 39
+ 38 write (iout,'(a)') 'Error reading reference structure.'
+ return1
+ 39 call chainbuild
+ nstart_sup=nnt
+ nstart_seq=nnt
+ nsup=nct-nnt+1
+ do i=1,2*nres
+ do j=1,3
+ cref_pdb(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_pdb(j,i)
+ enddo
+ enddo
+ do i=1,nres
+ do j=1,3
+ dc(j,nres+i)=cref_pdb(j,nres+i)-cref_pdb(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
+ write (iout,'(a,i3,a,i3,a,i3,a)')
+ & 'Number of residues to be superposed:',nsup,
+ & ' (from residue',nstart_sup,' to residue',
+ & nend_sup,').'
+ return
+ end
--- /dev/null
+ subroutine readpdb(lprint)
+C Read the PDB file and convert the peptide geometry into virtual-chain
+C geometry.
+ implicit none
+ include 'DIMENSIONS'
+ 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
+ logical lprint
+ 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.
+ if (lprint) then
+ 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
+ endif
+ 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 '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 '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 '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 readpdb
+C Read the PDB file and convert the peptide geometry into virtual-chain
+C geometry.
+ implicit none
+ include 'DIMENSIONS'
+ include 'sizesclu.dat'
+ 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
+ bfac=0.0d0
+ 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)
+ write (iout,'(2i3,2x,a,3f8.3)')
+ & ires,itype(ires),res,(c(j,ires),j=1,3)
+ iii=1
+ do j=1,3
+ sccor(j,iii)=c(j,ires)
+ enddo
+ 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 ') then
+ iii=iii+1
+ read(card(31:54),'(3f8.3)') (sccor(j,iii),j=1,3)
+ endif
+ endif
+ enddo
+ 10 write (iout,'(a,i5)') ' Nres: ',ires
+C Calculate 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.
+ 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.)
+c write (iout,*) "After int_from_cart"
+c 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,2*nres
+ do j=1,3
+ cref_pdb(j,i)=c(j,i)
+ enddo
+ enddo
+ do i=1,nres
+ write (iout,110) restyp(itype(i)),i,cref_pdb(1,i),
+ & cref_pdb(2,i),cref_pdb(3,i),cref_pdb(1,nres+i),
+ & cref_pdb(2,nres+i),cref_pdb(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)
+ ishift_pdb=ishift
+ return
+ end
+c---------------------------------------------------------------------------
+ subroutine int_from_cart(lside,lprn)
+ implicit none
+ include 'DIMENSIONS'
+ include 'sizesclu.dat'
+ include 'COMMON.LOCAL'
+ include 'COMMON.VAR'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.NAMES'
+ character*3 seq,atom,res
+ character*80 card
+ double precision sccor(3,20)
+ integer rescode
+ double precision dist,alpha,beta,di
+ integer i,j,iti
+ logical lside,lprn
+ if (lprn) then
+ write (iout,'(/a)')
+ & 'Internal coordinates calculated from crystal structure.'
+ if (lside) then
+ write (iout,'(8a)') ' Res ',' dvb',' Theta',
+ & ' Phi',' Dsc_id',' Dsc',' Alpha',
+ & ' Omega'
+ else
+ write (iout,'(4a)') ' Res ',' dvb',' Theta',
+ & ' Phi'
+ endif
+ endif
+ do i=2,nres
+ iti=itype(i)
+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
+ theta(i+1)=alpha(i-1,i,i+1)
+ if (i.gt.2) phi(i+1)=beta(i-2,i-1,i,i+1)
+ enddo
+ if (itype(1).eq.ntyp1) then
+ do j=1,3
+ c(j,1)=c(j,2)+(c(j,3)-c(j,4))
+ enddo
+ endif
+ if (itype(nres).eq.ntyp1) then
+ do j=1,3
+ c(j,nres)=c(j,nres-1)+(c(j,nres-2)-c(j,nres-3))
+ enddo
+ endif
+ if (lside) then
+ do i=2,nres-1
+ do j=1,3
+ c(j,maxres2)=0.5D0*(c(j,i-1)+c(j,i+1))
+ enddo
+ iti=itype(i)
+ di=dist(i,nres+i)
+ if (iti.ne.10) then
+ alph(i)=alpha(nres+i,i,maxres2)
+ omeg(i)=beta(nres+i,i,maxres2,i+1)
+ endif
+ if (lprn)
+ & write (iout,'(a3,i4,7f10.3)') restyp(iti),i,dist(i,i-1),
+ & rad2deg*theta(i),rad2deg*phi(i),dsc(iti),di,
+ & rad2deg*alph(i),rad2deg*omeg(i)
+ enddo
+ else if (lprn) then
+ do i=2,nres
+ iti=itype(i)
+ write (iout,'(a3,i4,7f10.3)') restyp(iti),i,dist(i,i-1),
+ & rad2deg*theta(i),rad2deg*phi(i)
+ enddo
+ endif
+ return
+ end
+c---------------------------------------------------------------------------
+ subroutine sccenter(ires,nscat,sccor)
+ implicit none
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ integer ires,nscat,i,j
+ double precision sccor(3,20),sccmj
+ do j=1,3
+ sccmj=0.0D0
+ do i=1,nscat
+ sccmj=sccmj+sccor(j,i)
+ enddo
+ dc(j,ires)=sccmj/nscat
+ enddo
+ return
+ end
--- /dev/null
+ subroutine read_control
+C
+C Read molecular data
+C
+ implicit none
+ include 'DIMENSIONS'
+ include 'sizesclu.dat'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.TIME1'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.CONTROL'
+ include 'COMMON.CLUSTER'
+ include 'COMMON.CHAIN'
+ include 'COMMON.HEADER'
+ include 'COMMON.FFIELD'
+ include 'COMMON.FREE'
+ include 'COMMON.INTERACT'
+ include "COMMON.SPLITELE"
+ include 'COMMON.SHIELD'
+ include 'COMMON.SAXS'
+ character*320 controlcard,ucase
+#ifdef MPL
+ include 'COMMON.INFO'
+#endif
+ integer i,i1,i2,it1,it2
+ double precision pi
+ read (INP,'(a80)') titel
+ call card_concat(controlcard)
+
+ energy_dec=(index(controlcard,'ENERGY_DEC').gt.0)
+ unres_pdb = index(controlcard,'UNRES_PDB') .gt. 0
+ call readi(controlcard,'TORMODE',tor_mode,0)
+ call readi(controlcard,'NRES',nres,0)
+ call readi(controlcard,'RESCALE',rescale_mode,2)
+ call reada(controlcard,'DISTCHAINMAX',distchainmax,50.0d0)
+ write (iout,*) "DISTCHAINMAX",distchainmax
+C Reading the dimensions of box in x,y,z coordinates
+ call reada(controlcard,'BOXX',boxxsize,100.0d0)
+ call reada(controlcard,'BOXY',boxysize,100.0d0)
+ call reada(controlcard,'BOXZ',boxzsize,100.0d0)
+c Cutoff range for interactions
+ call reada(controlcard,"R_CUT",r_cut,15.0d0)
+ call reada(controlcard,"LAMBDA",rlamb,0.3d0)
+ call reada(controlcard,"LIPTHICK",lipthick,0.0d0)
+ call reada(controlcard,"LIPAQBUF",lipbufthick,0.0d0)
+ if (lipthick.gt.0.0d0) then
+ bordliptop=(boxzsize+lipthick)/2.0
+ bordlipbot=bordliptop-lipthick
+C endif
+ if ((bordliptop.gt.boxzsize).or.(bordlipbot.lt.0.0))
+ & write(iout,*) "WARNING WRONG SIZE OF LIPIDIC PHASE"
+ buflipbot=bordlipbot+lipbufthick
+ bufliptop=bordliptop-lipbufthick
+ if ((lipbufthick*2.0d0).gt.lipthick)
+ &write(iout,*) "WARNING WRONG SIZE OF LIP AQ BUF"
+ endif
+ write(iout,*) "bordliptop=",bordliptop
+ write(iout,*) "bordlipbot=",bordlipbot
+ write(iout,*) "bufliptop=",bufliptop
+ write(iout,*) "buflipbot=",buflipbot
+C Shielding mode
+ call readi(controlcard,'SHIELD',shield_mode,0)
+ write (iout,*) "SHIELD MODE",shield_mode
+ if (shield_mode.gt.0) then
+ 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
+ pi=3.141592d0
+C VSolvSphere the volume of solving sphere
+C print *,pi,"pi"
+C rpp(1,1) is the energy r0 for peptide group contact and will be used for it
+C there will be no distinction between proline peptide group and normal peptide
+C group in case of shielding parameters
+ VSolvSphere=4.0/3.0*pi*rpp(1,1)**3
+ VSolvSphere_div=VSolvSphere-4.0/3.0*pi*(rpp(1,1)/2.0)**3
+ write (iout,*) VSolvSphere,VSolvSphere_div
+C long axis of side chain
+ do i=1,ntyp
+ long_r_sidechain(i)=vbldsc0(1,i)
+ short_r_sidechain(i)=sigma0(i)
+ enddo
+ buff_shield=1.0d0
+ endif
+ call readi(controlcard,'PDBOUT',outpdb,0)
+ call readi(controlcard,'MOL2OUT',outmol2,0)
+ refstr=(index(controlcard,'REFSTR').gt.0)
+ pdbref=(index(controlcard,'PDBREF').gt.0)
+ refstr = refstr .or. pdbref
+ write (iout,*) "REFSTR",refstr," PDBREF",pdbref
+ iscode=index(controlcard,'ONE_LETTER')
+ tree=(index(controlcard,'MAKE_TREE').gt.0)
+ with_dihed_constr = index(controlcard,"WITH_DIHED_CONSTR").gt.0
+ call readi(controlcard,'CONSTR_DIST',constr_dist,0)
+ write (iout,*) "with_dihed_constr ",with_dihed_constr,
+ & " CONSTR_DIST",constr_dist
+ with_theta_constr = index(controlcard,"WITH_THETA_CONSTR").gt.0
+ write (iout,*) "with_theta_constr ",with_theta_constr
+ call flush(iout)
+ min_var=(index(controlcard,'MINVAR').gt.0)
+ plot_tree=(index(controlcard,'PLOT_TREE').gt.0)
+ punch_dist=(index(controlcard,'PUNCH_DIST').gt.0)
+ print_fittest=(index(controlcard,'PRINT_FITTEST').gt.0)
+ call readi(controlcard,'NCUT',ncut,0)
+ if (ncut.gt.0) then
+ call multreada(controlcard,'CUTOFF',rcutoff,ncut,-1.0d0)
+ nclust=0
+ else
+ call readi(controlcard,'NCLUST',nclust,5)
+ endif
+ call readi(controlcard,'SYM',symetr,1)
+ write (iout,*) 'sym', symetr
+ call readi(controlcard,'NSTART',nstart,0)
+ call readi(controlcard,'NEND',nend,0)
+ call reada(controlcard,'ECUT',ecut,10.0d0)
+ call reada(controlcard,'PROB',prob_limit,0.99d0)
+ write (iout,*) "Probability limit",prob_limit
+ lgrp=(index(controlcard,'LGRP').gt.0)
+ caonly=(index(controlcard,'CA_ONLY').gt.0)
+ print_dist=(index(controlcard,'PRINT_DIST').gt.0)
+ call readi(controlcard,'IOPT',iopt,2)
+ lefree = index(controlcard,"EFREE").gt.0
+ call readi(controlcard,'NTEMP',nT,1)
+ write (iout,*) "nT",nT
+ call multreada(controlcard,'TEMPER',beta_h,nT,300.0d0)
+ write (iout,*) "nT",nT
+ write (iout,*) 'beta_h',(beta_h(i),i=1,nT)
+ do i=1,nT
+ beta_h(i)=1.0d0/(1.987D-3*beta_h(i))
+ enddo
+ write (iout,*) 'beta_h',(beta_h(i),i=1,nT)
+ lprint_cart=index(controlcard,"PRINT_CART") .gt.0
+ lprint_int=index(controlcard,"PRINT_INT") .gt.0
+ call readi(controlcard,'CONSTR_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
+ 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
+ if (min_var) iopt=1
+ return
+ end
+c--------------------------------------------------------------------------
+ subroutine molread
+C
+C Read molecular data.
+C
+ implicit none
+ include 'DIMENSIONS'
+ 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.CONTACTS'
+ include 'COMMON.TIME1'
+ include 'COMMON.TORCNSTR'
+ include 'COMMON.SHIELD'
+ include 'COMMON.SAXS'
+#ifdef MPL
+ include 'COMMON.INFO'
+#endif
+ character*4 sequence(maxres)
+ character*800 weightcard,controlcard
+ integer rescode
+ double precision x(maxvar)
+ double precision phihel,phibet,sigmahel,sigmabet,sumv,
+ & secprob(3,maxres)
+ integer itype_pdb(maxres)
+ logical seq_comp
+ integer i,j,kkk,i1,i2,it1,it2,tperm,ii,iperm
+C
+C Body
+C
+C Read weights of the subsequent energy terms.
+ call card_concat(weightcard)
+ call reada(weightcard,'WSC',wsc,1.0d0)
+ call reada(weightcard,'WLONG',wsc,wsc)
+ call reada(weightcard,'WSCP',wscp,1.0d0)
+ call reada(weightcard,'WELEC',welec,1.0D0)
+ call reada(weightcard,'WVDWPP',wvdwpp,welec)
+ call reada(weightcard,'WEL_LOC',wel_loc,1.0D0)
+ call reada(weightcard,'WCORR4',wcorr4,0.0D0)
+ call reada(weightcard,'WCORR5',wcorr5,0.0D0)
+ call reada(weightcard,'WCORR6',wcorr6,0.0D0)
+ call reada(weightcard,'WTURN3',wturn3,1.0D0)
+ call reada(weightcard,'WTURN4',wturn4,1.0D0)
+ call reada(weightcard,'WTURN6',wturn6,1.0D0)
+ call reada(weightcard,'WSTRAIN',wstrain,1.0D0)
+ call reada(weightcard,'WSCCOR',wsccor,1.0D0)
+ call reada(weightcard,'WBOND',wbond,1.0D0)
+ call reada(weightcard,'WTOR',wtor,1.0D0)
+ call reada(weightcard,'WTORD',wtor_d,1.0D0)
+ call reada(weightcard,'WANG',wang,1.0D0)
+ call reada(weightcard,'WSCLOC',wscloc,1.0D0)
+ call reada(weightcard,'WSAXS',wsaxs,0.0D0)
+ call reada(weightcard,'SCAL14',scal14,0.4D0)
+ call reada(weightcard,'SCALSCP',scalscp,1.0d0)
+ call reada(weightcard,'CUTOFF',cutoff_corr,7.0d0)
+ call reada(weightcard,'DELT_CORR',delt_corr,0.5d0)
+ if (index(weightcard,'SOFT').gt.0) ipot=6
+ call reada(weightcard,"D0CM",d0cm,3.78d0)
+ call reada(weightcard,"AKCM",akcm,15.1d0)
+ call reada(weightcard,"AKTH",akth,11.0d0)
+ call reada(weightcard,"AKCT",akct,12.0d0)
+ call reada(weightcard,"V1SS",v1ss,-1.08d0)
+ call reada(weightcard,"V2SS",v2ss,7.61d0)
+ call reada(weightcard,"V3SS",v3ss,13.7d0)
+ call reada(weightcard,"EBR",ebr,-5.50D0)
+ call reada(weightcard,'WSHIELD',wshield,1.0d0)
+ call reada(weightcard,'WDFAD',wdfa_dist,0.0d0)
+ call reada(weightcard,'WDFAT',wdfa_tor,0.0d0)
+ call reada(weightcard,'WDFAN',wdfa_nei,0.0d0)
+ call reada(weightcard,'WDFAB',wdfa_beta,0.0d0)
+ call reada(weightcard,'WLT',wliptran,0.0D0)
+ call reada(weightcard,"ATRISS",atriss,0.301D0)
+ call reada(weightcard,"BTRISS",btriss,0.021D0)
+ call reada(weightcard,"CTRISS",ctriss,1.001D0)
+ call reada(weightcard,"DTRISS",dtriss,1.001D0)
+ dyn_ss=(index(weightcard,'DYN_SS').gt.0)
+ do i=1,maxres
+ dyn_ss_mask(i)=.false.
+ enddo
+ do i=1,maxres-1
+ do j=i+1,maxres
+ dyn_ssbond_ij(i,j)=1.0d300
+ enddo
+ enddo
+ call reada(weightcard,"HT",Ht,0.0D0)
+ if (dyn_ss) then
+ ss_depth=ebr/wsc-0.25*eps(1,1)
+ Ht=Ht/wsc-0.25*eps(1,1)
+ akcm=akcm*wstrain/wsc
+ akth=akth*wstrain/wsc
+ akct=akct*wstrain/wsc
+ v1ss=v1ss*wstrain/wsc
+ v2ss=v2ss*wstrain/wsc
+ v3ss=v3ss*wstrain/wsc
+ else
+ ss_depth=ebr/wstrain-0.25*eps(1,1)*wsc/wstrain
+ endif
+ write (iout,'(/a)') "Disulfide bridge parameters:"
+ write (iout,'(a,f10.2)') 'S-S bridge energy: ',ebr
+ write (iout,'(2(a,f10.2))') 'd0cm:',d0cm,' akcm:',akcm
+ write (iout,'(2(a,f10.2))') 'akth:',akth,' akct:',akct
+ write (iout,'(3(a,f10.2))') 'v1ss:',v1ss,' v2ss:',v2ss,
+ & ' v3ss:',v3ss
+ write (iout,*) "Parameters of the 'trisulfide' potential"
+ write (iout,*) "ATRISS=", atriss
+ write (iout,*) "BTRISS=", btriss
+ write (iout,*) "CTRISS=", ctriss
+ write (iout,*) "DTRISS=", dtriss
+
+C 12/1/95 Added weight for the multi-body term WCORR
+ call reada(weightcard,'WCORRH',wcorr,1.0D0)
+ if (wcorr4.gt.0.0d0) wcorr=wcorr4
+ weights(1)=wsc
+ weights(2)=wscp
+ weights(3)=welec
+ weights(4)=wcorr
+ weights(5)=wcorr5
+ weights(6)=wcorr6
+ weights(7)=wel_loc
+ weights(8)=wturn3
+ weights(9)=wturn4
+ weights(10)=wturn6
+ weights(11)=wang
+ weights(12)=wscloc
+ weights(13)=wtor
+ weights(14)=wtor_d
+ weights(15)=wstrain
+ weights(16)=wvdwpp
+ weights(17)=scal14
+ weights(18)=wbond
+ weights(19)=wsccor
+ weights(28)=wdfa_dist
+ weights(29)=wdfa_tor
+ weights(30)=wdfa_nei
+ weights(31)=wdfa_beta
+ write (iout,10) wsc,wscp,welec,wvdwpp,wbond,wang,wscloc,wtor,
+ & wtor_d,wstrain,wel_loc,wcorr,wcorr5,wcorr6,wturn3,
+ & wturn4,wturn6,wsccor
+ 10 format (/'Energy-term weights (unscaled):'//
+ & 'WSCC= ',f10.6,' (SC-SC)'/
+ & 'WSCP= ',f10.6,' (SC-p)'/
+ & 'WELEC= ',f10.6,' (p-p electr)'/
+ & 'WVDWPP= ',f10.6,' (p-p VDW)'/
+ & 'WBOND= ',f10.6,' (stretching)'/
+ & 'WANG= ',f10.6,' (bending)'/
+ & 'WSCLOC= ',f10.6,' (SC local)'/
+ & 'WTOR= ',f10.6,' (torsional)'/
+ & 'WTORD= ',f10.6,' (double torsional)'/
+ & 'WSTRAIN=',f10.6,' (SS bridges & dist. cnstr.)'/
+ & 'WEL_LOC=',f10.6,' (multi-body 3-rd order)'/
+ & 'WCORR4= ',f10.6,' (multi-body 4th order)'/
+ & 'WCORR5= ',f10.6,' (multi-body 5th order)'/
+ & 'WCORR6= ',f10.6,' (multi-body 6th order)'/
+ & 'WTURN3= ',f10.6,' (turns, 3rd order)'/
+ & 'WTURN4= ',f10.6,' (turns, 4th order)'/
+ & 'WTURN6= ',f10.6,' (turns, 6th order)'/
+ & 'WSCCOR= ',f10.6,' (SC-backbone torsinal correalations)')
+
+ if (wcorr4.gt.0.0d0) then
+ write (iout,'(/2a/)') 'Local-electrostatic type correlation ',
+ & 'between contact pairs of peptide groups'
+ write (iout,'(2(a,f5.3/))')
+ & 'Cutoff on 4-6th order correlation terms: ',cutoff_corr,
+ & 'Range of quenching the correlation terms:',2*delt_corr
+ else if (wcorr.gt.0.0d0) then
+ write (iout,'(/2a/)') 'Hydrogen-bonding correlation ',
+ & 'between contact pairs of peptide groups'
+ endif
+ write (iout,'(a,f8.3)')
+ & 'Scaling factor of 1,4 SC-p interactions:',scal14
+ write (iout,'(a,f8.3)')
+ & 'General scaling factor of SC-p interactions:',scalscp
+ r0_corr=cutoff_corr-delt_corr
+ do i=1,20
+ aad(i,1)=scalscp*aad(i,1)
+ aad(i,2)=scalscp*aad(i,2)
+ bad(i,1)=scalscp*bad(i,1)
+ bad(i,2)=scalscp*bad(i,2)
+ enddo
+#ifdef DFA
+ write (iout,'(/a/)') "DFA pseudopotential parameters:"
+ write (iout,'(a,f10.6,a)')
+ & "WDFAD= ",wdfa_dist," (distance)",
+ & "WDFAT= ",wdfa_tor," (backbone angles)",
+ & "WDFAN= ",wdfa_nei," (neighbors)",
+ & "WDFAB= ",wdfa_beta," (beta structure)"
+#endif
+ call flush(iout)
+c print *,'indpdb=',indpdb,' pdbref=',pdbref
+
+C Read sequence if not taken from the pdb file.
+ 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
+c print *,nres
+c print '(20i4)',(itype(i),i=1,nres)
+
+ do i=1,nres
+#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
+
+c print *,'Call Read_Bridge.'
+ call read_bridge
+C this fragment reads diheadral constrains
+ nnt=1
+ nct=nres
+c print *,'NNT=',NNT,' NCT=',NCT
+ 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)
+ 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
+ if (nstart.lt.nnt) nstart=nnt
+ if (nend.gt.nct .or. nend.eq.0) nend=nct
+ write (iout,*) "nstart",nstart," nend",nend
+ nres0=nres
+#ifdef DFA
+ 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
+ call init_dfa_vars
+ print*, 'init_dfa_vars finished!'
+ call read_dfa_info
+ print*, 'read_dfa_info finished!'
+ endif
+#endif
+ if (with_dihed_constr) then
+
+ read (inp,*) ndih_constr
+ if (ndih_constr.gt.0) then
+ raw_psipred=.false.
+C read (inp,*) ftors
+C write (iout,*) 'FTORS',ftors
+C ftors is the force constant for torsional quartic constrains
+ read (inp,*) (idih_constr(i),phi0(i),drange(i),ftors(i),
+ & i=1,ndih_constr)
+ write (iout,*)
+ & 'There are',ndih_constr,' constraints on phi angles.'
+ do i=1,ndih_constr
+ write (iout,'(i5,3f8.3)') idih_constr(i),phi0(i),drange(i),
+ & ftors(i)
+ enddo
+ do i=1,ndih_constr
+ phi0(i)=deg2rad*phi0(i)
+ drange(i)=deg2rad*drange(i)
+ enddo
+ else if (ndih_constr.lt.0) then
+ raw_psipred=.true.
+ call card_concat(controlcard)
+ 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 ndif_constr.gt.0
+ endif ! with_dihed_constr
+ if (with_theta_constr) then
+C with_theta_constr is keyword allowing for occurance of theta constrains
+ read (inp,*) ntheta_constr
+C ntheta_constr is the number of theta constrains
+ if (ntheta_constr.gt.0) then
+C read (inp,*) ftors
+ read (inp,*) (itheta_constr(i),theta_constr0(i),
+ & theta_drange(i),for_thet_constr(i),
+ & i=1,ntheta_constr)
+C the above code reads from 1 to ntheta_constr
+C itheta_constr(i) residue i for which is theta_constr
+C theta_constr0 the global minimum value
+C theta_drange is range for which there is no energy penalty
+C for_thet_constr is the force constant for quartic energy penalty
+C E=k*x**4
+ 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
+ write (iout,*) "calling read_saxs_consrtr",nsaxs
+ if (nsaxs.gt.0) call read_saxs_constr
+
+c if (pdbref) then
+c read(inp,'(a)') pdbfile
+c write (iout,'(2a)') 'PDB data will be read from file ',pdbfile
+c open(ipdbin,file=pdbfile,status='old',err=33)
+c goto 34
+c 33 write (iout,'(a)') 'Error opening PDB file.'
+c stop
+c 34 continue
+c print *,'Begin reading pdb data'
+c call readpdb
+c print *,'Finished reading pdb data'
+c write (iout,'(a,i3,a,i3)')'nsup=',nsup,' nstart_sup=',nstart_sup
+c do i=1,nres
+c itype_pdb(i)=itype(i)
+c enddo
+c close (ipdbin)
+c write (iout,'(a,i3)') 'nsup=',nsup
+c nstart_seq=nnt
+c if (nsup.le.(nct-nnt+1)) then
+c do i=0,nct-nnt+1-nsup
+c if (seq_comp(itype(nnt+i),itype_pdb(nstart_sup),nsup)) then
+c nstart_seq=nnt+i
+c goto 111
+c endif
+c enddo
+c write (iout,'(a)')
+c & 'Error - sequences to be superposed do not match.'
+c stop
+c else
+c do i=0,nsup-(nct-nnt+1)
+c if (seq_comp(itype(nnt),itype_pdb(nstart_sup+i),nct-nnt+1))
+c & then
+c nstart_sup=nstart_sup+i
+c nsup=nct-nnt+1
+c goto 111
+c endif
+c enddo
+c write (iout,'(a)')
+c & 'Error - sequences to be superposed do not match.'
+c endif
+c 111 continue
+c write (iout,*) 'nsup=',nsup,' nstart_sup=',nstart_sup,
+c & ' nstart_seq=',nstart_seq
+c endif
+ call init_int_table
+ call setup_var
+ write (iout,*) "molread: REFSTR",refstr
+ if (refstr) then
+ if (.not.pdbref) then
+ call read_angles(inp,*38)
+ goto 39
+ 38 write (iout,'(a)') 'Error reading reference structure.'
+#ifdef MPL
+ call mp_stopall(Error_Msg)
+#else
+ stop 'Error reading reference structure'
+#endif
+ 39 call chainbuild
+ nstart_sup=nnt
+ nstart_seq=nnt
+ nsup=nct-nnt+1
+ do i=1,2*nres
+ do j=1,3
+ cref(j,i)=c(j,i)
+ enddo
+ enddo
+ endif
+c call contact(.true.,ncont_ref,icont_ref)
+ endif
+ if (ns.gt.0) then
+C write (iout,'(/a,i3,a)')
+C & 'The chain contains',ns,' disulfide-bridging cysteines.'
+ write (iout,'(20i4)') (iss(i),i=1,ns)
+ if (dyn_ss) then
+ write(iout,*)"Running with dynamic disulfide-bond formation"
+ else
+ write (iout,'(/a/)') 'Pre-formed links are:'
+ do i=1,nss
+ i1=ihpb(i)-nres
+ i2=jhpb(i)-nres
+ it1=itype(i1)
+ it2=itype(i2)
+ write (iout,'(2a,i3,3a,i3,a,3f10.3)')
+ & restyp(it1),'(',i1,') -- ',restyp(it2),'(',i2,')',dhpb(i),
+ & ebr,forcon(i)
+ enddo
+ write (iout,'(a)')
+ endif
+ endif
+ if (ns.gt.0.and.dyn_ss) then
+ do i=nss+1,nhpb
+ ihpb(i-nss)=ihpb(i)
+ jhpb(i-nss)=jhpb(i)
+ forcon(i-nss)=forcon(i)
+ dhpb(i-nss)=dhpb(i)
+ enddo
+ nhpb=nhpb-nss
+ nss=0
+ call hpb_partition
+ do i=1,ns
+ dyn_ss_mask(iss(i))=.true.
+ enddo
+ endif
+c Read distance restraints
+ if (constr_dist.gt.0) then
+ call read_dist_constr
+ call hpb_partition
+ endif
+ return
+ end
+c-----------------------------------------------------------------------------
+ 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 none
+ include 'DIMENSIONS'
+ 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.TIME1'
+#ifdef MPL
+ include 'COMMON.INFO'
+#endif
+ integer i,j
+C Read bridging residues.
+ read (inp,*) ns,(iss(i),i=1,ns)
+c print *,'ns=',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?!!!'
+#ifdef MPL
+ call mp_stopall(error_msg)
+#else
+ stop
+#endif
+ endif
+ enddo
+C Read preformed bridges.
+ if (ns.gt.0) then
+ read (inp,*) nss,(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.'
+#ifdef MPL
+ call mp_stopall(error_msg)
+#else
+ stop
+#endif
+ 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
+C dhpb(i)=dbr
+C 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,*)
+ implicit none
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.CHAIN'
+ include 'COMMON.IOUNITS'
+ integer i,kanal
+ 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 reada(rekord,lancuch,wartosc,default)
+ implicit none
+ character*(*) rekord,lancuch
+ double precision wartosc,default
+ integer ilen,iread
+ external ilen
+ iread=index(rekord,lancuch)
+ if (iread.eq.0) then
+ wartosc=default
+ return
+ endif
+ iread=iread+ilen(lancuch)+1
+ read (rekord(iread:),*) wartosc
+ return
+ end
+c----------------------------------------------------------------------------
+ subroutine multreada(rekord,lancuch,tablica,dim,default)
+ implicit none
+ integer dim,i
+ double precision tablica(dim),default
+ character*(*) rekord,lancuch
+ integer ilen,iread
+ external ilen
+ do i=1,dim
+ tablica(i)=default
+ enddo
+ iread=index(rekord,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 readi(rekord,lancuch,wartosc,default)
+ implicit none
+ character*(*) rekord,lancuch
+ integer wartosc,default
+ integer ilen,iread
+ external ilen
+ iread=index(rekord,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 card_concat(card)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ character*(*) card
+ character*80 karta,ucase
+ external ilen
+ read (inp,'(a)') karta
+ karta=ucase(karta)
+ card=' '
+ do while (karta(80:80).eq.'&')
+ card=card(:ilen(card)+1)//karta(:79)
+ read (inp,'(a)') karta
+ karta=ucase(karta)
+ enddo
+ card=card(:ilen(card)+1)//karta
+ return
+ end
+c----------------------------------------------------------------------------
+ subroutine openunits
+ implicit none
+ include 'DIMENSIONS'
+#ifdef MPI
+ include "mpif.h"
+ character*3 liczba
+ include "COMMON.MPI"
+#endif
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CONTROL'
+ integer lenpre,lenpot,ilen
+ external ilen
+ character*16 cformat,cprint
+ character*16 ucase
+ integer lenint,lenout
+ call getenv('INPUT',prefix)
+ call getenv('OUTPUT',prefout)
+ call getenv('INTIN',prefintin)
+ call getenv('COORD',cformat)
+ call getenv('PRINTCOOR',cprint)
+ call getenv('SCRATCHDIR',scratchdir)
+ from_bx=.true.
+ from_cx=.false.
+ if (index(ucase(cformat),'CX').gt.0) then
+ from_cx=.true.
+ from_bx=.false.
+ endif
+ from_cart=.true.
+ lenpre=ilen(prefix)
+ lenout=ilen(prefout)
+ lenint=ilen(prefintin)
+C Get the names and open the input files
+ open (inp,file=prefix(:ilen(prefix))//'.inp',status='old')
+#ifdef MPI
+ write (liczba,'(bz,i3.3)') me
+ outname=prefout(:lenout)//'_clust.out_'//liczba
+#else
+ outname=prefout(:lenout)//'_clust.out'
+#endif
+ if (from_bx) then
+ intinname=prefintin(:lenint)//'.bx'
+ else if (from_cx) then
+ intinname=prefintin(:lenint)//'.cx'
+ else
+ intinname=prefintin(:lenint)//'.int'
+ endif
+ rmsname=prefintin(:lenint)//'.rms'
+ open (jplot,file=prefout(:ilen(prefout))//'.tex',
+ & status='unknown')
+ open (jrms,file=rmsname,status='unknown')
+ open(iout,file=outname,status='unknown')
+C Get parameter filenames and open the parameter files.
+ call getenv('BONDPAR',bondname)
+ open (ibond,file=bondname,status='old')
+ call getenv('THETPAR',thetname)
+ open (ithep,file=thetname,status='old')
+ call getenv('ROTPAR',rotname)
+ open (irotam,file=rotname,status='old')
+ call getenv('TORPAR',torname)
+ open (itorp,file=torname,status='old')
+#ifndef NEWCORR
+ call getenv('TORDPAR',tordname)
+ open (itordp,file=tordname,status='old')
+#endif
+ call getenv('FOURIER',fouriername)
+ open (ifourier,file=fouriername,status='old')
+ call getenv('ELEPAR',elename)
+ open (ielep,file=elename,status='old')
+ call getenv('SIDEPAR',sidename)
+ open (isidep,file=sidename,status='old')
+ call getenv('SIDEP',sidepname)
+ open (isidep1,file=sidepname,status="old")
+ call getenv('SCCORPAR',sccorname)
+ open (isccor,file=sccorname,status="old")
+ call getenv('LIPTRANPAR',liptranname)
+ open (iliptranpar,file=liptranname,status='old')
+#ifndef OLDSCP
+C
+C 8/9/01 In the newest version SCp interaction constants are read from a file
+C Use -DOLDSCP to use hard-coded constants instead.
+C
+ call getenv('SCPPAR',scpname)
+ open (iscpp,file=scpname,status='old')
+#endif
+ return
+ end
+c--------------------------------------------------------------------------
+ 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'
+ include 'COMMON.INTERACT'
+ 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 scal_bfac
+ 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)
+ 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)
+ 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
+ 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
+ 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
+ call hpb_partition
+ call flush(iout)
+ return
+ 11 write (iout,*)"read_dist_restr: error reading reference structure"
+ stop
+ end
+c-------------------------------------------------------------------------------
+ subroutine read_saxs_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'
+ 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 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 '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(ccc,cccref,przes_min,obrot_min,
+ & 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),przes_min(3),obrot_min(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
+ rmsmin=1.0d10
+ DO IPERM=1,NPERMCHAIN
+ 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,'(3f10.5,5x,3f10.5)')
+ & (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,'(3f10.5,5x,3f10.5)')
+ & (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
+ przes_min=przes
+ obrot_min=obrot
+ 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 rmscalc_thet(ttheta,theta_reff,
+ & iperm)
+ implicit none
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.VAR'
+ integer iperm,k,ichain,indchain,kchain1,kchain2,nnnn
+ double precision ttheta(maxres),theta_reff(maxres),rmsthet,dtheta
+ rmsthet = 0.0d0
+ nnnn=0
+ do ichain=1,nchain
+ indchain=tabpermchain(ichain,iperm)
+c write (iout,*) "ichain",ichain," iperm",iperm,
+c & " indchain",indchain
+ call flush(iout)
+ do k=3,chain_length(ichain)
+ kchain1=chain_border(1,ichain)+k-1
+ kchain2=chain_border(1,indchain)+k-1
+ nnnn=nnnn+1
+ dtheta = ttheta(kchain2)-theta_reff(kchain1)
+c write (iout,*) k,theta(k),theta_ref(k,iref,ib,iprot),
+c & dtheta
+ rmsthet = rmsthet+dtheta*dtheta
+ enddo
+ enddo
+ nnnn=nnnn-1
+ rmsthet=dsqrt(rmsthet/nnnn)
+#ifdef DEBUG
+ write (iout,*) "nnnn",nnnn," rmsthet",rmsthet
+#endif
+ rmscalc_thet=rmsthet
+ return
+ end
+c------------------------------------------------------------------------
+ double precision function rmscalc_phi(pphi,phi_reff,iperm)
+ implicit none
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.VAR'
+ integer iperm,k,ichain,indchain,kchain1,kchain2,nnnn
+ double precision pphi(maxres),phi_reff(maxres),rmsphi,dphi
+ double precision pinorm
+ rmsphi = 0.0d0
+ nnnn=0
+ do ichain=1,nchain
+ indchain=tabpermchain(ichain,iperm)
+ do k=4,chain_length(ichain)
+ kchain1=chain_border(1,ichain)+k-1
+ kchain2=chain_border(1,indchain)+k-1
+ nnnn=nnnn+1
+ dphi=pinorm(pphi(kchain2)-phi_reff(kchain1))
+c write (iout,*) k,phi(k),phi_ref(k,iref,ib,iprot),
+c & pinorm(phi(k)-phi_ref(k,iref,ib,iprot))
+ rmsphi = rmsphi + dphi*dphi
+ enddo
+ enddo
+ nnnn=nnnn-1
+ rmsphi=dsqrt(rmsphi/nnnn)
+#ifdef DEBUG
+ write (iout,*) "nnnn",nnnn," rmsphi",rmsphi
+#endif
+ rmscalc_phi=rmsphi
+ return
+ end
+c------------------------------------------------------------------------
+ double precision function rmscalc_side(xxtabb,yytabb,zztabb,
+ & xxreff,yyreff,zzreff,iperm)
+ implicit none
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.VAR'
+ integer iperm,k,ichain,indchain,kchain1,kchain2,nnnn
+ double precision xxtabb(maxres),yytabb(maxres),zztabb(maxres),
+ & xxreff(maxres),yyreff(maxres),zzreff(maxres),rmsside,
+ & dxref,dyref,dzref
+ rmsside = 0.0d0
+ nnnn=0
+ do ichain=1,nchain
+ indchain=tabpermchain(ichain,iperm)
+ do k=1,chain_length(ichain)
+ kchain1=chain_border(1,ichain)+k-1
+ kchain2=chain_border(1,indchain)+k-1
+ if (itype(kchain1).eq.ntyp1) cycle
+ nnnn=nnnn+1
+ dxref = xxtabb(kchain2)-xxreff(kchain1)
+ dyref = yytabb(kchain2)-yyreff(kchain1)
+ dzref = zztabb(kchain2)-zzreff(kchain1)
+ rmsside = rmsside + dxref*dxref+dyref*dyref+dzref*dzref
+ enddo
+ enddo
+ rmsside=dsqrt(rmsside/nnnn)
+#ifdef DEBUG
+ write (iout,*) iii,iref," nnnn",nnnn," rmsside",rmsside
+#endif
+ rmscalc_side=rmsside
+ return
+ end
--- /dev/null
+ double precision function rmsnat(jcon)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'sizesclu.dat'
+ include 'DIMENSIONS.COMPAR'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.VAR'
+ include 'COMMON.CONTROL'
+ integer ipermmin
+ double precision przes(3),obrot(3,3)
+ rmsnat=rmscalc(c(1,1),cref_pdb(1,1),przes,obrot,ipermmin)
+ return
+ end
+c-----------------------------------------------------------------------------
+ double precision function gyrate()
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CHAIN'
+ double precision cen(3),rg
+
+ do j=1,3
+ cen(j)=0.0d0
+ enddo
+
+ 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
+ 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 'sizesclu.dat'
+ 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
+******************************************************************
+*
+* Array dimensions for the clustering programs:
+*
+* Max. number of conformations in the data set.
+*
+ integer maxconf,maxstr_proc
+ PARAMETER (MAXCONF=8000)
+ parameter (maxstr_proc=maxconf/2)
+*
+* Max. number of "distances" between conformations.
+*
+ integer MAXDIST
+ PARAMETER (MAXDIST=(maxstr_proc*(maxstr_proc-1))/2)
+*
+* Max. number of clusters. Should be set to MAXCONF; change only if there are
+* problems with memory. In such a case be suspicious about the results, however!
+*
+ integer maxgr
+ PARAMETER (MAXGR=maxstr_proc)
+*
+* Max. number of conformations in a cluster. Remark above applies also here.
+*
+ integer maxingr
+ PARAMETER (MAXINGR=maxstr_proc)
+*
+* Max. number of cut-off values
+*
+ integer max_cut
+ PARAMETER (MAX_CUT=5)
+*
+* Max. number of properties
+*
+ integer maxprop
+ PARAMETER (MAXPROP=5)
+*
+*******************************************************************
--- /dev/null
+ SUBROUTINE SRTCLUST(ICUT,NCON,IB)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'sizesclu.dat'
+ include 'COMMON.CLUSTER'
+ include 'COMMON.FREE'
+ include 'COMMON.IOUNITS'
+ double precision prob(maxgr)
+c
+c Compute free energies of clusters
+c
+ do igr=1,ngr
+ emin=totfree(nconf(igr,1))
+ totfree_gr(igr)=1.0d0
+ do i=2,licz(igr)
+ ii=nconf(igr,i)
+ totfree_gr(igr)=totfree_gr(igr)+dexp(-totfree(ii)+emin)
+ enddo
+c write (iout,*) "igr",igr," totfree",emin,
+c & " totfree_gr",totfree_gr(igr)
+ totfree_gr(igr)=emin-dlog(totfree_gr(igr))
+c write (iout,*) igr," efree",totfree_gr(igr)/beta_h(ib)
+ enddo
+C
+C SORT CONFORMATIONS IN GROUPS ACC. TO ENERGY
+C
+ DO 16 IGR=1,NGR
+ LIGR=LICZ(IGR)
+ DO 17 ICO=1,LIGR-1
+ IND1=NCONF(IGR,ICO)
+ ENE=totfree(IND1)
+ DO 18 JCO=ICO+1,LIGR
+ IND2=NCONF(IGR,JCO)
+ EN1=totfree(IND2)
+ IF (EN1.LT.ENE) THEN
+ NCONF(IGR,ICO)=IND2
+ NCONF(IGR,JCO)=IND1
+ IND1=IND2
+ ENE=EN1
+ ENDIF
+ 18 CONTINUE
+ 17 CONTINUE
+ 16 CONTINUE
+C
+C SORT GROUPS
+C
+ DO 71 IGR=1,NGR
+ ENE=totfree_gr(IGR)
+ DO 72 JGR=IGR+1,NGR
+ EN1=totfree_gr(JGR)
+ IF (EN1.LT.ENE) THEN
+ LI1=LICZ(IGR)
+ LI2=LICZ(JGR)
+ LI=MAX0(LI1,LI2)
+ DO 73 I=1,LI
+ NCO=NCONF(IGR,I)
+ NCONF(IGR,I)=NCONF(JGR,I)
+ NCONF(JGR,I)=NCO
+ 73 CONTINUE
+ totfree_gr(igr)=en1
+ totfree_gr(jgr)=ene
+ ENE=EN1
+ LICZ(IGR)=LI2
+ LICZ(JGR)=LI1
+ ENDIF
+ 72 CONTINUE
+ 71 CONTINUE
+ DO 81 IGR=1,NGR
+ LI=LICZ(IGR)
+ DO 82 I=1,LI
+ 82 IASS(NCONF(IGR,I))=IGR
+ 81 CONTINUE
+ if (lgrp) then
+ do i=1,ncon
+ iass_tot(i,icut)=iass(i)
+c write (iout,*) icut,i,iass(i),iass_tot(i,icut)
+ enddo
+ endif
+ return
+ end
+c----------------------------------------------------------------------
+ SUBROUTINE WRITE_STATS(ICUT,NCON,IB)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'sizesclu.dat'
+ include 'COMMON.CLUSTER'
+ include 'COMMON.FREE'
+ include 'COMMON.IOUNITS'
+ double precision prob(maxgr)
+ write (iout,
+ & '("Free energies, probabilities and rmsds of clusters at",
+ & f6.1," K")') 1.0d0/(1.987d-3*beta_h(ib))
+ prob(1)=1.0d0
+ sumprob=1.0d0
+ do i=2,ngr
+ prob(i)=dexp(-(totfree_gr(i)-totfree_gr(1)))
+ sumprob=sumprob+prob(i)
+ enddo
+ do i=1,ngr
+ prob(i)=prob(i)/sumprob
+ enddo
+ sumprob=0.0d0
+ write(iout,'(/7x,4a20)') " RMSD","TMscore","GDT_TS","GDT_HA"
+ write(iout,'(a5,2x,a6,10a10)')"clust","efree","cl.ave.",
+ & "ave.str.",
+ & "cl.ave.","ave.str","cl.ave","ave.str.","cl.ave","ave.str.",
+ & "prob","sumprob"
+ do i=1,ngr
+ sumprob=sumprob+prob(i)
+ write (iout,'(i3,2x,f8.1,2f10.3,6f10.4,2f10.4)')
+ & i,totfree_gr(i)/beta_h(ib),
+ & rmsave(i),rms_closest(i),tmscore_ave(i),tmscore_closest(i),
+ & gdt_ts_ave(i),gdt_ts_closest(i),gdt_ha_ave(i),
+ & gdt_ha_closest(i),prob(i),sumprob
+ enddo
+ RETURN
+ END
--- /dev/null
+c----------------------------------------------------------------------------
+ subroutine check_energies
+c implicit none
+
+c Includes
+ implicit real*8 (a-h,o-z)
+ 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
+ implicit real*8 (a-h,o-z)
+ 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)
+ integer xshift,yshift,zshift
+c-------END FIRST METHOD
+c-------SECOND METHOD
+c$$$ double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
+c-------END SECOND METHOD
+
+c-------TESTING CODE
+ logical checkstop,transgrad
+ common /sschecks/ checkstop,transgrad
+
+ integer icheck,nicheck,jcheck,njcheck
+ double precision echeck(-1:1),deps,ssx0,ljx0
+c-------END TESTING CODE
+
+
+ i=resi
+ j=resj
+
+ itypi=itype(i)
+ dxi=dc_norm(1,nres+i)
+ dyi=dc_norm(2,nres+i)
+ dzi=dc_norm(3,nres+i)
+ dsci_inv=vbld_inv(i+nres)
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+ xi=dmod(xi,boxxsize)
+ if (xi.lt.0) xi=xi+boxxsize
+ yi=dmod(yi,boxysize)
+ if (yi.lt.0) yi=yi+boxysize
+ zi=dmod(zi,boxzsize)
+ if (zi.lt.0) zi=zi+boxzsize
+C define scaling factor for lipids
+
+C if (positi.le.0) positi=positi+boxzsize
+C print *,i
+C first for peptide groups
+c for each residue check if it is in lipid or lipid water border area
+ if ((zi.gt.bordlipbot)
+ &.and.(zi.lt.bordliptop)) then
+C the energy transfer exist
+ if (zi.lt.buflipbot) then
+C what fraction I am in
+ fracinbuf=1.0d0-
+ & ((positi-bordlipbot)/lipbufthick)
+C lipbufthick is thickenes of lipid buffore
+ sslipi=sscalelip(fracinbuf)
+ ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
+ elseif (zi.gt.bufliptop) then
+ fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
+ sslipi=sscalelip(fracinbuf)
+ ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
+ else
+ sslipi=1.0d0
+ ssgradlipi=0.0
+ endif
+ else
+ sslipi=0.0d0
+ ssgradlipi=0.0
+ endif
+
+ itypj=itype(j)
+ xj=c(1,nres+j)
+ yj=c(2,nres+j)
+ zj=c(3,nres+j)
+ xj=dmod(xj,boxxsize)
+ if (xj.lt.0) xj=xj+boxxsize
+ yj=dmod(yj,boxysize)
+ if (yj.lt.0) yj=yj+boxysize
+ zj=dmod(zj,boxzsize)
+ if (zj.lt.0) zj=zj+boxzsize
+ if ((zj.gt.bordlipbot)
+ &.and.(zj.lt.bordliptop)) then
+C the energy transfer exist
+ if (zj.lt.buflipbot) then
+C what fraction I am in
+ fracinbuf=1.0d0-
+ & ((positi-bordlipbot)/lipbufthick)
+C lipbufthick is thickenes of lipid buffore
+ sslipj=sscalelip(fracinbuf)
+ ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
+ elseif (zi.gt.bufliptop) then
+ fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
+ sslipj=sscalelip(fracinbuf)
+ ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
+ else
+ sslipj=1.0d0
+ ssgradlipj=0.0
+ endif
+ else
+ sslipj=0.0d0
+ ssgradlipj=0.0
+ endif
+ aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
+ & +aa_aq(itypi,itypj)*(2.0d0-sslipi+sslipj)/2.0d0
+ bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
+ & +bb_aq(itypi,itypj)*(2.0d0-sslipi+sslipj)/2.0d0
+
+ dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
+ xj_safe=xj
+ yj_safe=yj
+ zj_safe=zj
+ subchap=0
+ xj_safe=xj
+ yj_safe=yj
+ zj_safe=zj
+ subchap=0
+ do xshift=-1,1
+ do yshift=-1,1
+ do zshift=-1,1
+ xj=xj_safe+xshift*boxxsize
+ yj=yj_safe+yshift*boxysize
+ zj=zj_safe+zshift*boxzsize
+ dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
+ if(dist_temp.lt.dist_init) then
+ dist_init=dist_temp
+ xj_temp=xj
+ yj_temp=yj
+ zj_temp=zj
+ subchap=1
+ endif
+ enddo
+ enddo
+ enddo
+ if (subchap.eq.1) then
+ xj=xj_temp-xi
+ yj=yj_temp-yi
+ zj=zj_temp-zi
+ else
+ xj=xj_safe-xi
+ yj=yj_safe-yi
+ zj=zj_safe-zi
+ endif
+
+ dxj=dc_norm(1,nres+j)
+ dyj=dc_norm(2,nres+j)
+ dzj=dc_norm(3,nres+j)
+ dscj_inv=vbld_inv(j+nres)
+
+ chi1=chi(itypi,itypj)
+ chi2=chi(itypj,itypi)
+ chi12=chi1*chi2
+ chip1=chip(itypi)
+ chip2=chip(itypj)
+ chip12=chip1*chip2
+ alf1=alp(itypi)
+ alf2=alp(itypj)
+ alf12=0.5D0*(alf1+alf2)
+
+ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
+ rij=dsqrt(rrij) ! sc_angular needs rij to really be the inverse
+c The following are set in sc_angular
+c erij(1)=xj*rij
+c erij(2)=yj*rij
+c erij(3)=zj*rij
+c om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
+c om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
+c om12=dxi*dxj+dyi*dyj+dzi*dzj
+ call sc_angular
+ rij=1.0D0/rij ! Reset this so it makes sense
+
+ sig0ij=sigma(itypi,itypj)
+ sig=sig0ij*dsqrt(1.0D0/sigsq)
+
+ ljXs=sig-sig0ij
+ ljA=eps1*eps2rt**2*eps3rt**2
+ ljB=ljA*bb
+ ljA=ljA*aa
+ ljxm=ljXs+(-2.0D0*aa/bb)**(1.0D0/6.0D0)
+
+ ssXs=d0cm
+ deltat1=1.0d0-om1
+ deltat2=1.0d0+om2
+ deltat12=om2-om1+2.0d0
+ cosphi=om12-om1*om2
+ ssA=akcm
+ ssB=akct*deltat12
+ ssC=ss_depth
+ & +akth*(deltat1*deltat1+deltat2*deltat2)
+ & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
+ ssxm=ssXs-0.5D0*ssB/ssA
+
+c-------TESTING CODE
+c$$$c Some extra output
+c$$$ ssm=ssC-0.25D0*ssB*ssB/ssA
+c$$$ ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
+c$$$ ssx0=ssB*ssB-4.0d0*ssA*ssC
+c$$$ if (ssx0.gt.0.0d0) then
+c$$$ ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
+c$$$ else
+c$$$ ssx0=ssxm
+c$$$ endif
+c$$$ ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
+c$$$ write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
+c$$$ & ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
+c$$$ return
+c-------END TESTING CODE
+
+c-------TESTING CODE
+c Stop and plot energy and derivative as a function of distance
+ if (checkstop) then
+ ssm=ssC-0.25D0*ssB*ssB/ssA
+ ljm=-0.25D0*ljB*bb/aa
+ if (ssm.lt.ljm .and.
+ & dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
+ nicheck=1000
+ njcheck=1
+ deps=0.5d-7
+ else
+ checkstop=.false.
+ endif
+ endif
+ if (.not.checkstop) then
+ nicheck=0
+ njcheck=-1
+ endif
+
+ do icheck=0,nicheck
+ do jcheck=-1,njcheck
+ if (checkstop) rij=(ssxm-1.0d0)+
+ & ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
+c-------END TESTING CODE
+
+ if (rij.gt.ljxm) then
+ havebond=.false.
+ ljd=rij-ljXs
+ fac=(1.0D0/ljd)**expon
+ e1=fac*fac*aa
+ e2=fac*bb
+ eij=eps1*eps2rt*eps3rt*(e1+e2)
+C write(iout,*) eij,'TU?1'
+ eps2der=eij*eps3rt
+ eps3der=eij*eps2rt
+ eij=eij*eps2rt*eps3rt
+
+ sigder=-sig/sigsq
+ e1=e1*eps1*eps2rt**2*eps3rt**2
+ ed=-expon*(e1+eij)/ljd
+ sigder=ed*sigder
+ eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
+ eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
+ eom12=eij*eps1_om12+eps2der*eps2rt_om12
+ & -2.0D0*alf12*eps3der+sigder*sigsq_om12
+ else if (rij.lt.ssxm) then
+ havebond=.true.
+ ssd=rij-ssXs
+ eij=ssA*ssd*ssd+ssB*ssd+ssC
+C write(iout,*) 'TU?2',ssc,ssd
+ ed=2*akcm*ssd+akct*deltat12
+ pom1=akct*ssd
+ pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
+ eom1=-2*akth*deltat1-pom1-om2*pom2
+ eom2= 2*akth*deltat2+pom1-om1*pom2
+ eom12=pom2
+ else
+ omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
+
+ d_ssxm(1)=0.5D0*akct/ssA
+ d_ssxm(2)=-d_ssxm(1)
+ d_ssxm(3)=0.0D0
+
+ d_ljxm(1)=sig0ij/sqrt(sigsq**3)
+ d_ljxm(2)=d_ljxm(1)*sigsq_om2
+ d_ljxm(3)=d_ljxm(1)*sigsq_om12
+ d_ljxm(1)=d_ljxm(1)*sigsq_om1
+
+c-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
+ xm=0.5d0*(ssxm+ljxm)
+ do k=1,3
+ d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
+ enddo
+ if (rij.lt.xm) then
+ havebond=.true.
+ ssm=ssC-0.25D0*ssB*ssB/ssA
+ d_ssm(1)=0.5D0*akct*ssB/ssA
+ d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
+ d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
+ d_ssm(3)=omega
+ f1=(rij-xm)/(ssxm-xm)
+ f2=(rij-ssxm)/(xm-ssxm)
+ h1=h_base(f1,hd1)
+ h2=h_base(f2,hd2)
+ eij=ssm*h1+Ht*h2
+C write(iout,*) eij,'TU?3'
+ delta_inv=1.0d0/(xm-ssxm)
+ deltasq_inv=delta_inv*delta_inv
+ fac=ssm*hd1-Ht*hd2
+ fac1=deltasq_inv*fac*(xm-rij)
+ fac2=deltasq_inv*fac*(rij-ssxm)
+ ed=delta_inv*(Ht*hd2-ssm*hd1)
+ eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
+ eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
+ eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
+ else
+ havebond=.false.
+ ljm=-0.25D0*ljB*bb/aa
+ d_ljm(1)=-0.5D0*bb/aa*ljB
+ d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
+ d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt-
+ + alf12/eps3rt)
+ d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
+ f1=(rij-ljxm)/(xm-ljxm)
+ f2=(rij-xm)/(ljxm-xm)
+ h1=h_base(f1,hd1)
+ h2=h_base(f2,hd2)
+ eij=Ht*h1+ljm*h2
+C write(iout,*) 'TU?4',ssA
+ delta_inv=1.0d0/(ljxm-xm)
+ deltasq_inv=delta_inv*delta_inv
+ fac=Ht*hd1-ljm*hd2
+ fac1=deltasq_inv*fac*(ljxm-rij)
+ fac2=deltasq_inv*fac*(rij-xm)
+ ed=delta_inv*(ljm*hd2-Ht*hd1)
+ eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
+ eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
+ eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
+ endif
+c-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
+
+c-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
+c$$$ ssd=rij-ssXs
+c$$$ ljd=rij-ljXs
+c$$$ fac1=rij-ljxm
+c$$$ fac2=rij-ssxm
+c$$$
+c$$$ d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
+c$$$ d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
+c$$$ d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
+c$$$
+c$$$ ssm=ssC-0.25D0*ssB*ssB/ssA
+c$$$ d_ssm(1)=0.5D0*akct*ssB/ssA
+c$$$ d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
+c$$$ d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
+c$$$ d_ssm(3)=omega
+c$$$
+c$$$ ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
+c$$$ do k=1,3
+c$$$ d_ljm(k)=ljm*d_ljB(k)
+c$$$ enddo
+c$$$ ljm=ljm*ljB
+c$$$
+c$$$ ss=ssA*ssd*ssd+ssB*ssd+ssC
+c$$$ d_ss(0)=2.0d0*ssA*ssd+ssB
+c$$$ d_ss(2)=akct*ssd
+c$$$ d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
+c$$$ d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
+c$$$ d_ss(3)=omega
+c$$$
+c$$$ ljf=bb(itypi,itypj)/aa(itypi,itypj)
+c$$$ ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
+c$$$ d_ljf(0)=ljf*2.0d0*ljB*fac1
+c$$$ do k=1,3
+c$$$ d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
+c$$$ & 2.0d0*ljB*fac1*d_ljxm(k))
+c$$$ enddo
+c$$$ ljf=ljm+ljf*ljB*fac1*fac1
+c$$$
+c$$$ f1=(rij-ljxm)/(ssxm-ljxm)
+c$$$ f2=(rij-ssxm)/(ljxm-ssxm)
+c$$$ h1=h_base(f1,hd1)
+c$$$ h2=h_base(f2,hd2)
+c$$$ eij=ss*h1+ljf*h2
+c$$$ delta_inv=1.0d0/(ljxm-ssxm)
+c$$$ deltasq_inv=delta_inv*delta_inv
+c$$$ fac=ljf*hd2-ss*hd1
+c$$$ ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
+c$$$ eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
+c$$$ & (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
+c$$$ eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
+c$$$ & (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
+c$$$ eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
+c$$$ & (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
+c$$$
+c$$$ havebond=.false.
+c$$$ if (ed.gt.0.0d0) havebond=.true.
+c-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
+
+ endif
+C write(iout,*) 'havebond',havebond
+ if (havebond) then
+#ifndef CLUST
+#ifndef WHAM
+c if (dyn_ssbond_ij(i,j).eq.1.0d300) then
+c write(iout,'(a15,f12.2,f8.1,2i5)')
+c & "SSBOND_E_FORM",totT,t_bath,i,j
+c endif
+#endif
+#endif
+ dyn_ssbond_ij(i,j)=eij
+ else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
+ dyn_ssbond_ij(i,j)=1.0d300
+#ifndef CLUST
+#ifndef WHAM
+c write(iout,'(a15,f12.2,f8.1,2i5)')
+c & "SSBOND_E_BREAK",totT,t_bath,i,j
+#endif
+#endif
+ endif
+
+c-------TESTING CODE
+ if (checkstop) then
+ if (jcheck.eq.0) write(iout,'(a,3f15.8,$)')
+ & "CHECKSTOP",rij,eij,ed
+ echeck(jcheck)=eij
+ endif
+ enddo
+ if (checkstop) then
+ write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
+ endif
+ enddo
+ if (checkstop) then
+ transgrad=.true.
+ checkstop=.false.
+ endif
+c-------END TESTING CODE
+
+ do k=1,3
+ dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
+ dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
+ enddo
+ do k=1,3
+ gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
+ enddo
+ do k=1,3
+ gvdwx(k,i)=gvdwx(k,i)-gg(k)
+ & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
+ & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
+ gvdwx(k,j)=gvdwx(k,j)+gg(k)
+ & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
+ & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
+ enddo
+cgrad do k=i,j-1
+cgrad do l=1,3
+cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
+cgrad enddo
+cgrad enddo
+
+ do l=1,3
+ gvdwc(l,i)=gvdwc(l,i)-gg(l)
+ gvdwc(l,j)=gvdwc(l,j)+gg(l)
+ enddo
+
+ return
+ end
+
+C-----------------------------------------------------------------------------
+
+ double precision function h_base(x,deriv)
+c A smooth function going 0->1 in range [0,1]
+c It should NOT be called outside range [0,1], it will not work there.
+ implicit none
+
+c Input arguments
+ double precision x
+
+c Output arguments
+ double precision deriv
+
+c Local variables
+ double precision xsq
+
+
+c Two parabolas put together. First derivative zero at extrema
+c$$$ if (x.lt.0.5D0) then
+c$$$ h_base=2.0D0*x*x
+c$$$ deriv=4.0D0*x
+c$$$ else
+c$$$ deriv=1.0D0-x
+c$$$ h_base=1.0D0-2.0D0*deriv*deriv
+c$$$ deriv=4.0D0*deriv
+c$$$ endif
+
+c Third degree polynomial. First derivative zero at extrema
+ h_base=x*x*(3.0d0-2.0d0*x)
+ deriv=6.0d0*x*(1.0d0-x)
+
+c Fifth degree polynomial. First and second derivatives zero at extrema
+c$$$ xsq=x*x
+c$$$ h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
+c$$$ deriv=x-1.0d0
+c$$$ deriv=deriv*deriv
+c$$$ deriv=30.0d0*xsq*deriv
+
+ return
+ end
+
+c----------------------------------------------------------------------------
+
+ subroutine dyn_set_nss
+c Adjust nss and other relevant variables based on dyn_ssbond_ij
+c implicit none
+
+c Includes
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include "mpif.h"
+#endif
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.CHAIN'
+ include 'COMMON.IOUNITS'
+C include 'COMMON.SETUP'
+#ifndef CLUST
+#ifndef WHAM
+C include 'COMMON.MD'
+#endif
+#endif
+
+c Local variables
+ double precision emin
+ integer i,j,imin
+ integer diff,allflag(maxdim),allnss,
+ & allihpb(maxdim),alljhpb(maxdim),
+ & newnss,newihpb(maxdim),newjhpb(maxdim)
+ logical found
+ integer i_newnss(1024),displ(0:1024)
+ integer g_newihpb(maxdim),g_newjhpb(maxdim),g_newnss
+
+ allnss=0
+ do i=1,nres-1
+ do j=i+1,nres
+ if (dyn_ssbond_ij(i,j).lt.1.0d300) then
+ allnss=allnss+1
+ allflag(allnss)=0
+ allihpb(allnss)=i
+ alljhpb(allnss)=j
+ endif
+ enddo
+ enddo
+
+cmc write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
+
+ 1 emin=1.0d300
+ do i=1,allnss
+ if (allflag(i).eq.0 .and.
+ & dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
+ emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
+ imin=i
+ endif
+ enddo
+ if (emin.lt.1.0d300) then
+ allflag(imin)=1
+ do i=1,allnss
+ if (allflag(i).eq.0 .and.
+ & (allihpb(i).eq.allihpb(imin) .or.
+ & alljhpb(i).eq.allihpb(imin) .or.
+ & allihpb(i).eq.alljhpb(imin) .or.
+ & alljhpb(i).eq.alljhpb(imin))) then
+ allflag(i)=-1
+ endif
+ enddo
+ goto 1
+ endif
+
+cmc write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
+
+ newnss=0
+ do i=1,allnss
+ if (allflag(i).eq.1) then
+ newnss=newnss+1
+ newihpb(newnss)=allihpb(i)
+ newjhpb(newnss)=alljhpb(i)
+ endif
+ enddo
+
+#ifdef MPI
+ if (nfgtasks.gt.1)then
+
+ call MPI_Reduce(newnss,g_newnss,1,
+ & MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
+ call MPI_Gather(newnss,1,MPI_INTEGER,
+ & i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
+ displ(0)=0
+ do i=1,nfgtasks-1,1
+ displ(i)=i_newnss(i-1)+displ(i-1)
+ enddo
+ call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,
+ & g_newihpb,i_newnss,displ,MPI_INTEGER,
+ & king,FG_COMM,IERR)
+ call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,
+ & g_newjhpb,i_newnss,displ,MPI_INTEGER,
+ & king,FG_COMM,IERR)
+ if(fg_rank.eq.0) then
+c print *,'g_newnss',g_newnss
+c print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
+c print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
+ newnss=g_newnss
+ do i=1,newnss
+ newihpb(i)=g_newihpb(i)
+ newjhpb(i)=g_newjhpb(i)
+ enddo
+ endif
+ endif
+#endif
+
+ diff=newnss-nss
+
+cmc write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
+
+ do i=1,nss
+ found=.false.
+ do j=1,newnss
+ if (idssb(i).eq.newihpb(j) .and.
+ & jdssb(i).eq.newjhpb(j)) found=.true.
+ enddo
+#ifndef CLUST
+#ifndef WHAM
+c if (.not.found.and.fg_rank.eq.0)
+c & write(iout,'(a15,f12.2,f8.1,2i5)')
+c & "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
+#endif
+#endif
+ enddo
+
+ do i=1,newnss
+ found=.false.
+ do j=1,nss
+ if (newihpb(i).eq.idssb(j) .and.
+ & newjhpb(i).eq.jdssb(j)) found=.true.
+ enddo
+#ifndef CLUST
+#ifndef WHAM
+c if (.not.found.and.fg_rank.eq.0)
+c & write(iout,'(a15,f12.2,f8.1,2i5)')
+c & "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
+#endif
+#endif
+ enddo
+
+ nss=newnss
+ do i=1,nss
+ idssb(i)=newihpb(i)
+ jdssb(i)=newjhpb(i)
+ enddo
+
+ return
+ end
+
+
+c$$$c-----------------------------------------------------------------------------
+c$$$
+c$$$ subroutine ss_relax(i_in,j_in)
+c$$$ implicit none
+c$$$
+c$$$c Includes
+c$$$ include 'DIMENSIONS'
+c$$$ include 'COMMON.VAR'
+c$$$ include 'COMMON.CHAIN'
+c$$$ include 'COMMON.IOUNITS'
+c$$$ include 'COMMON.INTERACT'
+c$$$
+c$$$c Input arguments
+c$$$ integer i_in,j_in
+c$$$
+c$$$c Local variables
+c$$$ integer i,iretcode,nfun_sc
+c$$$ logical scfail
+c$$$ double precision var(maxvar),e_sc,etot
+c$$$
+c$$$
+c$$$ mask_r=.true.
+c$$$ do i=nnt,nct
+c$$$ mask_side(i)=0
+c$$$ enddo
+c$$$ mask_side(i_in)=1
+c$$$ mask_side(j_in)=1
+c$$$
+c$$$c Minimize the two selected side-chains
+c$$$ call overlap_sc(scfail) ! Better not fail!
+c$$$ call minimize_sc(e_sc,var,iretcode,nfun_sc)
+c$$$
+c$$$ mask_r=.false.
+c$$$
+c$$$ return
+c$$$ end
+c$$$
+c$$$c-------------------------------------------------------------
+c$$$
+c$$$ subroutine minimize_sc(etot_sc,iretcode,nfun)
+c$$$c Minimize side-chains only, starting from geom but without modifying
+c$$$c bond lengths.
+c$$$c If mask_r is already set, only the selected side-chains are minimized,
+c$$$c otherwise all side-chains are minimized keeping the backbone frozen.
+c$$$ implicit none
+c$$$
+c$$$c Includes
+c$$$ include 'DIMENSIONS'
+c$$$ include 'COMMON.IOUNITS'
+c$$$ include 'COMMON.VAR'
+c$$$ include 'COMMON.CHAIN'
+c$$$ include 'COMMON.GEO'
+c$$$ include 'COMMON.MINIM'
+c$$$ integer icall
+c$$$ common /srutu/ icall
+c$$$
+c$$$c Output arguments
+c$$$ double precision etot_sc
+c$$$ integer iretcode,nfun
+c$$$
+c$$$c External functions/subroutines
+c$$$ external func_sc,grad_sc,fdum
+c$$$
+c$$$c Local variables
+c$$$ integer liv,lv
+c$$$ parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2))
+c$$$ integer iv(liv)
+c$$$ double precision rdum(1)
+c$$$ double precision d(maxvar),v(1:lv),x(maxvar),xx(maxvar)
+c$$$ integer idum(1)
+c$$$ integer i,nvar_restr
+c$$$
+c$$$
+c$$$cmc start_minim=.true.
+c$$$ call deflt(2,iv,liv,lv,v)
+c$$$* 12 means fresh start, dont call deflt
+c$$$ iv(1)=12
+c$$$* max num of fun calls
+c$$$ if (maxfun.eq.0) maxfun=500
+c$$$ iv(17)=maxfun
+c$$$* max num of iterations
+c$$$ if (maxmin.eq.0) maxmin=1000
+c$$$ iv(18)=maxmin
+c$$$* controls output
+c$$$ iv(19)=1
+c$$$* selects output unit
+c$$$ iv(21)=0
+c$$$c iv(21)=iout ! DEBUG
+c$$$c iv(21)=8 ! DEBUG
+c$$$* 1 means to print out result
+c$$$ iv(22)=0
+c$$$c iv(22)=1 ! DEBUG
+c$$$* 1 means to print out summary stats
+c$$$ iv(23)=0
+c$$$c iv(23)=1 ! DEBUG
+c$$$* 1 means to print initial x and d
+c$$$ iv(24)=0
+c$$$c iv(24)=1 ! DEBUG
+c$$$* min val for v(radfac) default is 0.1
+c$$$ v(24)=0.1D0
+c$$$* max val for v(radfac) default is 4.0
+c$$$ v(25)=2.0D0
+c$$$c v(25)=4.0D0
+c$$$* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease)
+c$$$* the sumsl default is 0.1
+c$$$ v(26)=0.1D0
+c$$$* false conv if (act fnctn decrease) .lt. v(34)
+c$$$* the sumsl default is 100*machep
+c$$$ v(34)=v(34)/100.0D0
+c$$$* absolute convergence
+c$$$ if (tolf.eq.0.0D0) tolf=1.0D-4
+c$$$ v(31)=tolf
+c$$$* relative convergence
+c$$$ if (rtolf.eq.0.0D0) rtolf=1.0D-1
+c$$$ v(32)=rtolf
+c$$$* controls initial step size
+c$$$ v(35)=1.0D-1
+c$$$* large vals of d correspond to small components of step
+c$$$ do i=1,nphi
+c$$$ d(i)=1.0D-1
+c$$$ enddo
+c$$$ do i=nphi+1,nvar
+c$$$ d(i)=1.0D-1
+c$$$ enddo
+c$$$
+c$$$ call geom_to_var(nvar,x)
+c$$$ IF (mask_r) THEN
+c$$$ do i=1,nres ! Just in case...
+c$$$ mask_phi(i)=0
+c$$$ mask_theta(i)=0
+c$$$ enddo
+c$$$ call x2xx(x,xx,nvar_restr)
+c$$$ call sumsl(nvar_restr,d,xx,func_sc,grad_sc,
+c$$$ & iv,liv,lv,v,idum,rdum,fdum)
+c$$$ call xx2x(x,xx)
+c$$$ ELSE
+c$$$c When minimizing ALL side-chains, etotal_sc is a little
+c$$$c faster if we don't set mask_r
+c$$$ do i=1,nres
+c$$$ mask_phi(i)=0
+c$$$ mask_theta(i)=0
+c$$$ mask_side(i)=1
+c$$$ enddo
+c$$$ call x2xx(x,xx,nvar_restr)
+c$$$ call sumsl(nvar_restr,d,xx,func_sc,grad_sc,
+c$$$ & iv,liv,lv,v,idum,rdum,fdum)
+c$$$ call xx2x(x,xx)
+c$$$ ENDIF
+c$$$ call var_to_geom(nvar,x)
+c$$$ call chainbuild_sc
+c$$$ etot_sc=v(10)
+c$$$ iretcode=iv(1)
+c$$$ nfun=iv(6)
+c$$$ return
+c$$$ end
+c$$$
+c$$$C--------------------------------------------------------------------------
+c$$$
+c$$$ subroutine chainbuild_sc
+c$$$ implicit none
+c$$$ include 'DIMENSIONS'
+c$$$ include 'COMMON.VAR'
+c$$$ include 'COMMON.INTERACT'
+c$$$
+c$$$c Local variables
+c$$$ integer i
+c$$$
+c$$$
+c$$$ do i=nnt,nct
+c$$$ if (.not.mask_r .or. mask_side(i).eq.1) then
+c$$$ call locate_side_chain(i)
+c$$$ endif
+c$$$ enddo
+c$$$
+c$$$ return
+c$$$ end
+c$$$
+c$$$C--------------------------------------------------------------------------
+c$$$
+c$$$ subroutine func_sc(n,x,nf,f,uiparm,urparm,ufparm)
+c$$$ implicit none
+c$$$
+c$$$c Includes
+c$$$ include 'DIMENSIONS'
+c$$$ include 'COMMON.DERIV'
+c$$$ include 'COMMON.VAR'
+c$$$ include 'COMMON.MINIM'
+c$$$ include 'COMMON.IOUNITS'
+c$$$
+c$$$c Input arguments
+c$$$ integer n
+c$$$ double precision x(maxvar)
+c$$$ double precision ufparm
+c$$$ external ufparm
+c$$$
+c$$$c Input/Output arguments
+c$$$ integer nf
+c$$$ integer uiparm(1)
+c$$$ double precision urparm(1)
+c$$$
+c$$$c Output arguments
+c$$$ double precision f
+c$$$
+c$$$c Local variables
+c$$$ double precision energia(0:n_ene)
+c$$$#ifdef OSF
+c$$$c Variables used to intercept NaNs
+c$$$ double precision x_sum
+c$$$ integer i_NAN
+c$$$#endif
+c$$$
+c$$$
+c$$$ nfl=nf
+c$$$ icg=mod(nf,2)+1
+c$$$
+c$$$#ifdef OSF
+c$$$c Intercept NaNs in the coordinates, before calling etotal_sc
+c$$$ x_sum=0.D0
+c$$$ do i_NAN=1,n
+c$$$ x_sum=x_sum+x(i_NAN)
+c$$$ enddo
+c$$$c Calculate the energy only if the coordinates are ok
+c$$$ if ((.not.(x_sum.lt.0.D0)) .and. (.not.(x_sum.ge.0.D0))) then
+c$$$ write(iout,*)" *** func_restr_sc : Found NaN in coordinates"
+c$$$ f=1.0D+77
+c$$$ nf=0
+c$$$ else
+c$$$#endif
+c$$$
+c$$$ call var_to_geom_restr(n,x)
+c$$$ call zerograd
+c$$$ call chainbuild_sc
+c$$$ call etotal_sc(energia(0))
+c$$$ f=energia(0)
+c$$$ if (energia(1).eq.1.0D20 .or. energia(0).eq.1.0D99) nf=0
+c$$$
+c$$$#ifdef OSF
+c$$$ endif
+c$$$#endif
+c$$$
+c$$$ return
+c$$$ end
+c$$$
+c$$$c-------------------------------------------------------
+c$$$
+c$$$ subroutine grad_sc(n,x,nf,g,uiparm,urparm,ufparm)
+c$$$ implicit none
+c$$$
+c$$$c Includes
+c$$$ include 'DIMENSIONS'
+c$$$ include 'COMMON.CHAIN'
+c$$$ include 'COMMON.DERIV'
+c$$$ include 'COMMON.VAR'
+c$$$ include 'COMMON.INTERACT'
+c$$$ include 'COMMON.MINIM'
+c$$$
+c$$$c Input arguments
+c$$$ integer n
+c$$$ double precision x(maxvar)
+c$$$ double precision ufparm
+c$$$ external ufparm
+c$$$
+c$$$c Input/Output arguments
+c$$$ integer nf
+c$$$ integer uiparm(1)
+c$$$ double precision urparm(1)
+c$$$
+c$$$c Output arguments
+c$$$ double precision g(maxvar)
+c$$$
+c$$$c Local variables
+c$$$ double precision f,gphii,gthetai,galphai,gomegai
+c$$$ integer ig,ind,i,j,k,igall,ij
+c$$$
+c$$$
+c$$$ icg=mod(nf,2)+1
+c$$$ if (nf-nfl+1) 20,30,40
+c$$$ 20 call func_sc(n,x,nf,f,uiparm,urparm,ufparm)
+c$$$c write (iout,*) 'grad 20'
+c$$$ if (nf.eq.0) return
+c$$$ goto 40
+c$$$ 30 call var_to_geom_restr(n,x)
+c$$$ call chainbuild_sc
+c$$$C
+c$$$C Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
+c$$$C
+c$$$ 40 call cartder
+c$$$C
+c$$$C Convert the Cartesian gradient into internal-coordinate gradient.
+c$$$C
+c$$$
+c$$$ ig=0
+c$$$ ind=nres-2
+c$$$ do i=2,nres-2
+c$$$ IF (mask_phi(i+2).eq.1) THEN
+c$$$ gphii=0.0D0
+c$$$ do j=i+1,nres-1
+c$$$ ind=ind+1
+c$$$ do k=1,3
+c$$$ gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
+c$$$ gphii=gphii+dxdv(k+3,ind)*gradx(k,j,icg)
+c$$$ enddo
+c$$$ enddo
+c$$$ ig=ig+1
+c$$$ g(ig)=gphii
+c$$$ ELSE
+c$$$ ind=ind+nres-1-i
+c$$$ ENDIF
+c$$$ enddo
+c$$$
+c$$$
+c$$$ ind=0
+c$$$ do i=1,nres-2
+c$$$ IF (mask_theta(i+2).eq.1) THEN
+c$$$ ig=ig+1
+c$$$ gthetai=0.0D0
+c$$$ do j=i+1,nres-1
+c$$$ ind=ind+1
+c$$$ do k=1,3
+c$$$ gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
+c$$$ gthetai=gthetai+dxdv(k,ind)*gradx(k,j,icg)
+c$$$ enddo
+c$$$ enddo
+c$$$ g(ig)=gthetai
+c$$$ ELSE
+c$$$ ind=ind+nres-1-i
+c$$$ ENDIF
+c$$$ enddo
+c$$$
+c$$$ do i=2,nres-1
+c$$$ if (itype(i).ne.10) then
+c$$$ IF (mask_side(i).eq.1) THEN
+c$$$ ig=ig+1
+c$$$ galphai=0.0D0
+c$$$ do k=1,3
+c$$$ galphai=galphai+dxds(k,i)*gradx(k,i,icg)
+c$$$ enddo
+c$$$ g(ig)=galphai
+c$$$ ENDIF
+c$$$ endif
+c$$$ enddo
+c$$$
+c$$$
+c$$$ do i=2,nres-1
+c$$$ if (itype(i).ne.10) then
+c$$$ IF (mask_side(i).eq.1) THEN
+c$$$ ig=ig+1
+c$$$ gomegai=0.0D0
+c$$$ do k=1,3
+c$$$ gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
+c$$$ enddo
+c$$$ g(ig)=gomegai
+c$$$ ENDIF
+c$$$ endif
+c$$$ enddo
+c$$$
+c$$$C
+c$$$C Add the components corresponding to local energy terms.
+c$$$C
+c$$$
+c$$$ ig=0
+c$$$ igall=0
+c$$$ do i=4,nres
+c$$$ igall=igall+1
+c$$$ if (mask_phi(i).eq.1) then
+c$$$ ig=ig+1
+c$$$ g(ig)=g(ig)+gloc(igall,icg)
+c$$$ endif
+c$$$ enddo
+c$$$
+c$$$ do i=3,nres
+c$$$ igall=igall+1
+c$$$ if (mask_theta(i).eq.1) then
+c$$$ ig=ig+1
+c$$$ g(ig)=g(ig)+gloc(igall,icg)
+c$$$ endif
+c$$$ enddo
+c$$$
+c$$$ do ij=1,2
+c$$$ do i=2,nres-1
+c$$$ if (itype(i).ne.10) then
+c$$$ igall=igall+1
+c$$$ if (mask_side(i).eq.1) then
+c$$$ ig=ig+1
+c$$$ g(ig)=g(ig)+gloc(igall,icg)
+c$$$ endif
+c$$$ endif
+c$$$ enddo
+c$$$ enddo
+c$$$
+c$$$cd do i=1,ig
+c$$$cd write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i)
+c$$$cd enddo
+c$$$
+c$$$ return
+c$$$ end
+c$$$
+c$$$C-----------------------------------------------------------------------------
+c$$$
+c$$$ subroutine etotal_sc(energy_sc)
+c$$$ implicit none
+c$$$
+c$$$c Includes
+c$$$ include 'DIMENSIONS'
+c$$$ include 'COMMON.VAR'
+c$$$ include 'COMMON.INTERACT'
+c$$$ include 'COMMON.DERIV'
+c$$$ include 'COMMON.FFIELD'
+c$$$
+c$$$c Output arguments
+c$$$ double precision energy_sc(0:n_ene)
+c$$$
+c$$$c Local variables
+c$$$ double precision evdw,escloc
+c$$$ integer i,j
+c$$$
+c$$$
+c$$$ do i=1,n_ene
+c$$$ energy_sc(i)=0.0D0
+c$$$ enddo
+c$$$
+c$$$ if (mask_r) then
+c$$$ call egb_sc(evdw)
+c$$$ call esc_sc(escloc)
+c$$$ else
+c$$$ call egb(evdw)
+c$$$ call esc(escloc)
+c$$$ endif
+c$$$
+c$$$ if (evdw.eq.1.0D20) then
+c$$$ energy_sc(0)=evdw
+c$$$ else
+c$$$ energy_sc(0)=wsc*evdw+wscloc*escloc
+c$$$ endif
+c$$$ energy_sc(1)=evdw
+c$$$ energy_sc(12)=escloc
+c$$$
+c$$$C
+c$$$C Sum up the components of the Cartesian gradient.
+c$$$C
+c$$$ do i=1,nct
+c$$$ do j=1,3
+c$$$ gradx(j,i,icg)=wsc*gvdwx(j,i)
+c$$$ enddo
+c$$$ enddo
+c$$$
+c$$$ return
+c$$$ end
+c$$$
+c$$$C-----------------------------------------------------------------------------
+c$$$
+c$$$ subroutine egb_sc(evdw)
+c$$$C
+c$$$C This subroutine calculates the interaction energy of nonbonded side chains
+c$$$C assuming the Gay-Berne potential of interaction.
+c$$$C
+c$$$ implicit real*8 (a-h,o-z)
+c$$$ include 'DIMENSIONS'
+c$$$ include 'COMMON.GEO'
+c$$$ include 'COMMON.VAR'
+c$$$ include 'COMMON.LOCAL'
+c$$$ include 'COMMON.CHAIN'
+c$$$ include 'COMMON.DERIV'
+c$$$ include 'COMMON.NAMES'
+c$$$ include 'COMMON.INTERACT'
+c$$$ include 'COMMON.IOUNITS'
+c$$$ include 'COMMON.CALC'
+c$$$ include 'COMMON.CONTROL'
+c$$$ logical lprn
+c$$$ evdw=0.0D0
+c$$$ energy_dec=.false.
+c$$$c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
+c$$$ evdw=0.0D0
+c$$$ lprn=.false.
+c$$$c if (icall.eq.0) lprn=.false.
+c$$$ ind=0
+c$$$ do i=iatsc_s,iatsc_e
+c$$$ itypi=itype(i)
+c$$$ itypi1=itype(i+1)
+c$$$ xi=c(1,nres+i)
+c$$$ yi=c(2,nres+i)
+c$$$ zi=c(3,nres+i)
+c$$$ dxi=dc_norm(1,nres+i)
+c$$$ dyi=dc_norm(2,nres+i)
+c$$$ dzi=dc_norm(3,nres+i)
+c$$$c dsci_inv=dsc_inv(itypi)
+c$$$ dsci_inv=vbld_inv(i+nres)
+c$$$c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
+c$$$c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
+c$$$C
+c$$$C Calculate SC interaction energy.
+c$$$C
+c$$$ do iint=1,nint_gr(i)
+c$$$ do j=istart(i,iint),iend(i,iint)
+c$$$ IF (mask_side(j).eq.1.or.mask_side(i).eq.1) THEN
+c$$$ ind=ind+1
+c$$$ itypj=itype(j)
+c$$$c dscj_inv=dsc_inv(itypj)
+c$$$ dscj_inv=vbld_inv(j+nres)
+c$$$c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
+c$$$c & 1.0d0/vbld(j+nres)
+c$$$c write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
+c$$$ sig0ij=sigma(itypi,itypj)
+c$$$ chi1=chi(itypi,itypj)
+c$$$ chi2=chi(itypj,itypi)
+c$$$ chi12=chi1*chi2
+c$$$ chip1=chip(itypi)
+c$$$ chip2=chip(itypj)
+c$$$ chip12=chip1*chip2
+c$$$ alf1=alp(itypi)
+c$$$ alf2=alp(itypj)
+c$$$ alf12=0.5D0*(alf1+alf2)
+c$$$C For diagnostics only!!!
+c$$$c chi1=0.0D0
+c$$$c chi2=0.0D0
+c$$$c chi12=0.0D0
+c$$$c chip1=0.0D0
+c$$$c chip2=0.0D0
+c$$$c chip12=0.0D0
+c$$$c alf1=0.0D0
+c$$$c alf2=0.0D0
+c$$$c alf12=0.0D0
+c$$$ xj=c(1,nres+j)-xi
+c$$$ yj=c(2,nres+j)-yi
+c$$$ zj=c(3,nres+j)-zi
+c$$$ dxj=dc_norm(1,nres+j)
+c$$$ dyj=dc_norm(2,nres+j)
+c$$$ dzj=dc_norm(3,nres+j)
+c$$$c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
+c$$$c write (iout,*) "j",j," dc_norm",
+c$$$c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
+c$$$ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
+c$$$ rij=dsqrt(rrij)
+c$$$C Calculate angle-dependent terms of energy and contributions to their
+c$$$C derivatives.
+c$$$ call sc_angular
+c$$$ sigsq=1.0D0/sigsq
+c$$$ sig=sig0ij*dsqrt(sigsq)
+c$$$ rij_shift=1.0D0/rij-sig+sig0ij
+c$$$c for diagnostics; uncomment
+c$$$c rij_shift=1.2*sig0ij
+c$$$C I hate to put IF's in the loops, but here don't have another choice!!!!
+c$$$ if (rij_shift.le.0.0D0) then
+c$$$ evdw=1.0D20
+c$$$cd write (iout,'(2(a3,i3,2x),17(0pf7.3))')
+c$$$cd & restyp(itypi),i,restyp(itypj),j,
+c$$$cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
+c$$$ return
+c$$$ endif
+c$$$ sigder=-sig*sigsq
+c$$$c---------------------------------------------------------------
+c$$$ rij_shift=1.0D0/rij_shift
+c$$$ fac=rij_shift**expon
+c$$$ e1=fac*fac*aa(itypi,itypj)
+c$$$ e2=fac*bb(itypi,itypj)
+c$$$ evdwij=eps1*eps2rt*eps3rt*(e1+e2)
+c$$$ eps2der=evdwij*eps3rt
+c$$$ eps3der=evdwij*eps2rt
+c$$$c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
+c$$$c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
+c$$$ evdwij=evdwij*eps2rt*eps3rt
+c$$$ evdw=evdw+evdwij
+c$$$ if (lprn) then
+c$$$ sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
+c$$$ epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
+c$$$ write (iout,'(2(a3,i3,2x),17(0pf7.3))')
+c$$$ & restyp(itypi),i,restyp(itypj),j,
+c$$$ & epsi,sigm,chi1,chi2,chip1,chip2,
+c$$$ & eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
+c$$$ & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
+c$$$ & evdwij
+c$$$ endif
+c$$$
+c$$$ if (energy_dec) write (iout,'(a6,2i,0pf7.3)')
+c$$$ & 'evdw',i,j,evdwij
+c$$$
+c$$$C Calculate gradient components.
+c$$$ e1=e1*eps1*eps2rt**2*eps3rt**2
+c$$$ fac=-expon*(e1+evdwij)*rij_shift
+c$$$ sigder=fac*sigder
+c$$$ fac=rij*fac
+c$$$c fac=0.0d0
+c$$$C Calculate the radial part of the gradient
+c$$$ gg(1)=xj*fac
+c$$$ gg(2)=yj*fac
+c$$$ gg(3)=zj*fac
+c$$$C Calculate angular part of the gradient.
+c$$$ call sc_grad
+c$$$ ENDIF
+c$$$ enddo ! j
+c$$$ enddo ! iint
+c$$$ enddo ! i
+c$$$ energy_dec=.false.
+c$$$ return
+c$$$ end
+c$$$
+c$$$c-----------------------------------------------------------------------------
+c$$$
+c$$$ subroutine esc_sc(escloc)
+c$$$C Calculate the local energy of a side chain and its derivatives in the
+c$$$C corresponding virtual-bond valence angles THETA and the spherical angles
+c$$$C ALPHA and OMEGA.
+c$$$ implicit real*8 (a-h,o-z)
+c$$$ include 'DIMENSIONS'
+c$$$ include 'COMMON.GEO'
+c$$$ include 'COMMON.LOCAL'
+c$$$ include 'COMMON.VAR'
+c$$$ include 'COMMON.INTERACT'
+c$$$ include 'COMMON.DERIV'
+c$$$ include 'COMMON.CHAIN'
+c$$$ include 'COMMON.IOUNITS'
+c$$$ include 'COMMON.NAMES'
+c$$$ include 'COMMON.FFIELD'
+c$$$ include 'COMMON.CONTROL'
+c$$$ double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
+c$$$ & ddersc0(3),ddummy(3),xtemp(3),temp(3)
+c$$$ common /sccalc/ time11,time12,time112,theti,it,nlobit
+c$$$ delta=0.02d0*pi
+c$$$ escloc=0.0D0
+c$$$c write (iout,'(a)') 'ESC'
+c$$$ do i=loc_start,loc_end
+c$$$ IF (mask_side(i).eq.1) THEN
+c$$$ it=itype(i)
+c$$$ if (it.eq.10) goto 1
+c$$$ nlobit=nlob(it)
+c$$$c print *,'i=',i,' it=',it,' nlobit=',nlobit
+c$$$c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
+c$$$ theti=theta(i+1)-pipol
+c$$$ x(1)=dtan(theti)
+c$$$ x(2)=alph(i)
+c$$$ x(3)=omeg(i)
+c$$$
+c$$$ if (x(2).gt.pi-delta) then
+c$$$ xtemp(1)=x(1)
+c$$$ xtemp(2)=pi-delta
+c$$$ xtemp(3)=x(3)
+c$$$ call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
+c$$$ xtemp(2)=pi
+c$$$ call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
+c$$$ call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
+c$$$ & escloci,dersc(2))
+c$$$ call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
+c$$$ & ddersc0(1),dersc(1))
+c$$$ call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
+c$$$ & ddersc0(3),dersc(3))
+c$$$ xtemp(2)=pi-delta
+c$$$ call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
+c$$$ xtemp(2)=pi
+c$$$ call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
+c$$$ call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
+c$$$ & dersc0(2),esclocbi,dersc02)
+c$$$ call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
+c$$$ & dersc12,dersc01)
+c$$$ call splinthet(x(2),0.5d0*delta,ss,ssd)
+c$$$ dersc0(1)=dersc01
+c$$$ dersc0(2)=dersc02
+c$$$ dersc0(3)=0.0d0
+c$$$ do k=1,3
+c$$$ dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
+c$$$ enddo
+c$$$ dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
+c$$$c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
+c$$$c & esclocbi,ss,ssd
+c$$$ escloci=ss*escloci+(1.0d0-ss)*esclocbi
+c$$$c escloci=esclocbi
+c$$$c write (iout,*) escloci
+c$$$ else if (x(2).lt.delta) then
+c$$$ xtemp(1)=x(1)
+c$$$ xtemp(2)=delta
+c$$$ xtemp(3)=x(3)
+c$$$ call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
+c$$$ xtemp(2)=0.0d0
+c$$$ call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
+c$$$ call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
+c$$$ & escloci,dersc(2))
+c$$$ call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
+c$$$ & ddersc0(1),dersc(1))
+c$$$ call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
+c$$$ & ddersc0(3),dersc(3))
+c$$$ xtemp(2)=delta
+c$$$ call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
+c$$$ xtemp(2)=0.0d0
+c$$$ call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
+c$$$ call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
+c$$$ & dersc0(2),esclocbi,dersc02)
+c$$$ call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
+c$$$ & dersc12,dersc01)
+c$$$ dersc0(1)=dersc01
+c$$$ dersc0(2)=dersc02
+c$$$ dersc0(3)=0.0d0
+c$$$ call splinthet(x(2),0.5d0*delta,ss,ssd)
+c$$$ do k=1,3
+c$$$ dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
+c$$$ enddo
+c$$$ dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
+c$$$c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
+c$$$c & esclocbi,ss,ssd
+c$$$ escloci=ss*escloci+(1.0d0-ss)*esclocbi
+c$$$c write (iout,*) escloci
+c$$$ else
+c$$$ call enesc(x,escloci,dersc,ddummy,.false.)
+c$$$ endif
+c$$$
+c$$$ escloc=escloc+escloci
+c$$$ if (energy_dec) write (iout,'(a6,i,0pf7.3)')
+c$$$ & 'escloc',i,escloci
+c$$$c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
+c$$$
+c$$$ gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
+c$$$ & wscloc*dersc(1)
+c$$$ gloc(ialph(i,1),icg)=wscloc*dersc(2)
+c$$$ gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
+c$$$ 1 continue
+c$$$ ENDIF
+c$$$ enddo
+c$$$ return
+c$$$ end
+c$$$
+c$$$C-----------------------------------------------------------------------------
+c$$$
+c$$$ subroutine egb_ij(i_sc,j_sc,evdw)
+c$$$C
+c$$$C This subroutine calculates the interaction energy of nonbonded side chains
+c$$$C assuming the Gay-Berne potential of interaction.
+c$$$C
+c$$$ implicit real*8 (a-h,o-z)
+c$$$ include 'DIMENSIONS'
+c$$$ include 'COMMON.GEO'
+c$$$ include 'COMMON.VAR'
+c$$$ include 'COMMON.LOCAL'
+c$$$ include 'COMMON.CHAIN'
+c$$$ include 'COMMON.DERIV'
+c$$$ include 'COMMON.NAMES'
+c$$$ include 'COMMON.INTERACT'
+c$$$ include 'COMMON.IOUNITS'
+c$$$ include 'COMMON.CALC'
+c$$$ include 'COMMON.CONTROL'
+c$$$ logical lprn
+c$$$ evdw=0.0D0
+c$$$ energy_dec=.false.
+c$$$c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
+c$$$ evdw=0.0D0
+c$$$ lprn=.false.
+c$$$ ind=0
+c$$$c$$$ do i=iatsc_s,iatsc_e
+c$$$ i=i_sc
+c$$$ itypi=itype(i)
+c$$$ itypi1=itype(i+1)
+c$$$ xi=c(1,nres+i)
+c$$$ yi=c(2,nres+i)
+c$$$ zi=c(3,nres+i)
+c$$$ dxi=dc_norm(1,nres+i)
+c$$$ dyi=dc_norm(2,nres+i)
+c$$$ dzi=dc_norm(3,nres+i)
+c$$$c dsci_inv=dsc_inv(itypi)
+c$$$ dsci_inv=vbld_inv(i+nres)
+c$$$c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
+c$$$c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
+c$$$C
+c$$$C Calculate SC interaction energy.
+c$$$C
+c$$$c$$$ do iint=1,nint_gr(i)
+c$$$c$$$ do j=istart(i,iint),iend(i,iint)
+c$$$ j=j_sc
+c$$$ ind=ind+1
+c$$$ itypj=itype(j)
+c$$$c dscj_inv=dsc_inv(itypj)
+c$$$ dscj_inv=vbld_inv(j+nres)
+c$$$c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
+c$$$c & 1.0d0/vbld(j+nres)
+c$$$c write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
+c$$$ sig0ij=sigma(itypi,itypj)
+c$$$ chi1=chi(itypi,itypj)
+c$$$ chi2=chi(itypj,itypi)
+c$$$ chi12=chi1*chi2
+c$$$ chip1=chip(itypi)
+c$$$ chip2=chip(itypj)
+c$$$ chip12=chip1*chip2
+c$$$ alf1=alp(itypi)
+c$$$ alf2=alp(itypj)
+c$$$ alf12=0.5D0*(alf1+alf2)
+c$$$C For diagnostics only!!!
+c$$$c chi1=0.0D0
+c$$$c chi2=0.0D0
+c$$$c chi12=0.0D0
+c$$$c chip1=0.0D0
+c$$$c chip2=0.0D0
+c$$$c chip12=0.0D0
+c$$$c alf1=0.0D0
+c$$$c alf2=0.0D0
+c$$$c alf12=0.0D0
+c$$$ xj=c(1,nres+j)-xi
+c$$$ yj=c(2,nres+j)-yi
+c$$$ zj=c(3,nres+j)-zi
+c$$$ dxj=dc_norm(1,nres+j)
+c$$$ dyj=dc_norm(2,nres+j)
+c$$$ dzj=dc_norm(3,nres+j)
+c$$$c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
+c$$$c write (iout,*) "j",j," dc_norm",
+c$$$c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
+c$$$ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
+c$$$ rij=dsqrt(rrij)
+c$$$C Calculate angle-dependent terms of energy and contributions to their
+c$$$C derivatives.
+c$$$ call sc_angular
+c$$$ sigsq=1.0D0/sigsq
+c$$$ sig=sig0ij*dsqrt(sigsq)
+c$$$ rij_shift=1.0D0/rij-sig+sig0ij
+c$$$c for diagnostics; uncomment
+c$$$c rij_shift=1.2*sig0ij
+c$$$C I hate to put IF's in the loops, but here don't have another choice!!!!
+c$$$ if (rij_shift.le.0.0D0) then
+c$$$ evdw=1.0D20
+c$$$cd write (iout,'(2(a3,i3,2x),17(0pf7.3))')
+c$$$cd & restyp(itypi),i,restyp(itypj),j,
+c$$$cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
+c$$$ return
+c$$$ endif
+c$$$ sigder=-sig*sigsq
+c$$$c---------------------------------------------------------------
+c$$$ rij_shift=1.0D0/rij_shift
+c$$$ fac=rij_shift**expon
+c$$$ e1=fac*fac*aa(itypi,itypj)
+c$$$ e2=fac*bb(itypi,itypj)
+c$$$ evdwij=eps1*eps2rt*eps3rt*(e1+e2)
+c$$$ eps2der=evdwij*eps3rt
+c$$$ eps3der=evdwij*eps2rt
+c$$$c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
+c$$$c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
+c$$$ evdwij=evdwij*eps2rt*eps3rt
+c$$$ evdw=evdw+evdwij
+c$$$ if (lprn) then
+c$$$ sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
+c$$$ epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
+c$$$ write (iout,'(2(a3,i3,2x),17(0pf7.3))')
+c$$$ & restyp(itypi),i,restyp(itypj),j,
+c$$$ & epsi,sigm,chi1,chi2,chip1,chip2,
+c$$$ & eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
+c$$$ & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
+c$$$ & evdwij
+c$$$ endif
+c$$$
+c$$$ if (energy_dec) write (iout,'(a6,2i,0pf7.3)')
+c$$$ & 'evdw',i,j,evdwij
+c$$$
+c$$$C Calculate gradient components.
+c$$$ e1=e1*eps1*eps2rt**2*eps3rt**2
+c$$$ fac=-expon*(e1+evdwij)*rij_shift
+c$$$ sigder=fac*sigder
+c$$$ fac=rij*fac
+c$$$c fac=0.0d0
+c$$$C Calculate the radial part of the gradient
+c$$$ gg(1)=xj*fac
+c$$$ gg(2)=yj*fac
+c$$$ gg(3)=zj*fac
+c$$$C Calculate angular part of the gradient.
+c$$$ call sc_grad
+c$$$c$$$ enddo ! j
+c$$$c$$$ enddo ! iint
+c$$$c$$$ enddo ! i
+c$$$ energy_dec=.false.
+c$$$ return
+c$$$ end
+c$$$
+c$$$C-----------------------------------------------------------------------------
+c$$$
+c$$$ subroutine perturb_side_chain(i,angle)
+c$$$ implicit none
+c$$$
+c$$$c Includes
+c$$$ include 'DIMENSIONS'
+c$$$ include 'COMMON.CHAIN'
+c$$$ include 'COMMON.GEO'
+c$$$ include 'COMMON.VAR'
+c$$$ include 'COMMON.LOCAL'
+c$$$ include 'COMMON.IOUNITS'
+c$$$
+c$$$c External functions
+c$$$ external ran_number
+c$$$ double precision ran_number
+c$$$
+c$$$c Input arguments
+c$$$ integer i
+c$$$ double precision angle ! In degrees
+c$$$
+c$$$c Local variables
+c$$$ integer i_sc
+c$$$ double precision rad_ang,rand_v(3),length,cost,sint
+c$$$
+c$$$
+c$$$ i_sc=i+nres
+c$$$ rad_ang=angle*deg2rad
+c$$$
+c$$$ length=0.0
+c$$$ do while (length.lt.0.01)
+c$$$ rand_v(1)=ran_number(0.01D0,1.0D0)
+c$$$ rand_v(2)=ran_number(0.01D0,1.0D0)
+c$$$ rand_v(3)=ran_number(0.01D0,1.0D0)
+c$$$ length=rand_v(1)*rand_v(1)+rand_v(2)*rand_v(2)+
+c$$$ + rand_v(3)*rand_v(3)
+c$$$ length=sqrt(length)
+c$$$ rand_v(1)=rand_v(1)/length
+c$$$ rand_v(2)=rand_v(2)/length
+c$$$ rand_v(3)=rand_v(3)/length
+c$$$ cost=rand_v(1)*dc_norm(1,i_sc)+rand_v(2)*dc_norm(2,i_sc)+
+c$$$ + rand_v(3)*dc_norm(3,i_sc)
+c$$$ length=1.0D0-cost*cost
+c$$$ if (length.lt.0.0D0) length=0.0D0
+c$$$ length=sqrt(length)
+c$$$ rand_v(1)=rand_v(1)-cost*dc_norm(1,i_sc)
+c$$$ rand_v(2)=rand_v(2)-cost*dc_norm(2,i_sc)
+c$$$ rand_v(3)=rand_v(3)-cost*dc_norm(3,i_sc)
+c$$$ enddo
+c$$$ rand_v(1)=rand_v(1)/length
+c$$$ rand_v(2)=rand_v(2)/length
+c$$$ rand_v(3)=rand_v(3)/length
+c$$$
+c$$$ cost=dcos(rad_ang)
+c$$$ sint=dsin(rad_ang)
+c$$$ dc(1,i_sc)=vbld(i_sc)*(dc_norm(1,i_sc)*cost+rand_v(1)*sint)
+c$$$ dc(2,i_sc)=vbld(i_sc)*(dc_norm(2,i_sc)*cost+rand_v(2)*sint)
+c$$$ dc(3,i_sc)=vbld(i_sc)*(dc_norm(3,i_sc)*cost+rand_v(3)*sint)
+c$$$ dc_norm(1,i_sc)=dc(1,i_sc)*vbld_inv(i_sc)
+c$$$ dc_norm(2,i_sc)=dc(2,i_sc)*vbld_inv(i_sc)
+c$$$ dc_norm(3,i_sc)=dc(3,i_sc)*vbld_inv(i_sc)
+c$$$ c(1,i_sc)=c(1,i)+dc(1,i_sc)
+c$$$ c(2,i_sc)=c(2,i)+dc(2,i_sc)
+c$$$ c(3,i_sc)=c(3,i)+dc(3,i_sc)
+c$$$
+c$$$ call chainbuild_cart
+c$$$
+c$$$ return
+c$$$ end
+c$$$
+c$$$c----------------------------------------------------------------------------
+c$$$
+c$$$ subroutine ss_relax3(i_in,j_in)
+c$$$ implicit none
+c$$$
+c$$$c Includes
+c$$$ include 'DIMENSIONS'
+c$$$ include 'COMMON.VAR'
+c$$$ include 'COMMON.CHAIN'
+c$$$ include 'COMMON.IOUNITS'
+c$$$ include 'COMMON.INTERACT'
+c$$$
+c$$$c External functions
+c$$$ external ran_number
+c$$$ double precision ran_number
+c$$$
+c$$$c Input arguments
+c$$$ integer i_in,j_in
+c$$$
+c$$$c Local variables
+c$$$ double precision energy_sc(0:n_ene),etot
+c$$$ double precision org_dc(3),org_dc_norm(3),org_c(3)
+c$$$ double precision ang_pert,rand_fact,exp_fact,beta
+c$$$ integer n,i_pert,i
+c$$$ logical notdone
+c$$$
+c$$$
+c$$$ beta=1.0D0
+c$$$
+c$$$ mask_r=.true.
+c$$$ do i=nnt,nct
+c$$$ mask_side(i)=0
+c$$$ enddo
+c$$$ mask_side(i_in)=1
+c$$$ mask_side(j_in)=1
+c$$$
+c$$$ call etotal_sc(energy_sc)
+c$$$ etot=energy_sc(0)
+c$$$c write(iout,'(a,3d15.5)')" SS_MC_START ",energy_sc(0),
+c$$$c + energy_sc(1),energy_sc(12)
+c$$$
+c$$$ notdone=.true.
+c$$$ n=0
+c$$$ do while (notdone)
+c$$$ if (mod(n,2).eq.0) then
+c$$$ i_pert=i_in
+c$$$ else
+c$$$ i_pert=j_in
+c$$$ endif
+c$$$ n=n+1
+c$$$
+c$$$ do i=1,3
+c$$$ org_dc(i)=dc(i,i_pert+nres)
+c$$$ org_dc_norm(i)=dc_norm(i,i_pert+nres)
+c$$$ org_c(i)=c(i,i_pert+nres)
+c$$$ enddo
+c$$$ ang_pert=ran_number(0.0D0,3.0D0)
+c$$$ call perturb_side_chain(i_pert,ang_pert)
+c$$$ call etotal_sc(energy_sc)
+c$$$ exp_fact=exp(beta*(etot-energy_sc(0)))
+c$$$ rand_fact=ran_number(0.0D0,1.0D0)
+c$$$ if (rand_fact.lt.exp_fact) then
+c$$$c write(iout,'(a,3d15.5)')" SS_MC_ACCEPT ",energy_sc(0),
+c$$$c + energy_sc(1),energy_sc(12)
+c$$$ etot=energy_sc(0)
+c$$$ else
+c$$$c write(iout,'(a,3d15.5)')" SS_MC_REJECT ",energy_sc(0),
+c$$$c + energy_sc(1),energy_sc(12)
+c$$$ do i=1,3
+c$$$ dc(i,i_pert+nres)=org_dc(i)
+c$$$ dc_norm(i,i_pert+nres)=org_dc_norm(i)
+c$$$ c(i,i_pert+nres)=org_c(i)
+c$$$ enddo
+c$$$ endif
+c$$$
+c$$$ if (n.eq.10000.or.etot.lt.30.0D0) notdone=.false.
+c$$$ enddo
+c$$$
+c$$$ mask_r=.false.
+c$$$
+c$$$ return
+c$$$ end
+c$$$
+c$$$c----------------------------------------------------------------------------
+c$$$
+c$$$ subroutine ss_relax2(etot,iretcode,nfun,i_in,j_in)
+c$$$ implicit none
+c$$$ include 'DIMENSIONS'
+c$$$ integer liv,lv
+c$$$ parameter (liv=60,lv=(77+maxres6*(maxres6+17)/2))
+c$$$*********************************************************************
+c$$$* OPTIMIZE sets up SUMSL or DFP and provides a simple interface for *
+c$$$* the calling subprogram. *
+c$$$* when d(i)=1.0, then v(35) is the length of the initial step, *
+c$$$* calculated in the usual pythagorean way. *
+c$$$* absolute convergence occurs when the function is within v(31) of *
+c$$$* zero. unless you know the minimum value in advance, abs convg *
+c$$$* is probably not useful. *
+c$$$* relative convergence is when the model predicts that the function *
+c$$$* will decrease by less than v(32)*abs(fun). *
+c$$$*********************************************************************
+c$$$ include 'COMMON.IOUNITS'
+c$$$ include 'COMMON.VAR'
+c$$$ include 'COMMON.GEO'
+c$$$ include 'COMMON.MINIM'
+c$$$ include 'COMMON.CHAIN'
+c$$$
+c$$$ double precision orig_ss_dc,orig_ss_var,orig_ss_dist
+c$$$ common /orig_ss/ orig_ss_dc(3,0:maxres2),orig_ss_var(maxvar),
+c$$$ + orig_ss_dist(maxres2,maxres2)
+c$$$
+c$$$ double precision etot
+c$$$ integer iretcode,nfun,i_in,j_in
+c$$$
+c$$$ external dist
+c$$$ double precision dist
+c$$$ external ss_func,fdum
+c$$$ double precision ss_func,fdum
+c$$$
+c$$$ integer iv(liv),uiparm(2)
+c$$$ double precision v(lv),x(maxres6),d(maxres6),rdum
+c$$$ integer i,j,k
+c$$$
+c$$$
+c$$$ call deflt(2,iv,liv,lv,v)
+c$$$* 12 means fresh start, dont call deflt
+c$$$ iv(1)=12
+c$$$* max num of fun calls
+c$$$ if (maxfun.eq.0) maxfun=500
+c$$$ iv(17)=maxfun
+c$$$* max num of iterations
+c$$$ if (maxmin.eq.0) maxmin=1000
+c$$$ iv(18)=maxmin
+c$$$* controls output
+c$$$ iv(19)=2
+c$$$* selects output unit
+c$$$c iv(21)=iout
+c$$$ iv(21)=0
+c$$$* 1 means to print out result
+c$$$ iv(22)=0
+c$$$* 1 means to print out summary stats
+c$$$ iv(23)=0
+c$$$* 1 means to print initial x and d
+c$$$ iv(24)=0
+c$$$* min val for v(radfac) default is 0.1
+c$$$ v(24)=0.1D0
+c$$$* max val for v(radfac) default is 4.0
+c$$$ v(25)=2.0D0
+c$$$c v(25)=4.0D0
+c$$$* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease)
+c$$$* the sumsl default is 0.1
+c$$$ v(26)=0.1D0
+c$$$* false conv if (act fnctn decrease) .lt. v(34)
+c$$$* the sumsl default is 100*machep
+c$$$ v(34)=v(34)/100.0D0
+c$$$* absolute convergence
+c$$$ if (tolf.eq.0.0D0) tolf=1.0D-4
+c$$$ v(31)=tolf
+c$$$ v(31)=1.0D-1
+c$$$* relative convergence
+c$$$ if (rtolf.eq.0.0D0) rtolf=1.0D-4
+c$$$ v(32)=rtolf
+c$$$ v(32)=1.0D-1
+c$$$* controls initial step size
+c$$$ v(35)=1.0D-1
+c$$$* large vals of d correspond to small components of step
+c$$$ do i=1,6*nres
+c$$$ d(i)=1.0D0
+c$$$ enddo
+c$$$
+c$$$ do i=0,2*nres
+c$$$ do j=1,3
+c$$$ orig_ss_dc(j,i)=dc(j,i)
+c$$$ enddo
+c$$$ enddo
+c$$$ call geom_to_var(nvar,orig_ss_var)
+c$$$
+c$$$ do i=1,nres
+c$$$ do j=i,nres
+c$$$ orig_ss_dist(j,i)=dist(j,i)
+c$$$ orig_ss_dist(j+nres,i)=dist(j+nres,i)
+c$$$ orig_ss_dist(j,i+nres)=dist(j,i+nres)
+c$$$ orig_ss_dist(j+nres,i+nres)=dist(j+nres,i+nres)
+c$$$ enddo
+c$$$ enddo
+c$$$
+c$$$ k=0
+c$$$ do i=1,nres-1
+c$$$ do j=1,3
+c$$$ k=k+1
+c$$$ x(k)=dc(j,i)
+c$$$ enddo
+c$$$ enddo
+c$$$ do i=2,nres-1
+c$$$ if (ialph(i,1).gt.0) then
+c$$$ do j=1,3
+c$$$ k=k+1
+c$$$ x(k)=dc(j,i+nres)
+c$$$ enddo
+c$$$ endif
+c$$$ enddo
+c$$$
+c$$$ uiparm(1)=i_in
+c$$$ uiparm(2)=j_in
+c$$$ call smsno(k,d,x,ss_func,iv,liv,lv,v,uiparm,rdum,fdum)
+c$$$ etot=v(10)
+c$$$ iretcode=iv(1)
+c$$$ nfun=iv(6)+iv(30)
+c$$$
+c$$$ k=0
+c$$$ do i=1,nres-1
+c$$$ do j=1,3
+c$$$ k=k+1
+c$$$ dc(j,i)=x(k)
+c$$$ enddo
+c$$$ enddo
+c$$$ do i=2,nres-1
+c$$$ if (ialph(i,1).gt.0) then
+c$$$ do j=1,3
+c$$$ k=k+1
+c$$$ dc(j,i+nres)=x(k)
+c$$$ enddo
+c$$$ endif
+c$$$ enddo
+c$$$ call chainbuild_cart
+c$$$
+c$$$ return
+c$$$ end
+c$$$
+c$$$C-----------------------------------------------------------------------------
+c$$$
+c$$$ subroutine ss_func(n,x,nf,f,uiparm,urparm,ufparm)
+c$$$ implicit none
+c$$$ include 'DIMENSIONS'
+c$$$ include 'COMMON.DERIV'
+c$$$ include 'COMMON.IOUNITS'
+c$$$ include 'COMMON.VAR'
+c$$$ include 'COMMON.CHAIN'
+c$$$ include 'COMMON.INTERACT'
+c$$$ include 'COMMON.SBRIDGE'
+c$$$
+c$$$ double precision orig_ss_dc,orig_ss_var,orig_ss_dist
+c$$$ common /orig_ss/ orig_ss_dc(3,0:maxres2),orig_ss_var(maxvar),
+c$$$ + orig_ss_dist(maxres2,maxres2)
+c$$$
+c$$$ integer n
+c$$$ double precision x(maxres6)
+c$$$ integer nf
+c$$$ double precision f
+c$$$ integer uiparm(2)
+c$$$ real*8 urparm(1)
+c$$$ external ufparm
+c$$$ double precision ufparm
+c$$$
+c$$$ external dist
+c$$$ double precision dist
+c$$$
+c$$$ integer i,j,k,ss_i,ss_j
+c$$$ double precision tempf,var(maxvar)
+c$$$
+c$$$
+c$$$ ss_i=uiparm(1)
+c$$$ ss_j=uiparm(2)
+c$$$ f=0.0D0
+c$$$
+c$$$ k=0
+c$$$ do i=1,nres-1
+c$$$ do j=1,3
+c$$$ k=k+1
+c$$$ dc(j,i)=x(k)
+c$$$ enddo
+c$$$ enddo
+c$$$ do i=2,nres-1
+c$$$ if (ialph(i,1).gt.0) then
+c$$$ do j=1,3
+c$$$ k=k+1
+c$$$ dc(j,i+nres)=x(k)
+c$$$ enddo
+c$$$ endif
+c$$$ enddo
+c$$$ call chainbuild_cart
+c$$$
+c$$$ call geom_to_var(nvar,var)
+c$$$
+c$$$c Constraints on all angles
+c$$$ do i=1,nvar
+c$$$ tempf=var(i)-orig_ss_var(i)
+c$$$ f=f+tempf*tempf
+c$$$ enddo
+c$$$
+c$$$c Constraints on all distances
+c$$$ do i=1,nres-1
+c$$$ if (i.gt.1) then
+c$$$ tempf=dist(i+nres,i)-orig_ss_dist(i+nres,i)
+c$$$ f=f+tempf*tempf
+c$$$ endif
+c$$$ do j=i+1,nres
+c$$$ tempf=dist(j,i)-orig_ss_dist(j,i)
+c$$$ if (tempf.lt.0.0D0 .or. j.eq.i+1) f=f+tempf*tempf
+c$$$ tempf=dist(j+nres,i)-orig_ss_dist(j+nres,i)
+c$$$ if (tempf.lt.0.0D0) f=f+tempf*tempf
+c$$$ tempf=dist(j,i+nres)-orig_ss_dist(j,i+nres)
+c$$$ if (tempf.lt.0.0D0) f=f+tempf*tempf
+c$$$ tempf=dist(j+nres,i+nres)-orig_ss_dist(j+nres,i+nres)
+c$$$ if (tempf.lt.0.0D0) f=f+tempf*tempf
+c$$$ enddo
+c$$$ enddo
+c$$$
+c$$$c Constraints for the relevant CYS-CYS
+c$$$ tempf=dist(nres+ss_i,nres+ss_j)-8.0D0
+c$$$ f=f+tempf*tempf
+c$$$CCCCCCCCCCCCCCCCC ADD SOME ANGULAR STUFF
+c$$$
+c$$$c$$$ if (nf.ne.nfl) then
+c$$$c$$$ write(iout,'(a,i10,2d15.5)')"IN DIST_FUNC (NF,F,DIST)",nf,
+c$$$c$$$ + f,dist(5+nres,14+nres)
+c$$$c$$$ endif
+c$$$
+c$$$ nfl=nf
+c$$$
+c$$$ return
+c$$$ end
+c$$$
+c$$$C-----------------------------------------------------------------------------
+c$$$C-----------------------------------------------------------------------------
+ subroutine triple_ssbond_ene(resi,resj,resk,eij)
+ implicit real*8 (a-h,o-z)
+ 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
+C $Date: 1994/10/05 16:41:52 $
+C $Revision: 2.2 $
+C
+C
+C
+ subroutine set_timers
+c
+ double precision tcpu ! function
+ 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()
+ return
+ end
+ logical function stopx(nf)
+C
+C ..................................................................
+C
+C *****PURPOSE...
+C THIS FUNCTION MAY SERVE AS THE STOPX (ASYNCHRONOUS INTERRUPTION)
+C FUNCTION FOR THE NL2SOL (NONLINEAR LEAST-SQUARES) PACKAGE AT
+C THOSE INSTALLATIONS WHICH DO NOT WISH TO IMPLEMENT A
+C DYNAMIC STOPX.
+C
+C *****ALGORITHM NOTES...
+C AT INSTALLATIONS WHERE THE NL2SOL SYSTEM IS USED
+C INTERACTIVELY, THIS DUMMY STOPX SHOULD BE REPLACED BY A
+C FUNCTION THAT RETURNS .TRUE. IF AND ONLY IF THE INTERRUPT
+C (BREAK) KEY HAS BEEN PRESSED SINCE THE LAST CALL ON STOPX.
+C
+C $$$ MODIFIED FOR USE AS THE TIMER ROUTINE.
+C $$$ WHEN THE TIME LIMIT HAS BEEN
+C $$$ REACHED STOPX IS SET TO .TRUE AND INITIATES (IN ITSUM)
+C $$$ AND ORDERLY EXIT OUT OF SUMSL. IF ARRAYS IV AND V ARE
+C $$$ SAVED, THE SUMSL ROUTINES CAN BE RESTARTED AT THE SAME
+C $$$ POINT AT WHICH THEY WERE INTERRUPTED.
+C
+C ..................................................................
+C
+ include 'DIMENSIONS'
+ integer nf
+ logical ovrtim
+ include 'COMMON.IOUNITS'
+ include 'COMMON.TIME1'
+#ifdef MPL
+ include 'COMMON.INFO'
+ integer Kwita
+
+cd print *,'Processor',MyID,' NF=',nf
+#endif
+ if (ovrtim()) then
+C Finish if time is up.
+ stopx = .true.
+#ifdef MPL
+ else if (mod(nf,100).eq.0) then
+C Other processors might have finished. Check this every 100th function
+C evaluation.
+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.
+ else
+ stopx=.false.
+ endif
+#endif
+ else
+ stopx = .false.
+ endif
+ return
+ end
+C=========================================================================
+C
+ logical function ovrtim()
+ double precision tcpu ! function
+ include 'COMMON.TIME1'
+C Set a 100.0 secs. safety margin, so as to allow for the termination of
+C a batch job.
+c double safety /150.0D0/
+ curtim= tcpu()
+cd print *,'curtim=',curtim,' timlim=',timlim
+C curtim is the current time in seconds.
+ ovrtim=(curtim .ge. timlim - safety )
+ return
+ end
+C=========================================================================
+C
+ 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
+ integer seconds
+ call clock(seconds)
+ tcpu=seconds - stime
+****************************
+#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)
+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 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
+ return
+ end
+*
+ 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
+ SUBROUTINE TRACK(ICUT)
+ include 'DIMENSIONS'
+ INCLUDE 'sizesclu.dat'
+ INCLUDE 'COMMON.CLUSTER'
+ COMMON /HISTORY/ NCUR(MAX_CUT),IBACK(MAXGR,MAX_CUT)
+ COMMON /PREVIOUS/ NGRP,LICZP(MAXGR),NCONFP(MAXGR,MAXINGR)
+ IF (ICUT.GT.1) THEN
+C Find out what of the previous families the current ones came from.
+ DO IGR=1,NGR
+ NCI1=NCONF(IGR,1)
+ DO JGR=1,NGRP
+ DO K=1,LICZP(JGR)
+ IF (NCI1.EQ.NCONFP(JGR,K)) THEN
+ IBACK(IGR,ICUT)=JGR
+ GOTO 10
+ ENDIF
+ ENDDO ! K
+ ENDDO ! JGR
+ 10 CONTINUE
+ ENDDO ! IGR
+ ENDIF ! (ICUT.GT.1)
+C Save current partition for subsequent backtracking.
+ NCUR(ICUT)=NGR
+ NGRP=NGR
+ DO IGR=1,NGR
+ LICZP(IGR)=LICZ(IGR)
+ DO K=1,LICZ(IGR)
+ NCONFP(IGR,K)=NCONF(IGR,K)
+ ENDDO ! K
+ ENDDO ! IGR
+ RETURN
+ END
+C------------------------------------------------------------------------------
+ SUBROUTINE WRITRACK
+ include 'DIMENSIONS'
+ INCLUDE 'sizesclu.dat'
+ INCLUDE 'COMMON.CLUSTER'
+ include 'COMMON.IOUNITS'
+ COMMON /HISTORY/ NCUR(MAX_CUT),IBACK(MAXGR,MAX_CUT)
+ COMMON /PREVIOUS/ NGRP,LICZP(MAXGR),NCONFP(MAXGR,MAXINGR)
+ DIMENSION IPART(MAXGR/5,MAXGR/5)
+c do icut=2,ncut
+c write (iout,'(a,f10.5)') 'Cut-off',rcutoff(icut)
+c write (iout,'(16i5)') (iback(k,icut),k=1,ncur(icut))
+c enddo
+C
+C Print the partition history.
+C
+ DO ICUT=2,NCUT
+ NCU=NCUR(ICUT)
+ NCUP=NCUR(ICUT-1)
+cd print *,'icut=',icut,' ncu=',ncu,' ncur=',ncur
+ WRITE(iout,'(A,f10.5,A,f10.5)')
+ & 'Partition of families obtained at cut-off',RCUTOFF(ICUT-1),
+ & ' at cut-off',RCUTOFF(ICUT)
+ DO I=1,NCUP
+ NPART=0
+cd print *,'i=',i
+ DO J=1,NCU
+ IF (IBACK(J,ICUT).EQ.I) THEN
+ NPART=NPART+1
+ IPART(NPART,I)=J
+ ENDIF
+cd print *,'j=',j,' iback=',IBACK(J,ICUT),' npart=',npart
+ ENDDO ! J
+ WRITE (iout,'(16I5)') I,(IPART(K,I),K=1,NPART)
+ ENDDO ! I
+ ENDDO ! ICUT
+ RETURN
+ END
+C------------------------------------------------------------------------------
+ SUBROUTINE PLOTREE
+ include 'DIMENSIONS'
+ INCLUDE 'sizesclu.dat'
+ INCLUDE 'COMMON.CLUSTER'
+ include 'COMMON.IOUNITS'
+ COMMON /HISTORY/ NCUR(MAX_CUT),IBACK(MAXGR,MAX_CUT)
+ COMMON /PREVIOUS/ NGRP,LICZP(MAXGR),NCONFP(MAXGR,MAXINGR)
+ DIMENSION Y(MAXGR,MAX_CUT)
+ DIMENSION ITREE(MAXGR,MAX_CUT),IFIRST(MAXGR,MAX_CUT),
+ &ILAST(MAXGR,MAX_CUT),IFT(MAXGR),ILT(MAXGR),ITR(MAXGR)
+ CHARACTER*32 FD
+ external ilen
+C
+C Generate the image of the tree (tentatively for LaTeX picture environment).
+C
+C
+C First untangle the branches of the tree
+C
+ DO I=1,NCUR(1)
+ ITREE(I,1)=I
+ ENDDO
+ DO ICUT=NCUT,2,-1
+C
+C Determine the order of families for the (icut)th partition.
+C
+ NCU=NCUR(ICUT)
+ NCUP=NCUR(ICUT-1)
+ NPART=0
+ DO I=1,NCUP
+ IS=0
+ IF (I.GT.1) ILAST(I-1,ICUT-1)=NPART
+ DO J=1,NCU
+ IF (IBACK(J,ICUT).EQ.I) THEN
+ NPART=NPART+1
+ IF (IS.EQ.0) THEN
+ IS=1
+ IFIRST(I,ICUT-1)=NPART
+ ENDIF
+ ITREE(NPART,ICUT)=J
+ ENDIF
+ ENDDO ! J
+ ENDDO ! I
+ ILAST(NCUP,ICUT-1)=NPART
+cd print *,'i=',i,' ncup=',ncup,' ncu=',ncu,' npart=',npart
+ ENDDO ! ICUT
+c diagnostic printout
+cd do icut=1,ncut
+cd write (iout,*) 'Cut-off',icut,' = ',rcutoff(icut)
+cd write (iout,*) 'ITREE'
+cd write (iout,*) (itree(i,icut),i=1,ncur(icut))
+cd write (iout,*) 'IFIRST, ILAST'
+cd write (iout,*) (ifirst(i,icut),ilast(i,icut),i=1,ncur(icut))
+cd enddo
+C
+C Propagate the order of families from cut-off #2 to cut-off #n.
+C
+ DO ICUT=1,NCUT-1
+ DO J=1,NCUR(ICUT)
+ IFT(J)=IFIRST(J,ICUT)
+ ILT(J)=ILAST(J,ICUT)
+ ENDDO ! J
+ DO J=1,NCUR(ICUT+1)
+ ITR(J)=ITREE(J,ICUT+1)
+ ENDDO
+ DO I=1,NCUR(ICUT)
+ ITI=ITREE(I,ICUT)
+c write (iout,*) 'icut=',icut,' i=',i,' iti=',iti
+C IF (ITI.NE.I) THEN
+ JF1=IFT(I)
+ JF2=IFT(ITI)
+ JL1=ILT(I)
+ JL2=ILT(ITI)
+ JR1=JL1-JF1+1
+ JR2=JL2-JF2+1
+Cd write (iout,*) 'jf1=',jf1,' jl1=',jl1,' jf2=',jf2,
+Cd & ' jl2=',jl2
+Cd write (iout,*) 'jr1=',jr1,' jr2=',jr2
+C Update IFIRST and ILAST.
+ ILAST(I,ICUT)=IFIRST(I,ICUT)+JR2-1
+ IFIRST(I+1,ICUT)=ILAST(I,ICUT)+1
+C Update ITREE.
+ JF11=IFIRST(I,ICUT)
+Cd write(iout,*) 'jf11=',jf11
+ DO J=JF2,JL2
+Cd write (iout,*) j,JF11+J-JF2,ITR(J)
+ ITREE(JF11+J-JF2,ICUT+1)=ITR(J)
+ ENDDO
+Cd write (iout,*) (ifirst(k,icut),ilast(k,icut),k=1,i)
+Cd write (iout,*) (itree(k,icut+1),k=1,ilast(i,icut))
+C ENDIF ! (ITI.NE.I)
+ ENDDO ! I
+ ENDDO ! ICUT
+c diagnostic printout
+cd do icut=1,ncut
+cd write (iout,*) 'Cut-off',icut,' = ',rcutoff(icut)
+cd write (iout,*) 'ITREE'
+cd write (iout,*) (itree(i,icut),i=1,ncur(icut))
+cd write (iout,*) 'IFIRST, ILAST'
+cd write (iout,*) (ifirst(i,icut),ilast(i,icut),i=1,ncur(icut))
+cd enddo
+C
+C Generate the y-coordinates of the branches.
+C
+ XLEN=400.0/(ncut-1)
+ YLEN=600.0
+ xbox=xlen/4.0
+ deltx=0.5*(xlen-xbox)
+ NNC=NCUR(NCUT)
+ ybox=ylen/(2.0*nnc)
+ DO J=1,NNC
+ Y(J,NCUT)=J*YLEN/NNC
+ ENDDO
+ DO ICUT=NCUT-1,1,-1
+ NNC=NCUR(ICUT)
+ DO J=1,NNC
+ KF=IFIRST(J,ICUT)
+ KL=ILAST(J,ICUT)
+ YY=0.0
+ DO K=KF,KL
+ YY=YY+Y(K,ICUT+1)
+ ENDDO
+ Y(J,ICUT)=YY/(KL-KF+1)
+ ENDDO ! J
+ ENDDO ! ICUT
+c diagnostic output
+cd do icut=1,ncut
+cd write(iout,*) 'Cut-off=',rcutoff(icut)
+cd write(iout,'(8f10.3)') (y(j,icut),j=1,ncur(icut))
+cd enddo
+C
+C Generate LaTeX script for tree plot
+C
+ iylen=ylen
+#ifdef AIX
+ call fdate_(fd)
+#else
+ call fdate(fd)
+#endif
+ write(jplot,'(80(1h%))')
+ write(jplot,'(a)') '% LaTeX code for minimal-tree plotting.'
+ write(jplot,'(3a)') '% Created by UNRES_CLUST on ',
+ & fd(:ilen(fd)),'.'
+ write(jplot,'(2a)') '% To change the dimensions use the LaTeX',
+ & ' \\unitlength=number command.'
+ write(jplot,'(a)') '% The default dimensions fit an A4 page.'
+ write(jplot,'(80(1h%))')
+ write(jplot,'(a,i5,a)') '\\begin{picture}(1,1)(0,',iylen,')'
+ ycur=ylen+ybox
+ do icut=ncut,1,-1
+ xcur=xlen*(icut-1)
+ write(jplot,'(a,f6.1,a,f6.1,a,f4.2,a)')
+ & ' \\put(',xcur,',',ycur,'){',rcutoff(icut),' \\AA}'
+ enddo ! icut
+ xcur=0.0
+ xdraw=xcur+xbox
+ nnc=ncur(1)
+ write(jplot,'(a,i3,a)') '% Begin cut-off',1,'.'
+ do j=1,nnc
+ ydraw=y(j,1)
+ ycur=ydraw-0.5*ybox
+ ideltx=deltx
+ write(jplot,'(4(a,f6.1),a,i3,a)')
+ & ' \\put(',xcur,',',ycur,'){\\framebox(',xbox,',',ybox,'){',
+ & itree(j,1),'}}'
+ write(jplot,'(2(a,f6.1),2(a,i5),a,f6.1,a)')
+ & ' \\put(',xdraw,',',ydraw,'){\\line(',ideltx,
+ & ',',0,'){',deltx,'}}'
+ enddo ! j
+ do icut=2,ncut
+ write(jplot,'(a,i3,a)') '% Begin cut-off',icut,'.'
+ xcur=xlen*(icut-1)
+ xdraw=xcur-deltx
+cd print *,'icut=',icut,' xlen=',xlen,' deltx=',deltx,
+cd & ' xcur=',xcur,' xdraw=',xdraw
+ nnc=ncur(icut)
+ do j=1,ncur(icut-1)
+ ydraw=y(ifirst(j,icut-1),icut)
+ delty=y(ilast(j,icut-1),icut)-y(ifirst(j,icut-1),icut)
+ idelty=delty
+ write(jplot,'(2(a,f6.1),2(a,i5),a,f6.1,a)')
+ & ' \\put(',xdraw,',',ydraw,'){\\line(',0,
+ & ',',idelty,'){',delty,'}}'
+ enddo
+ do j=1,nnc
+ xcur=xlen*(icut-1)
+ xdraw=xcur-deltx
+ ydraw=y(j,icut)
+ ycur=ydraw-0.5*ybox
+ ideltx=deltx
+ write(jplot,'(2(a,f6.1),2(a,i5),a,f6.1,a)')
+ & ' \\put(',xdraw,',',ydraw,'){\\line(',ideltx,
+ & ',',0,'){',deltx,'}}'
+ write(jplot,'(4(a,f6.1),a,i3,a)')
+ & ' \\put(',xcur,',',ycur,'){\\framebox(',xbox,',',ybox,'){',
+ & itree(j,icut),'}}'
+ if (icut.lt.ncut) then
+ xdraw=xcur+xbox
+ write(jplot,'(2(a,f6.1),2(a,i5),a,f6.1,a)')
+ & ' \\put(',xdraw,',',ydraw,'){\\line(',ideltx,
+ & ',',0,'){',deltx,'}}'
+ endif
+ enddo ! j
+ enddo ! icut
+ write(jplot,'(a)') '\\end{picture}'
+ RETURN
+ END
--- /dev/null
+#ifdef MPI
+ subroutine work_partition(lprint,ncon_work)
+c Split the conformations between processors
+ implicit none
+ include "DIMENSIONS"
+ include "sizesclu.dat"
+ include "mpif.h"
+ include "COMMON.IOUNITS"
+ include "COMMON.CLUSTER"
+ include "COMMON.MPI"
+ integer n,chunk,i,j,ii,remainder
+ integer kolor,key,ierror,errcode,ncon_work
+ 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=ncon_work
+ write (iout,*) "n=",n," nprocs=",nprocs
+ indstart(0)=1
+ chunk = N/nprocs
+ scount(0) = chunk
+c print *,"i",0," indstart",indstart(0)," scount",
+c & scount(0)
+ do i=1,nprocs-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(nprocs-1)
+ & +scount(nprocs-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,nprocs-1
+ indstart(i) = indstart(i) + remainder
+ enddo
+ endif
+
+ indstart(nprocs)=N+1
+ scount(nprocs)=0
+
+ do i=0,NProcs
+ indend(i)=indstart(i)+scount(i)-1
+ idispl(i)=indstart(i)-1
+ enddo
+
+ N=0
+ do i=0,Nprocs-1
+ N=N+indend(i)-indstart(i)+1
+ enddo
+
+c print *,"N",n," NCON_WORK",ncon_work
+ if (N.ne.ncon_work) then
+ write (iout,*) "!!! Checksum error on processor",me,
+ & n,ncon_work
+ call flush(iout)
+ call MPI_Abort( MPI_COMM_WORLD, Ierror, Errcode )
+ endif
+
+ if (lprint) then
+ write (iout,*) "Partition of work between processors"
+C do i=0,nprocs-1
+C write (iout,'(a,i5,a,i7,a,i7,a,i7)')
+C & "Processor",i," indstart",indstart(i),
+C & " indend",indend(i)," count",scount(i)
+C enddo
+ endif
+c write(iout,*) "just before leave"
+ return
+ end
+#endif
--- /dev/null
+ SUBROUTINE WRTCLUST(NCON,ICUT,PRINTANG,PRINTPDB,printmol2,ib)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'sizesclu.dat'
+ parameter (num_in_line=5)
+ LOGICAL PRINTANG(max_cut)
+ integer PRINTPDB(max_cut),printmol2(max_cut)
+ include 'COMMON.CONTROL'
+ include 'COMMON.HEADER'
+ include 'COMMON.CHAIN'
+ include 'COMMON.VAR'
+ include 'COMMON.CLUSTER'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.FREE'
+ include 'COMMON.TEMPFAC'
+ include 'COMMON.FFIELD'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.TORCNSTR'
+ include 'COMMON.SAXS'
+ CHARACTER*64 prefixp,NUMM,MUMM,EXTEN,extmol
+ character*120 cfname
+ character*8 ctemper
+ DATA EXTEN /'.pdb'/,extmol /'.mol2'/,NUMM /'000'/,MUMM /'000'/
+ external ilen
+ logical viol_nmr
+ integer ib,list_peak_viol(maxdim)
+ double precision Esaxs_all(maxgr),Pcalc_all(maxsaxs,maxgr)
+
+ do i=1,64
+ cfname(i:i)=" "
+ enddo
+c print *,"calling WRTCLUST",ncon
+c write (iout,*) "ICUT",icut," PRINTPDB ",PRINTPDB(icut)
+ rewind 80
+ call flush(iout)
+ temper=1.0d0/(beta_h(ib)*1.987d-3)
+ if (temper.lt.100.0d0) then
+ write(ctemper,'(f3.0)') temper
+ ctemper(3:3)=" "
+ else if (temper.lt.1000.0) then
+ write (ctemper,'(f4.0)') temper
+ ctemper(4:4)=" "
+ else
+ write (ctemper,'(f5.0)') temper
+ ctemper(5:5)=" "
+ endif
+
+ do i=1,ncon*(ncon-1)/2
+ read (80) diss(i)
+ enddo
+ close(80,status='delete')
+C
+C PRINT OUT THE RESULTS OF CLUSTER ANALYSIS
+C
+ ii1= index(intinname,'/')
+ ii2=ii1
+ ii1=ii1+1
+ do while (ii2.gt.0)
+ ii1=ii1+ii2
+ ii2=index(intinname(ii1:),'/')
+ enddo
+ ii = ii1+index(intinname(ii1:),'.')-1
+ if (ii.eq.0) then
+ ii=ilen(intinname)
+ else
+ ii=ii-1
+ endif
+ prefixp=intinname(ii1:ii)
+cd print *,icut,printang(icut),printpdb(icut),printmol2(icut)
+cd print *,'ecut=',ecut
+ WRITE (iout,100) NGR
+ DO 19 IGR=1,NGR
+ WRITE (iout,200) IGR,totfree_gr(igr)/beta_h(ib),LICZ(IGR)
+ NRECORD=LICZ(IGR)/num_in_line
+ IND1=1
+ DO 63 IRECORD=1,NRECORD
+ IND2=IND1+num_in_line-1
+ WRITE (iout,300) (list_conf(NCONF(IGR,ICO)),
+ & totfree(NCONF(IGR,ICO))/beta_h(ib),ICO=IND1,IND2)
+ IND1=IND2+1
+ 63 CONTINUE
+ WRITE (iout,300) (list_conf(NCONF(IGR,ICO)),
+ & totfree(NCONF(IGR,ICO))/beta_h(ib),ICO=IND1,LICZ(IGR))
+ IND1=1
+ ICON=list_conf(NCONF(IGR,1))
+c WRITE (iout,'(16F5.0)') (rad2deg*phiall(IND,icon),IND=4,nphi+3)
+C 12/8/93 Estimation of "diameters" of the subsequent families.
+ ave_dim=0.0
+ amax_dim=0.0
+c write (iout,*) "ecut",ecut
+ emin=totfree(nconf(igr,1))
+ do i=2,licz(igr)
+ ii=nconf(igr,i)
+ if (totfree(ii)-emin .gt. ecut) goto 10
+ do j=1,i-1
+ jj=nconf(igr,j)
+ if (jj.eq.1) exit
+ if (ii.lt.jj) then
+ ind=ioffset(ncon,ii,jj)
+ else
+ ind=ioffset(ncon,jj,ii)
+ endif
+c write (iout,*) " ncon",ncon,"i",i," j",j," ii",ii," jj",jj,
+c & " ind",ind," diss",diss(ind)
+c call flush(iout)
+ curr_dist=dabs(diss(ind)+0.0d0)
+c write(iout,'(i10,4i4,f12.4)') ind,ii,jj,list_conf(ii),
+c & list_conf(jj),curr_dist
+ if (curr_dist .gt. amax_dim) amax_dim=curr_dist
+ ave_dim=ave_dim+curr_dist**2
+ enddo
+ enddo
+ 10 if (licz(igr) .gt. 1)
+ & ave_dim=sqrt(ave_dim/(licz(igr)*(licz(igr)-1)/2))
+ write (iout,'(/A,F8.1,A,F8.1)')
+ & 'Max. distance in the family:',amax_dim,
+ & '; average distance in the family:',ave_dim
+ rmsave(igr)=0.0d0
+ gdt_ts_ave(igr)=0.0d0
+ gdt_ha_ave(igr)=0.0d0
+ tmscore_ave(igr)=0.0d0
+ qpart=0.0d0
+ e1=totfree(nconf(igr,1))
+ do i=1,licz(igr)
+ icon=nconf(igr,i)
+ boltz=dexp(-(totfree(icon)-e1))
+ rmsave(igr)=rmsave(igr)+boltz*rmstb(icon)
+ gdt_ts_ave(igr)=gdt_ts_ave(igr)+boltz*gdt_ts_tb(icon)
+ gdt_ha_ave(igr)=gdt_ha_ave(igr)+boltz*gdt_ha_tb(icon)
+ tmscore_ave(igr)=tmscore_ave(igr)+boltz*tmscore_tb(icon)
+ qpart=qpart+boltz
+c write (iout,'(2i5,10f10.5)') i,icon,boltz,rmstb(icon),
+c & gdt_ts_tb(icon),gdt_ha_tb(icon),tmscore_tb(icon)
+ enddo
+c write (iout,*) "qpart",qpart
+ rmsave(igr)=rmsave(igr)/qpart
+ gdt_ts_ave(igr)=gdt_ts_ave(igr)/qpart
+ gdt_ha_ave(igr)=gdt_ha_ave(igr)/qpart
+ tmscore_ave(igr)=tmscore_ave(igr)/qpart
+ write (iout,'(a,f5.2,a,3(a,f7.4))') "Cluster averages: RMSD",
+ & rmsave(igr)," A, ",
+ & "TMscore",tmscore_ave(igr),
+ & ", GDT_TS",gdt_ts_ave(igr),", GDT_HA",
+ & gdt_ha_ave(igr)
+ 19 CONTINUE
+ WRITE (iout,400)
+ WRITE (iout,500) (list_conf(I),IASS(I),I=1,NCON)
+c print *,icut,printang(icut)
+ IF (PRINTANG(ICUT) .and. (lprint_cart .or. lprint_int)) then
+ emin=totfree_gr(1)
+c print *,'emin',emin,' ngr',ngr
+ if (lprint_cart) then
+ cfname=prefixp(:ilen(prefixp))//"_T"//ctemper(:ilen(ctemper))
+ & //"K"//".x"
+ else
+ cfname=prefixp(:ilen(prefixp))//"_T"//ctemper(:ilen(ctemper))
+ & //"K"//".int"
+ endif
+ do igr=1,ngr
+ icon=nconf(igr,1)
+ if (totfree_gr(igr)-emin.le.ecut) then
+ if (lprint_cart) then
+ call cartout(igr,icon,totfree(icon)/beta_h(ib),
+ & totfree_gr(igr)/beta_h(ib),
+ & rmstb(icon),cfname)
+ else
+c print '(a)','calling briefout'
+ do i=1,2*nres
+ do j=1,3
+ c(j,i)=allcart(j,i,icon)
+ enddo
+ enddo
+ call int_from_cart1(.false.)
+ call briefout(igr,iscore(icon),totfree(icon)/beta_h(ib),
+ & totfree_gr(igr),nss_all(icon),ihpb_all(1,icon),
+ & jhpb_all(1,icon),cfname)
+c print '(a)','exit briefout'
+ endif
+ endif
+ enddo
+ close(igeom)
+ ENDIF
+ IF (PRINTPDB(ICUT).gt.0) THEN
+c Write out a number of conformations from each family in PDB format and
+c create InsightII command file for their displaying in different colors
+ cfname=prefixp(:ilen(prefixp))//"_T"//ctemper(:ilen(ctemper))
+ & //"K_"//'ave'//exten
+ write (iout,*) "cfname",cfname
+ OPEN(ipdb,FILE=CFNAME,STATUS='UNKNOWN',FORM='FORMATTED')
+ write (ipdb,'(a,f8.2)')
+ & "REMAR AVERAGE CONFORMATIONS AT TEMPERATURE",temper
+ close (ipdb)
+ I=1
+ ICON=NCONF(1,1)
+ EMIN=totfree_gr(I)
+ emin1=totfree(icon)
+ DO WHILE(I.LE.NGR .AND. totfree_gr(i)-EMIN.LE.ECUT)
+c write (iout,*) "i",i," ngr",ngr,totfree_gr(I),EMIN,ecut
+ write (NUMM,'(bz,i4.4)') i
+ ncon_lim=min0(licz(i),printpdb(icut))
+ cfname=prefixp(:ilen(prefixp))//"_T"//ctemper(:ilen(ctemper))
+ & //"K_"//numm(:ilen(numm))//exten
+ OPEN(ipdb,FILE=CFNAME,STATUS='UNKNOWN',FORM='FORMATTED')
+ write (ipdb,'("REMARK CLUSTER",i5," FREE ENERGY",1pe14.5,
+ & " AVE RMSD",0pf5.2)')
+ & i,totfree_gr(i)/beta_h(ib),rmsave(i)
+c Write conformations of the family i to PDB files
+ ncon_out=1
+ do while (ncon_out.lt.printpdb(icut) .and.
+ & ncon_out.lt.licz(i).and.
+ & totfree(nconf(i,ncon_out+1))-EMIN1.LE.ECUT)
+ ncon_out=ncon_out+1
+c write (iout,*) i,ncon_out,nconf(i,ncon_out),
+c & totfree(nconf(i,ncon_out)),emin1,ecut
+ enddo
+c write (iout,*) "ncon_out",ncon_out
+ call flush(iout)
+ do j=1,nres
+ tempfac(1,j)=5.0d0
+ tempfac(2,j)=5.0d0
+ enddo
+ do j=1,ncon_out
+ icon=nconf(i,j)
+ do ii=1,2*nres
+ do k=1,3
+ c(k,ii)=allcart(k,ii,icon)
+ enddo
+ enddo
+ call center
+ call pdbout(totfree(icon)/beta_h(ib),rmstb(icon),titel)
+ write (ipdb,'("TER")')
+ enddo
+ close(ipdb)
+c Average structures and structures closest to average
+ cfname=prefixp(:ilen(prefixp))//"_T"//ctemper(:ilen(ctemper))
+ & //"K_"//'ave'//exten
+ OPEN(ipdb,FILE=CFNAME,STATUS='UNKNOWN',FORM='FORMATTED',
+ & position="APPEND")
+ call ave_coord(i)
+ write (ipdb,'(a,i5)') "REMARK CLUSTER",i
+ call center
+ call pdbout(totfree_gr(i)/beta_h(ib),rmsave(i),titel)
+ write (ipdb,'("TER")')
+ if (print_fittest.and.(nsaxs.gt.0 .or. nhpb.gt.0
+ & .or.npeak.gt.0)) then
+ call fittest_coord(i)
+ else
+ call closest_coord(i)
+ endif
+c write (iout,*) "Calling rmsnat"
+ rms_closest(i) = rmsnat(i)
+
+ write (iout,*) "Cluster",i
+ call TMscore_sub(rmsd,gdt_ts_closest(i),gdt_ha_closest(i),
+ & tmscore_closest(i),cfname,.true.)
+c write (iout,*) "WRTCLUST: nsaxs",nsaxs," i",i
+ if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
+ call e_saxs(Esaxs_constr)
+ Cnorm=0.0d0
+ do j=1,nsaxs-1
+ Cnorm=Cnorm+(distsaxs(j+1)-distsaxs(j))*
+ & (Pcalc(j+1)+Pcalc(j))/2
+ enddo
+ do j=1,nsaxs
+ Pcalc_all(j,i)=Pcalc(j)/Cnorm
+ enddo
+c write (iout,*) "Pcalc"
+c write (iout,'(f6.2,f10.5)') (distsaxs(j),Pcalc(j),j=1,nsaxs)
+ Esaxs_all(i)=Esaxs_constr
+ write (iout,*) "Esaxs",Esaxs_constr
+ endif
+ nviolxlink=0
+ if (link_start.gt.0) then
+ do j=link_start,link_end
+ if (irestr_type(j).eq.10 .or. irestr_type(j).eq. 11) then
+ dxlink=dist(ihpb(j),jhpb(j))
+ if (dxlink.le.25.0d0) then
+ write (iout,'(a,i2,2i5,f8.2)') "XLINK-",
+ & irestr_type(j),ihpb(j),jhpb(j),
+ & dxlink
+ else
+ nviolxlink=nviolxlink+1
+ write (iout,'(a,i2,2i5,f8.2,2h *)') "XLINK-",
+ & irestr_type(j),ihpb(j),jhpb(j),
+ & dxlink
+ endif
+ endif
+ enddo
+ if (nviolxlink.gt.0)
+ & write (iout,*) nviolxlink," crosslink violations."
+c write (iout,*) "Family",i," rmsd",rmsd,"gdt_ts",
+c & gdt_ts_closest(i)," gdt_ha",gdt_ha_closest(i),
+c & "tmscore",tmscore_closest(i)
+ endif
+c Determine # violated NMR restraints
+ if (link_end_peak.gt.0) then
+ nviolpeak=0
+ write (NUMM,'(bz,i4.4)') i
+ cfname=prefixp(:ilen(prefixp))//"_T"//ctemper(:ilen(ctemper))
+ & //"K_"//NUMM(:ilen(NUMM))//'.nmr'
+ open(jrms,file=cfname)
+ do j=link_start_peak,link_end_peak
+ viol_nmr=.true.
+ do ip=ipeak(1,j),ipeak(2,j)
+ ii=ihpb_peak(ip)
+ jj=jhpb_peak(ip)
+ dd=dist(ii,jj)
+c iip=ip-ipeak(1,j)+1
+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
+ iiib=1
+ else
+ iii=ii
+ jjj=jj
+ iiib=0
+ endif
+ if (dd.lt.dhpb1_peak(ip)) then
+ viol_nmr=.false.
+c write (iout,*) j,iii,jjj,iiib
+ write (jrms,'(4i6)') j,iii,jjj,iiib
+ endif
+ enddo
+ if (viol_nmr) then
+ nviolpeak=nviolpeak+1
+ list_peak_viol(nviolpeak)=j
+ endif
+ enddo
+ if (nviolpeak.gt.0) then
+ write (iout,'(a,i5,2h (f8.4,2h%))')
+ & "Number of violated NMR restraints:",
+ & nviolpeak,100*(nviolpeak+0.)/npeak
+ write (iout,'(a)')"List of violated restraints:"
+ write (iout,'(16i5)') (list_peak_viol(j),j=1,nviolpeak)
+ endif
+ close(jrms)
+ endif
+ if (.not.raw_psipred .and. idihconstr_end.gt.0) then
+ cfname=prefixp(:ilen(prefixp))//"_T"
+ & //ctemper(:ilen(ctemper))
+ & //"K_"//NUMM(:ilen(NUMM))//'.angle'
+ open(jrms,file=cfname)
+ call int_from_cart1(.false.)
+ nangviol=0
+ do j=idihconstr_start,idihconstr_end
+ itori=idih_constr(j)
+ phii=phi(itori)
+ difi=pinorm(phii-phi0(j))
+ if (difi.gt.drange(j) .or. difi.lt.-drange(j))
+ & nangviol=nangviol+1
+ write (jrms,'(i5,3f10.3)') itori,phii*rad2deg,
+ & phi0(j)*rad2deg,rad2deg*drange(j)
+ enddo
+ write (iout,'(a,i5)')"Number of angle-restraint violations:"
+ & ,nangviol
+ close(jrms)
+ endif
+ call center
+ call pdbout(totfree_gr(i)/beta_h(ib),rms_closest(i),titel)
+ write (ipdb,'("TER")')
+ close (ipdb)
+ I=I+1
+ ICON=NCONF(I,1)
+ emin1=totfree(icon)
+ ENDDO
+ ngr_print=i-1
+ if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
+ cfname=prefixp(:ilen(prefixp))//"_T"//ctemper(:ilen(ctemper))
+ & //"K_"//'ave'//'.dist'
+ OPEN(99,FILE=CFNAME,STATUS='UNKNOWN',FORM='FORMATTED')
+ write (99,'(5h# ,10f10.5)')
+ & (Esaxs_all(i)*wsaxs,i=1,ngr_print)
+ do j=1,nsaxs
+ write (99,'(f6.2,10f10.5)') distsaxs(j),
+ & (Pcalc_all(j,i),i=1,ngr_print)
+ enddo
+ close(99)
+ endif
+ ENDIF
+ IF (printmol2(icut).gt.0) THEN
+c Write out a number of conformations from each family in PDB format and
+c create InsightII command file for their displaying in different colors
+ I=1
+ ICON=NCONF(1,1)
+ EMIN=ENERGY(ICON)
+ emin1=emin
+ DO WHILE(I.LE.NGR .AND. totfree_gr(i)-EMIN.LE.ECUT)
+ write (NUMM,'(bz,i4.4)') i
+ cfname=prefixp(:ilen(prefixp))//"_T"//ctemper(:ilen(ctemper))
+ & //"K_"//numm(:ilen(numm))//extmol
+ OPEN(imol2,FILE=CFNAME,STATUS='UNKNOWN',FORM='FORMATTED')
+ ncon_out=1
+ do while (ncon_out.lt.printmol2(icut) .and.
+ & ncon_out.lt.licz(i).and.
+ & totfree(nconf(i,ncon_out+1))-EMIN1.LE.ECUT)
+ ncon_out=ncon_out+1
+ enddo
+ do j=1,ncon_out
+ icon=nconf(i,j)
+ do ii=1,2*nres
+ do k=1,3
+ c(k,ii)=allcart(k,ii,icon)
+ enddo
+ enddo
+ CALL MOL2OUT(totfree(icon)/beta_h(ib),'STRUCTURE'//numm)
+ enddo
+ CLOSE(imol2)
+ I=I+1
+ ICON=NCONF(I,1)
+ emin1=totfree(icon)
+ ENDDO
+ ENDIF
+ call WRITE_STATS(ICUT,NCON,IB)
+ 100 FORMAT (//'THERE ARE ',I4,' FAMILIES OF CONFORMATIONS')
+ 200 FORMAT (/'FAMILY ',I4,' WITH TOTAL FREE ENERGY',1pE15.5,
+ & ' CONTAINS ',I4,' CONFORMATION(S): ')
+c 300 FORMAT ( 8(I4,F6.1))
+ 300 FORMAT (5(I4,1pe12.3))
+ 400 FORMAT (//'ASSIGNMENT OF CONSECUTIVE CONFORMATIONS TO FAMILIES:')
+ 500 FORMAT (8(2I4,2X))
+ 600 FORMAT ('REMARK FAMILY',I4,' CONFORMATION',I4,' ENERGY ',E15.6)
+ RETURN
+ END
+c------------------------------------------------------------------------------
+ subroutine ave_coord(igr)
+ implicit none
+ include 'DIMENSIONS'
+ include 'sizesclu.dat'
+ include 'COMMON.CONTROL'
+ include 'COMMON.CLUSTER'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.VAR'
+ include 'COMMON.TEMPFAC'
+ include 'COMMON.IOUNITS'
+ logical non_conv
+ double precision przes(3),obrot(3,3)
+ double precision xx(3,maxres2),csq(3,maxres2)
+ double precision eref
+ double precision rmscalc
+c double precision rmscheck
+ integer i,ii,j,k,icon,jcon,igr,ipermmin
+ double precision rms,boltz,qpart,cwork(3,maxres2),cref1(3,maxres2)
+c write (iout,*) "AVE_COORD: igr",igr
+ jcon=nconf(igr,1)
+ eref=totfree(jcon)
+ boltz = dexp(-totfree(jcon)+eref)
+ qpart=boltz
+ do i=1,2*nres
+ do j=1,3
+ c(j,i)=allcart(j,i,jcon)*boltz
+ cref1(j,i)=allcart(j,i,jcon)
+ csq(j,i)=allcart(j,i,jcon)**2*boltz
+ enddo
+ enddo
+ DO K=2,LICZ(IGR)
+ jcon=nconf(igr,k)
+c write (iout,*) "k",k," jcon",jcon
+ do i=1,2*nres
+ do j=1,3
+ cwork(j,i)=allcart(j,i,jcon)
+ enddo
+ enddo
+ rms=rmscalc(cwork(1,1),cref1(1,1),przes,obrot,ipermmin)
+c write (iout,*) "rms",rms," ipermmin",ipermmin
+c do i=1,3
+c write (iout,'(i3,f10.5,5x,3f10.5)')i,przes(i),
+c & (obrot(i,j),j=1,3)
+c enddo
+c if (rms.lt.0.0) then
+c print *,'error, rms^2 = ',rms,icon,jcon
+c stop
+c endif
+c if (non_conv) print *,non_conv,icon,jcon
+ boltz=dexp(-totfree(jcon)+eref)
+ qpart = qpart + boltz
+ do i=1,2*nres
+ do j=1,3
+ xx(j,i)=allcart(j,i,jcon)
+ enddo
+ enddo
+ call matvec(cwork,obrot,xx,2*nres)
+ do i=1,2*nres
+c write (iout,'(i5,2(3f10.5,5x))') i,(cwork(j,i),j=1,3),
+c & (allcart(j,i,jcon),j=1,3)
+ do j=1,3
+ cwork(j,i)=cwork(j,i)+przes(j)
+ c(j,i)=c(j,i)+cwork(j,i)*boltz
+ csq(j,i)=csq(j,i)+cwork(j,i)**2*boltz
+ enddo
+ enddo
+c rms check
+c rmscheck=0.0d0
+c do i=nnt,nct
+c do j=1,3
+c rmscheck=rmscheck+(cwork(j,i)-cref1(j,i))**2
+c enddo
+c enddo
+c write (iout,*) "rmscheck",dsqrt(rmscheck/(nct-nnt+1)),rms
+ ENDDO ! K
+ do i=1,2*nres
+ do j=1,3
+ c(j,i)=c(j,i)/qpart
+ csq(j,i)=csq(j,i)/qpart-c(j,i)**2
+ enddo
+c write (iout,'(i5,3f10.5)') i,(csq(j,i),j=1,3)
+ enddo
+ do i=nnt,nct
+ tempfac(1,i)=0.0d0
+ tempfac(2,i)=0.0d0
+ do j=1,3
+ tempfac(1,i)=tempfac(1,i)+csq(j,i)
+ tempfac(2,i)=tempfac(2,i)+csq(j,i+nres)
+ enddo
+ tempfac(1,i)=dsqrt(tempfac(1,i))
+ tempfac(2,i)=dsqrt(tempfac(2,i))
+ enddo
+ return
+ end
+c------------------------------------------------------------------------------
+ subroutine fittest_coord(igr)
+ implicit none
+ include 'DIMENSIONS'
+ include 'sizesclu.dat'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.CLUSTER'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.VAR'
+ include 'COMMON.FFIELD'
+ include 'COMMON.TORCNSTR'
+ include 'COMMON.SAXS'
+ logical non_conv
+ double precision przes(3),obrot(3,3)
+ double precision xx(3,maxres2),yy(3,maxres2)
+ integer i,ii,j,k,icon,jcon,jconmin,igr
+ double precision rms,rmsmin,cwork(3,maxres2)
+ double precision ehpb,Esaxs_constr,edihcnstr
+ rmsmin=1.0d10
+ jconmin=nconf(igr,1)
+ DO K=1,LICZ(IGR)
+ jcon=nconf(igr,k)
+ do i=1,2*nres
+ do j=1,3
+ c(j,i)=allcart(j,i,jcon)
+ enddo
+ enddo
+ call int_from_cart1(.false.)
+ esaxs_constr=0
+ ehpb=0
+ edihcnstr=0
+ if (nsaxs.gt.0) call e_saxs(Esaxs_constr)
+ call edis(ehpb)
+ if (ndih_constr.gt.0) call etor_constr(edihcnstr)
+ rms=wsaxs*esaxs_constr+wstrain*ehpb+edihcnstr
+c write (iout,*) "Esaxs_constr",esaxs_constr," Ehpb",ehpb,
+c & " Edihcnstr",edihcnstr
+ if (rms.lt.rmsmin) then
+ jconmin=nconf(igr,k)
+ rmsmin=rms
+ endif
+ ENDDO ! K
+ write (iout,*) "fittest conformation",jconmin," penalty",rmsmin
+ do i=1,2*nres
+ do j=1,3
+ c(j,i)=allcart(j,i,jconmin)
+ enddo
+ enddo
+ return
+ end
+c------------------------------------------------------------------------------
+ subroutine closest_coord(igr)
+ implicit none
+ include 'DIMENSIONS'
+ include 'sizesclu.dat'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.CLUSTER'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.VAR'
+ logical non_conv
+ double precision przes(3),obrot(3,3)
+ integer i,ii,j,k,icon,jcon,jconmin,igr,ipermmin
+ double precision rms,rmsmin,cwork(3,maxres2)
+ double precision xx(3,maxres2),yy(3,maxres2)
+ double precision rmscalc
+ rmsmin=1.0d10
+ jconmin=nconf(igr,1)
+ DO K=1,LICZ(IGR)
+ jcon=nconf(igr,k)
+ do i=1,2*nres
+ do j=1,3
+ xx(j,i)=c(j,i)
+ yy(j,i)=allcart(j,i,jcon)
+ enddo
+ enddo
+ rms=rmscalc(xx(1,1),yy(1,1),przes,obrot,ipermmin)
+c write (iout,*) "jcon",jcon," rms",rms," rmsmin",rmsmin
+ if (non_conv) print *,non_conv,icon,jcon
+ if (rms.lt.rmsmin) then
+ rmsmin=rms
+ jconmin=jcon
+ endif
+ ENDDO ! K
+c write (iout,*) "rmsmin",rmsmin," rms",rms
+c call flush(iout)
+ do i=1,2*nres
+ do j=1,3
+ c(j,i)=allcart(j,i,jconmin)
+ enddo
+ enddo
+ return
+ end
+c------------------------------------------------------------------------------
+ subroutine center
+ implicit none
+ include 'DIMENSIONS'
+ include 'sizesclu.dat'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.CLUSTER'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.VAR'
+ double precision przes(3)
+ integer i,ii,j,k,icon,jcon,jconmin,igr
+ przes=0.0d0
+ do j=1,3
+ do i=1,nres
+ przes(j)=przes(j)+c(j,i)
+ enddo
+ enddo
+ do j=1,3
+ przes(j)=przes(j)/nres
+ enddo
+ do i=1,2*nres
+ do j=1,3
+ c(j,i)=c(j,i)-przes(j)
+ enddo
+ enddo
+ return
+ end
--- /dev/null
+../../../lib/xdrf
\ No newline at end of file
projects / unres.git / commitdiff