From: Cezary Czaplewski Date: Sat, 14 Mar 2020 21:05:20 +0000 (+0100) Subject: ctest cluster wham X-Git-Tag: v.3.3.0~5^2~134 X-Git-Url: http://mmka.chem.univ.gda.pl/gitweb/?a=commitdiff_plain;ds=inline;h=9e7b4842e178ffd4545928c7fff1989630d6936c;p=unres.git ctest cluster wham --- diff --git a/CMakeLists.txt b/CMakeLists.txt index bc36b17..0363881 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -186,6 +186,7 @@ if(UNRES_WITH_MPI) # 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) diff --git a/ctest/1L2Y_clust.inp b/ctest/1L2Y_clust.inp index a08fcb8..3c3e198 100644 --- a/ctest/1L2Y_clust.inp +++ b/ctest/1L2Y_clust.inp @@ -1,5 +1,5 @@ 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 & diff --git a/source/cluster/wham/src-M-SAXS-homology/CMakeLists.txt b/source/cluster/wham/src-M-SAXS-homology/CMakeLists.txt new file mode 100644 index 0000000..a021b68 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/CMakeLists.txt @@ -0,0 +1,385 @@ +# +# 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") + diff --git a/source/cluster/wham/src-M-SAXS-homology/COMMON.CHAIN b/source/cluster/wham/src-M-SAXS-homology/COMMON.CHAIN new file mode 100644 index 0000000..9de64dd --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/COMMON.CHAIN @@ -0,0 +1,21 @@ + 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) diff --git a/source/cluster/wham/src-M-SAXS-homology/COMMON.CLUSTER b/source/cluster/wham/src-M-SAXS-homology/COMMON.CLUSTER new file mode 100644 index 0000000..46dbf75 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/COMMON.CLUSTER @@ -0,0 +1,23 @@ + 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/COMMON.CONTACTS.org b/source/cluster/wham/src-M-SAXS-homology/COMMON.CONTACTS.org new file mode 100644 index 0000000..1487839 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/COMMON.CONTACTS.org @@ -0,0 +1,73 @@ +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 diff --git a/source/cluster/wham/src-M-SAXS-homology/COMMON.CONTROL b/source/cluster/wham/src-M-SAXS-homology/COMMON.CONTROL new file mode 100644 index 0000000..cd8d0fe --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/COMMON.CONTROL @@ -0,0 +1,16 @@ + 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/COMMON.DFA b/source/cluster/wham/src-M-SAXS-homology/COMMON.DFA new file mode 100644 index 0000000..c6add4f --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/COMMON.DFA @@ -0,0 +1,101 @@ +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/ diff --git a/source/cluster/wham/src-M-SAXS-homology/COMMON.FFIELD b/source/cluster/wham/src-M-SAXS-homology/COMMON.FFIELD new file mode 100644 index 0000000..aab43b9 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/COMMON.FFIELD @@ -0,0 +1,32 @@ +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------------------------------------------------------------------------ diff --git a/source/cluster/wham/src-M-SAXS-homology/COMMON.FREE b/source/cluster/wham/src-M-SAXS-homology/COMMON.FREE new file mode 100644 index 0000000..7e86fe7 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/COMMON.FREE @@ -0,0 +1,3 @@ + integer nT + double precision beta_h(maxT),prob_limit + common /free/ beta_h,prob_limit,nT diff --git a/source/cluster/wham/src-M-SAXS-homology/COMMON.GEO b/source/cluster/wham/src-M-SAXS-homology/COMMON.GEO new file mode 100644 index 0000000..8cfbbde --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/COMMON.GEO @@ -0,0 +1,2 @@ + double precision pi,dwapi,pipol,pi3,dwapi3,deg2rad,rad2deg,angmin + common /geo/ pi,dwapi,pipol,pi3,dwapi3,deg2rad,rad2deg,angmin diff --git a/source/cluster/wham/src-M-SAXS-homology/COMMON.HEADER b/source/cluster/wham/src-M-SAXS-homology/COMMON.HEADER new file mode 100644 index 0000000..7154812 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/COMMON.HEADER @@ -0,0 +1,2 @@ + character*80 titel + common /header/ titel diff --git a/source/cluster/wham/src-M-SAXS-homology/COMMON.HOMOLOGY b/source/cluster/wham/src-M-SAXS-homology/COMMON.HOMOLOGY new file mode 100644 index 0000000..e2a7754 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/COMMON.HOMOLOGY @@ -0,0 +1,8 @@ + 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) diff --git a/source/cluster/wham/src-M-SAXS-homology/COMMON.HOMRESTR b/source/cluster/wham/src-M-SAXS-homology/COMMON.HOMRESTR new file mode 100644 index 0000000..95ea932 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/COMMON.HOMRESTR @@ -0,0 +1,39 @@ + 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/COMMON.IOUNITS b/source/cluster/wham/src-M-SAXS-homology/COMMON.IOUNITS new file mode 100644 index 0000000..d171ae0 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/COMMON.IOUNITS @@ -0,0 +1,63 @@ +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----------------------------------------------------------------------- diff --git a/source/cluster/wham/src-M-SAXS-homology/COMMON.LANGEVIN b/source/cluster/wham/src-M-SAXS-homology/COMMON.LANGEVIN new file mode 100644 index 0000000..982bde9 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/COMMON.LANGEVIN @@ -0,0 +1,8 @@ + 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/COMMON.MCM b/source/cluster/wham/src-M-SAXS-homology/COMMON.MCM new file mode 100644 index 0000000..576f912 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/COMMON.MCM @@ -0,0 +1,70 @@ +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). diff --git a/source/cluster/wham/src-M-SAXS-homology/COMMON.MINIM b/source/cluster/wham/src-M-SAXS-homology/COMMON.MINIM new file mode 100644 index 0000000..b231b47 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/COMMON.MINIM @@ -0,0 +1,3 @@ + double precision tolf,rtolf + integer maxfun,maxmin + common /minimm/ tolf,rtolf,maxfun,maxmin diff --git a/source/cluster/wham/src-M-SAXS-homology/COMMON.MPI b/source/cluster/wham/src-M-SAXS-homology/COMMON.MPI new file mode 100644 index 0000000..d2e7c00 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/COMMON.MPI @@ -0,0 +1,8 @@ + 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) diff --git a/source/cluster/wham/src-M-SAXS-homology/COMMON.NAMES b/source/cluster/wham/src-M-SAXS-homology/COMMON.NAMES new file mode 100644 index 0000000..7c5b6ee --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/COMMON.NAMES @@ -0,0 +1,7 @@ + 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) diff --git a/source/cluster/wham/src-M-SAXS-homology/COMMON.SAXS b/source/cluster/wham/src-M-SAXS-homology/COMMON.SAXS new file mode 100644 index 0000000..b787fa7 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/COMMON.SAXS @@ -0,0 +1,7 @@ +! 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 + diff --git a/source/cluster/wham/src-M-SAXS-homology/COMMON.SBRIDGE b/source/cluster/wham/src-M-SAXS-homology/COMMON.SBRIDGE new file mode 100644 index 0000000..ab78ed3 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/COMMON.SBRIDGE @@ -0,0 +1,29 @@ + 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) diff --git a/source/cluster/wham/src-M-SAXS-homology/COMMON.SCCOR b/source/cluster/wham/src-M-SAXS-homology/COMMON.SCCOR new file mode 100644 index 0000000..c38cccb --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/COMMON.SCCOR @@ -0,0 +1,19 @@ +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) diff --git a/source/cluster/wham/src-M-SAXS-homology/COMMON.SCROT b/source/cluster/wham/src-M-SAXS-homology/COMMON.SCROT new file mode 100644 index 0000000..a352775 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/COMMON.SCROT @@ -0,0 +1,3 @@ +C Parameters of the SC rotamers (local) term + double precision sc_parmin + common/scrot/sc_parmin(maxsccoef,ntyp) diff --git a/source/cluster/wham/src-M-SAXS-homology/COMMON.SHIELD b/source/cluster/wham/src-M-SAXS-homology/COMMON.SHIELD new file mode 100644 index 0000000..1f96c94 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/COMMON.SHIELD @@ -0,0 +1,14 @@ + 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) + + + diff --git a/source/cluster/wham/src-M-SAXS-homology/COMMON.TEMPFAC b/source/cluster/wham/src-M-SAXS-homology/COMMON.TEMPFAC new file mode 100644 index 0000000..a778a4c --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/COMMON.TEMPFAC @@ -0,0 +1,2 @@ + double precision tempfac(2,maxres) + common /factemp/ tempfac diff --git a/source/cluster/wham/src-M-SAXS-homology/COMMON.THREAD b/source/cluster/wham/src-M-SAXS-homology/COMMON.THREAD new file mode 100644 index 0000000..4020e75 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/COMMON.THREAD @@ -0,0 +1,7 @@ + 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/COMMON.TIME1 b/source/cluster/wham/src-M-SAXS-homology/COMMON.TIME1 new file mode 100644 index 0000000..b6e9c88 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/COMMON.TIME1 @@ -0,0 +1,4 @@ + DOUBLE PRECISION BATIME,TIMLIM,STIME,PREVTIM,SAFETY + INTEGER ISTOP + COMMON/TIME1/STIME,TIMLIM,BATIME,PREVTIM,SAFETY + COMMON/STOPTIM/ISTOP diff --git a/source/cluster/wham/src-M-SAXS-homology/COMMON.TORSION.org b/source/cluster/wham/src-M-SAXS-homology/COMMON.TORSION.org new file mode 100644 index 0000000..4da8585 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/COMMON.TORSION.org @@ -0,0 +1,35 @@ +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) diff --git a/source/cluster/wham/src-M-SAXS-homology/COMMON.VAR b/source/cluster/wham/src-M-SAXS-homology/COMMON.VAR new file mode 100644 index 0000000..072f773 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/COMMON.VAR @@ -0,0 +1,17 @@ +C Store the geometric variables in the following COMMON block. + integer ntheta,nphi,nside,nvar,ialph,ivar + double precision theta,phi,alph,omeg,vbld,vbld_ref, + & theta_ref,phi_ref,alph_ref,omeg_ref, + & costtab,sinttab,cost2tab,sint2tab,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) diff --git a/source/cluster/wham/src-M-SAXS-homology/DIMENSIONS b/source/cluster/wham/src-M-SAXS-homology/DIMENSIONS new file mode 100644 index 0000000..80ac845 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/DIMENSIONS @@ -0,0 +1,87 @@ +******************************************************************************** +* 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) diff --git a/source/cluster/wham/src-M-SAXS-homology/DIMENSIONS.COMPAR b/source/cluster/wham/src-M-SAXS-homology/DIMENSIONS.COMPAR new file mode 100644 index 0000000..08e2231 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/DIMENSIONS.COMPAR @@ -0,0 +1,20 @@ +****************************************************************** +* +* 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) +* +******************************************************************* diff --git a/source/cluster/wham/src-M-SAXS-homology/Makefile b/source/cluster/wham/src-M-SAXS-homology/Makefile new file mode 120000 index 0000000..8aee570 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/Makefile @@ -0,0 +1 @@ +Makefile-MPICH-ifort-okeanos \ No newline at end of file diff --git a/source/cluster/wham/src-M-SAXS-homology/Makefile-MPICH-gfortran b/source/cluster/wham/src-M-SAXS-homology/Makefile-MPICH-gfortran new file mode 100644 index 0000000..630299e --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/Makefile-MPICH-gfortran @@ -0,0 +1,76 @@ +################################################################## +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 + + diff --git a/source/cluster/wham/src-M-SAXS-homology/Makefile-MPICH-ifort b/source/cluster/wham/src-M-SAXS-homology/Makefile-MPICH-ifort new file mode 100644 index 0000000..79b8d0f --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/Makefile-MPICH-ifort @@ -0,0 +1,73 @@ +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 + + diff --git a/source/cluster/wham/src-M-SAXS-homology/Makefile-MPICH-ifort-okeanos b/source/cluster/wham/src-M-SAXS-homology/Makefile-MPICH-ifort-okeanos new file mode 100644 index 0000000..182e4ed --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/Makefile-MPICH-ifort-okeanos @@ -0,0 +1,96 @@ +#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 + + diff --git a/source/cluster/wham/src-M-SAXS-homology/Makefile-MPICH-ifort-prometheus b/source/cluster/wham/src-M-SAXS-homology/Makefile-MPICH-ifort-prometheus new file mode 100644 index 0000000..1492755 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/Makefile-MPICH-ifort-prometheus @@ -0,0 +1,77 @@ +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 + + diff --git a/source/cluster/wham/src-M-SAXS-homology/Makefile-okeanos b/source/cluster/wham/src-M-SAXS-homology/Makefile-okeanos new file mode 100644 index 0000000..ffb3dd5 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/Makefile-okeanos @@ -0,0 +1,71 @@ +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 + + diff --git a/source/cluster/wham/src-M-SAXS-homology/TMscore.F b/source/cluster/wham/src-M-SAXS-homology/TMscore.F new file mode 100644 index 0000000..2d7d441 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/TMscore.F @@ -0,0 +1,1095 @@ +************************************************************************* +* 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 +#include +#include +#include +#include + +main() +{ +FILE *in, *in1, *out; +int i,j,k,iv1,iv2,iv3; +char *p1,buf[500],buf1[500],buf2[100],buf3[100]; +struct utsname Name; +time_t Tp; + +in=fopen("cinfo.f","r"); +out=fopen("cinfo.f.new","w"); +if (fgets(buf,498,in) != NULL) + fprintf(out,"C DO NOT EDIT THIS FILE - IT HAS BEEN GENERATED BY COMPINFO.C\n"); +if (fgets(buf,498,in) != NULL) + sscanf(&buf[1],"%d %d %d",&iv1,&iv2,&iv3); +iv3++; +fprintf(out,"C %d %d %d\n",iv1,iv2,iv3); +fprintf(out," subroutine cinfo\n"); +fprintf(out," include 'COMMON.IOUNITS'\n"); +fprintf(out," write(iout,*)'++++ Compile info ++++'\n"); +fprintf(out," write(iout,*)'Version %d.%-d build %d'\n",iv1,iv2,iv3); +uname(&Name); +time(&Tp); +system("whoami > tmptmp"); +in1=fopen("tmptmp","r"); +if (fscanf(in1,"%s",buf1) != EOF) +{ +p1=ctime(&Tp); +p1[strlen(p1)-1]='\0'; +fprintf(out," write(iout,*)'compiled %s'\n",p1); +fprintf(out," write(iout,*)'compiled by %s@%s'\n",buf1,Name.nodename); +fprintf(out," write(iout,*)'OS name: %s '\n",Name.sysname); +fprintf(out," write(iout,*)'OS release: %s '\n",Name.release); +fprintf(out," write(iout,*)'OS version:',\n"); +fprintf(out," & ' %s '\n",Name.version); +fprintf(out," write(iout,*)'flags:'\n"); +} +system("rm tmptmp"); +fclose(in1); +in1=fopen("Makefile","r"); +while(fgets(buf,498,in1) != NULL) + { + if((p1=strchr(buf,'=')) != NULL && buf[0] != '#') + { + buf[strlen(buf)-1]='\0'; + if(strlen(buf) > 49) + { + buf[47]='\0'; + strcat(buf,"..."); + } + else + { + while(buf[strlen(buf)-1]=='\\') + { + strcat(buf,"\\"); + fprintf(out," write(iout,*)'%s'\n",buf); + if (fgets(buf,498,in1) != NULL) + buf[strlen(buf)-1]='\0'; + if(strlen(buf) > 49) + { + buf[47]='\0'; + strcat(buf,"..."); + } + } + } + + fprintf(out," write(iout,*)'%s'\n",buf); + } + } +fprintf(out," write(iout,*)'++++ End of compile info ++++'\n"); +fprintf(out," return\n"); +fprintf(out," end\n"); +fclose(out); +fclose(in1); +fclose(in); +system("mv cinfo.f.new cinfo.f"); +} diff --git a/source/cluster/wham/src-M-SAXS-homology/contact.f b/source/cluster/wham/src-M-SAXS-homology/contact.f new file mode 100644 index 0000000..6f01564 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/contact.f @@ -0,0 +1,69 @@ + 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/convert.f b/source/cluster/wham/src-M-SAXS-homology/convert.f new file mode 100644 index 0000000..b53032a --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/convert.f @@ -0,0 +1,59 @@ + 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/dfa.F b/source/cluster/wham/src-M-SAXS-homology/dfa.F new file mode 100644 index 0000000..c85191a --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/dfa.F @@ -0,0 +1,3548 @@ + 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=============================================================================== diff --git a/source/cluster/wham/src-M-SAXS-homology/energy_p_new.F b/source/cluster/wham/src-M-SAXS-homology/energy_p_new.F new file mode 100644 index 0000000..f599f70 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/energy_p_new.F @@ -0,0 +1,10602 @@ + 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 (ri' + do k=1,3 + ggg(k)=-ggg(k) +C Uncomment following line for SC-p interactions +c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) + enddo + endif + do k=1,3 + gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) + enddo + kstart=min0(i+1,j) + kend=max0(i-1,j-1) +cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend +cd write (iout,*) ggg(1),ggg(2),ggg(3) + do k=kstart,kend + do l=1,3 + gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) + enddo + enddo + endif ! 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/energy_p_new.F.safe b/source/cluster/wham/src-M-SAXS-homology/energy_p_new.F.safe new file mode 100644 index 0000000..a71e55b --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/energy_p_new.F.safe @@ -0,0 +1,9056 @@ + 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 (ri' + do k=1,3 + ggg(k)=-ggg(k) +C Uncomment following line for SC-p interactions +c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) + enddo + endif + do k=1,3 + gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) + enddo + kstart=min0(i+1,j) + kend=max0(i-1,j-1) +cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend +cd write (iout,*) ggg(1),ggg(2),ggg(3) + do k=kstart,kend + do l=1,3 + gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) + enddo + enddo + endif + enddo + enddo ! iint + 1225 continue + enddo ! i + do i=1,nct + do j=1,3 + gvdwc_scp(j,i)=expon*gvdwc_scp(j,i) + gradx_scp(j,i)=expon*gradx_scp(j,i) + enddo + enddo +C****************************************************************************** +C +C N O T E !!! +C +C To save time the factor EXPON has been extracted from ALL components +C of GVDWC and GRADX. Remember to multiply them by this factor before further +C use! +C +C****************************************************************************** + return + end +C-------------------------------------------------------------------------- + subroutine edis(ehpb) +C +C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include '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------------------------------------------------------------------------------------- diff --git a/source/cluster/wham/src-M-SAXS-homology/fitsq.f b/source/cluster/wham/src-M-SAXS-homology/fitsq.f new file mode 100644 index 0000000..17d92ee --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/fitsq.f @@ -0,0 +1,352 @@ + subroutine fitsq(rms,x,y,nn,t,b,non_conv) + implicit real*8 (a-h,o-z) + include 'COMMON.IOUNITS' +c x and y are the vectors of coordinates (dimensioned (3,n)) of the two +c structures to be superimposed. nn is 3*n, where n is the number of +c points. t and b are respectively the translation vector and the +c rotation matrix that transforms the second set of coordinates to the +c frame of the first set. +c eta = machine-specific variable + + dimension x(3*nn),y(3*nn),t(3) + dimension b(3,3),q(3,3),r(3,3),v(3),xav(3),yav(3),e(3),c(3,3) + logical non_conv + eta = z00100000 +c small=25.0*rmdcon(3) +c small=25.0*eta +c small=25.0*10.e-10 +c the following is a very lenient value for 'small' + small = 0.0001D0 + non_conv=.false. + fn=nn + do 10 i=1,3 + xav(i)=0.0D0 + yav(i)=0.0D0 + do 10 j=1,3 + 10 b(j,i)=0.0D0 + nc=0 +c + do 30 n=1,nn + do 20 i=1,3 +crc write(iout,*)'x = ',x(nc+i),' y = ',y(nc+i) + xav(i)=xav(i)+x(nc+i)/fn + 20 yav(i)=yav(i)+y(nc+i)/fn + 30 nc=nc+3 +c + do i=1,3 + t(i)=yav(i)-xav(i) + enddo + + rms=0.0d0 + do n=1,nn + do i=1,3 + rms=rms+(y(3*(n-1)+i)-x(3*(n-1)+i)-t(i))**2 + enddo + enddo + rms=dabs(rms/fn) + +c write(iout,*)'xav = ',(xav(j),j=1,3) +c write(iout,*)'yav = ',(yav(j),j=1,3) +c write(iout,*)'t = ',(t(j),j=1,3) +c write(iout,*)'rms=',rms + if (rms.lt.small) return + + + nc=0 + rms=0.0D0 + do 50 n=1,nn + do 40 i=1,3 + rms=rms+((x(nc+i)-xav(i))**2+(y(nc+i)-yav(i))**2)/fn + do 40 j=1,3 + b(j,i)=b(j,i)+(x(nc+i)-xav(i))*(y(nc+j)-yav(j))/fn + 40 c(j,i)=b(j,i) + 50 nc=nc+3 + call sivade(b,q,r,d,non_conv) + sn3=dsign(1.0d0,d) + do 120 i=1,3 + do 120 j=1,3 + 120 b(j,i)=-q(j,1)*r(i,1)-q(j,2)*r(i,2)-sn3*q(j,3)*r(i,3) + call mvvad(b,xav,yav,t) + do 130 i=1,3 + do 130 j=1,3 + rms=rms+2.0*c(j,i)*b(j,i) + 130 b(j,i)=-b(j,i) + if (dabs(rms).gt.small) go to 140 +* write (6,301) + return + 140 if (rms.gt.0.0d0) go to 150 +c write (iout,303) rms + rms=0.0d0 +* stop +c 150 write (iout,302) dsqrt(rms) + 150 continue + return + 301 format (5x,'rms deviation negligible') + 302 format (5x,'rms deviation ',f14.6) + 303 format (//,5x,'negative ms deviation - ',f14.6) + end + subroutine sivade(x,q,r,dt,non_conv) + implicit real*8(a-h,o-z) +c computes q,e and r such that q(t)xr = diag(e) + dimension x(3,3),q(3,3),r(3,3),e(3) + dimension h(3,3),p(3,3),u(3,3),d(3) + logical non_conv + eta = z00100000 + nit = 0 + small=25.0*10.e-10 +c small=25.0*eta +c small=2.0*rmdcon(3) + xnrm=0.0d0 + do 20 i=1,3 + do 10 j=1,3 + xnrm=xnrm+x(j,i)*x(j,i) + u(j,i)=0.0d0 + r(j,i)=0.0d0 + 10 h(j,i)=0.0d0 + u(i,i)=1.0 + 20 r(i,i)=1.0 + xnrm=dsqrt(xnrm) + do 110 n=1,2 + xmax=0.0d0 + do 30 j=n,3 + 30 if (dabs(x(j,n)).gt.xmax) xmax=dabs(x(j,n)) + a=0.0d0 + do 40 j=n,3 + h(j,n)=x(j,n)/xmax + 40 a=a+h(j,n)*h(j,n) + a=dsqrt(a) + den=a*(a+dabs(h(n,n))) + d(n)=1.0/den + h(n,n)=h(n,n)+dsign(a,h(n,n)) + do 70 i=n,3 + s=0.0d0 + do 50 j=n,3 + 50 s=s+h(j,n)*x(j,i) + s=d(n)*s + do 60 j=n,3 + 60 x(j,i)=x(j,i)-s*h(j,n) + 70 continue + if (n.gt.1) go to 110 + xmax=dmax1(dabs(x(1,2)),dabs(x(1,3))) + h(2,3)=x(1,2)/xmax + h(3,3)=x(1,3)/xmax + a=dsqrt(h(2,3)*h(2,3)+h(3,3)*h(3,3)) + den=a*(a+dabs(h(2,3))) + d(3)=1.0/den + h(2,3)=h(2,3)+sign(a,h(2,3)) + do 100 i=1,3 + s=0.0d0 + do 80 j=2,3 + 80 s=s+h(j,3)*x(i,j) + s=d(3)*s + do 90 j=2,3 + 90 x(i,j)=x(i,j)-s*h(j,3) + 100 continue + 110 continue + do 130 i=1,3 + do 120 j=1,3 + 120 p(j,i)=-d(1)*h(j,1)*h(i,1) + 130 p(i,i)=1.0+p(i,i) + do 140 i=2,3 + do 140 j=2,3 + u(j,i)=u(j,i)-d(2)*h(j,2)*h(i,2) + 140 r(j,i)=r(j,i)-d(3)*h(j,3)*h(i,3) + call mmmul(p,u,q) + 150 np=1 + nq=1 + nit=nit+1 + if (nit.gt.10000) then + print '(a)','!!!! Over 10000 iterations in SIVADE!!!!!' + non_conv=.true. + return + endif + if (dabs(x(2,3)).gt.small*(dabs(x(2,2))+abs(x(3,3)))) go to 160 + x(2,3)=0.0d0 + nq=nq+1 + 160 if (dabs(x(1,2)).gt.small*(dabs(x(1,1))+dabs(x(2,2)))) go to 180 + x(1,2)=0.0d0 + if (x(2,3).ne.0.0d0) go to 170 + nq=nq+1 + go to 180 + 170 np=np+1 + 180 if (nq.eq.3) go to 310 + npq=4-np-nq + if (np.gt.npq) go to 230 + n0=0 + do 220 n=np,npq + nn=n+np-1 + if (dabs(x(nn,nn)).gt.small*xnrm) go to 220 + x(nn,nn)=0.0d0 + if (x(nn,nn+1).eq.0.0d0) go to 220 + n0=n0+1 + go to (190,210,220),nn + 190 do 200 j=2,3 + 200 call givns(x,q,1,j) + go to 220 + 210 call givns(x,q,2,3) + 220 continue + if (n0.ne.0) go to 150 + 230 nn=3-nq + a=x(nn,nn)*x(nn,nn) + if (nn.gt.1) a=a+x(nn-1,nn)*x(nn-1,nn) + b=x(nn+1,nn+1)*x(nn+1,nn+1)+x(nn,nn+1)*x(nn,nn+1) + c=x(nn,nn)*x(nn,nn+1) + dd=0.5*(a-b) + xn2=c*c + rt=b-xn2/(dd+sign(dsqrt(dd*dd+xn2),dd)) + y=x(np,np)*x(np,np)-rt + z=x(np,np)*x(np,np+1) + do 300 n=np,nn + if (dabs(y).lt.dabs(z)) go to 240 + t=z/y + c=1.0/dsqrt(1.0d0+t*t) + s=c*t + go to 250 + 240 t=y/z + s=1.0/dsqrt(1.0d0+t*t) + c=s*t + 250 do 260 j=1,3 + v=x(j,n) + w=x(j,n+1) + x(j,n)=c*v+s*w + x(j,n+1)=-s*v+c*w + a=r(j,n) + b=r(j,n+1) + r(j,n)=c*a+s*b + 260 r(j,n+1)=-s*a+c*b + y=x(n,n) + z=x(n+1,n) + if (dabs(y).lt.dabs(z)) go to 270 + t=z/y + c=1.0/dsqrt(1.0+t*t) + s=c*t + go to 280 + 270 t=y/z + s=1.0/dsqrt(1.0+t*t) + c=s*t + 280 do 290 j=1,3 + v=x(n,j) + w=x(n+1,j) + a=q(j,n) + b=q(j,n+1) + x(n,j)=c*v+s*w + x(n+1,j)=-s*v+c*w + q(j,n)=c*a+s*b + 290 q(j,n+1)=-s*a+c*b + if (n.ge.nn) go to 300 + y=x(n,n+1) + z=x(n,n+2) + 300 continue + go to 150 + 310 do 320 i=1,3 + 320 e(i)=x(i,i) + nit=0 + 330 n0=0 + nit=nit+1 + if (nit.gt.10000) then + print '(a)','!!!! Over 10000 iterations in SIVADE!!!!!' + non_conv=.true. + return + endif + do 360 i=1,3 + if (e(i).ge.0.0d0) go to 350 + e(i)=-e(i) + do 340 j=1,3 + 340 q(j,i)=-q(j,i) + 350 if (i.eq.1) go to 360 + if (dabs(e(i)).lt.dabs(e(i-1))) go to 360 + call switch(i,1,q,r,e) + n0=n0+1 + 360 continue + if (n0.ne.0) go to 330 + if (dabs(e(3)).gt.small*xnrm) go to 370 + e(3)=0.0d0 + if (dabs(e(2)).gt.small*xnrm) go to 370 + e(2)=0.0d0 + 370 dt=det(q(1,1),q(1,2),q(1,3))*det(r(1,1),r(1,2),r(1,3)) +* write (1,501) (e(i),i=1,3) + return + 501 format (/,5x,'singular values - ',3e15.5) + end + subroutine givns(a,b,m,n) + implicit real*8 (a-h,o-z) + dimension a(3,3),b(3,3) + if (dabs(a(m,n)).lt.dabs(a(n,n))) go to 10 + t=a(n,n)/a(m,n) + s=1.0/dsqrt(1.0+t*t) + c=s*t + go to 20 + 10 t=a(m,n)/a(n,n) + c=1.0/dsqrt(1.0+t*t) + s=c*t + 20 do 30 j=1,3 + v=a(m,j) + w=a(n,j) + x=b(j,m) + y=b(j,n) + a(m,j)=c*v-s*w + a(n,j)=s*v+c*w + b(j,m)=c*x-s*y + 30 b(j,n)=s*x+c*y + return + end + subroutine switch(n,m,u,v,d) + implicit real*8 (a-h,o-z) + dimension u(3,3),v(3,3),d(3) + do 10 i=1,3 + tem=u(i,n) + u(i,n)=u(i,n-1) + u(i,n-1)=tem + if (m.eq.0) go to 10 + tem=v(i,n) + v(i,n)=v(i,n-1) + v(i,n-1)=tem + 10 continue + tem=d(n) + d(n)=d(n-1) + d(n-1)=tem + return + end + subroutine mvvad(b,xav,yav,t) + implicit real*8 (a-h,o-z) + dimension b(3,3),xav(3),yav(3),t(3) +c dimension a(3,3),b(3),c(3),d(3) +c do 10 j=1,3 +c d(j)=c(j) +c do 10 i=1,3 +c 10 d(j)=d(j)+a(j,i)*b(i) + do 10 j=1,3 + t(j)=yav(j) + do 10 i=1,3 + 10 t(j)=t(j)+b(j,i)*xav(i) + return + end + double precision function det (a,b,c) + implicit real*8 (a-h,o-z) + dimension a(3),b(3),c(3) + det=a(1)*(b(2)*c(3)-b(3)*c(2))+a(2)*(b(3)*c(1)-b(1)*c(3)) + 1 +a(3)*(b(1)*c(2)-b(2)*c(1)) + return + end + subroutine mmmul(a,b,c) + implicit real*8 (a-h,o-z) + dimension a(3,3),b(3,3),c(3,3) + do 10 i=1,3 + do 10 j=1,3 + c(i,j)=0.0d0 + do 10 k=1,3 + 10 c(i,j)=c(i,j)+a(i,k)*b(k,j) + return + end + subroutine matvec(uvec,tmat,pvec,nback) + implicit real*8 (a-h,o-z) + real*8 tmat(3,3),uvec(3,nback), pvec(3,nback) +c + do 2 j=1,nback + do 1 i=1,3 + uvec(i,j) = 0.0d0 + do 1 k=1,3 + 1 uvec(i,j)=uvec(i,j)+tmat(i,k)*pvec(k,j) + 2 continue + return + end diff --git a/source/cluster/wham/src-M-SAXS-homology/geomout.F b/source/cluster/wham/src-M-SAXS-homology/geomout.F new file mode 100644 index 0000000..4ef656f --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/geomout.F @@ -0,0 +1,201 @@ + 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)') '@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)') '@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)') '@BOND' + do i=nnt,nct-1 + write (imol2,'(i5,2i6,i2)') i-nnt+1,i-nnt+1,i-nnt+2,1 + enddo + do i=1,nss + write (imol2,'(i5,2i6,i2)') nct-nnt+i,ihpb(i),jhpb(i),1 + enddo + write (imol2,'(a)') '@SUBSTRUCTURE' + do i=nnt,nct + write (liczba,'(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 diff --git a/source/cluster/wham/src-M-SAXS-homology/gnmr1.f b/source/cluster/wham/src-M-SAXS-homology/gnmr1.f new file mode 100644 index 0000000..2357e6d --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/gnmr1.f @@ -0,0 +1,74 @@ + 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 + diff --git a/source/cluster/wham/src-M-SAXS-homology/hc.f b/source/cluster/wham/src-M-SAXS-homology/hc.f new file mode 100644 index 0000000..3d514a7 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/hc.f @@ -0,0 +1,479 @@ +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 diff --git a/source/cluster/wham/src-M-SAXS-homology/icant.f b/source/cluster/wham/src-M-SAXS-homology/icant.f new file mode 100644 index 0000000..ef794da --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/icant.f @@ -0,0 +1,9 @@ + 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.CALC b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.CALC new file mode 100644 index 0000000..bf255c9 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.CALC @@ -0,0 +1,15 @@ + integer i,j,k,l + double precision erij,rij,xj,yj,zj,dxi,dyi,dzi,dxj,dyj,dzj, + & chi1,chi2,chi12,chip1,chip2,chip12,alf1,alf2,alf12,om1,om2,om12, + & om1om2,chiom1,chiom2,chiom12,chipom1,chipom2,chipom12,eps1, + & faceps1,faceps1_inv,eps1_om12,facsig,sigsq,sigsq_om1,sigsq_om2, + & sigsq_om12,facp,facp_inv,facp1,eps2rt,eps2rt_om1,eps2rt_om2, + & eps2rt_om12,eps3rt,eom1,eom2,eom12,evdwij,eps2der,eps3der,sigder, + & dsci_inv,dscj_inv,gg,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 diff --git a/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.CONTACTS b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.CONTACTS new file mode 100644 index 0000000..ecfc97d --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.CONTACTS @@ -0,0 +1,77 @@ +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 diff --git a/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.CONTACTS.safe b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.CONTACTS.safe new file mode 100644 index 0000000..d07a0f0 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.CONTACTS.safe @@ -0,0 +1,68 @@ +C Change 12/1/95 - common block CONTACTS1 included. + integer ncont,ncont_ref,icont,icont_ref,num_cont,jcont + double precision facont,gacont + common /contacts/ ncont,ncont_ref,icont(2,maxcont), + & icont_ref(2,maxcont) + common /contacts1/ facont(maxconts,maxres), + & gacont(3,maxconts,maxres), + & num_cont(maxres),jcont(maxconts,maxres) +C 12/26/95 - H-bonding contacts + common /contacts_hb/ + & gacontp_hb1(3,maxconts,maxres),gacontp_hb2(3,maxconts,maxres), + & gacontp_hb3(3,maxconts,maxres), + & gacontm_hb1(3,maxconts,maxres),gacontm_hb2(3,maxconts,maxres), + & gacontm_hb3(3,maxconts,maxres), + & gacont_hbr(3,maxconts,maxres), + & grij_hb_cont(3,maxconts,maxres), + & facont_hb(maxconts,maxres),ees0p(maxconts,maxres), + & ees0m(maxconts,maxres),d_cont(maxconts,maxres), + & num_cont_hb(maxres),jcont_hb(maxconts,maxres) +C 9/23/99 Added improper rotation matrices and matrices of dipole-dipole +C interactions +C Interactions of pseudo-dipoles generated by loc-el interactions. + double precision dip,dipderg,dipderx + common /dipint/ dip(4,maxconts,maxres),dipderg(4,maxconts,maxres), + & dipderx(3,5,4,maxconts,maxres) +C 10/30/99 Added other pre-computed vectors and matrices needed +C to calculate three - six-order el-loc correlation terms + double precision Ug,Ugder,Ug2,Ug2der,obrot,obrot2,obrot_der, + & obrot2_der,Ub2,Ub2der,mu,muder,EUg,EUgder,CUg,CUgder, + & DUg,DUgder,DtUg2,DtUg2der,Ctobr,Ctobrder,Dtobr2,Dtobr2der + common /rotat/ Ug(2,2,maxres),Ugder(2,2,maxres),Ug2(2,2,maxres), + & Ug2der(2,2,maxres),obrot(2,maxres),obrot2(2,maxres), + & obrot_der(2,maxres),obrot2_der(2,maxres) +C This common block contains vectors and matrices dependent on a single +C amino-acid residue. + common /precomp1/ Ub2(2,maxres),Ub2der(2,maxres),mu(2,maxres), + & EUg(2,2,maxres),EUgder(2,2,maxres),CUg(2,2,maxres), + & CUgder(2,2,maxres),DUg(2,2,maxres),Dugder(2,2,maxres), + & DtUg2(2,2,maxres),DtUg2der(2,2,maxres),Ctobr(2,maxres), + & Ctobrder(2,maxres),Dtobr2(2,maxres),Dtobr2der(2,maxres) +C This common block contains vectors and matrices dependent on two +C consecutive amino-acid residues. + double precision Ug2Db1t,Ug2Db1tder,CUgb2,CUgb2der,EUgC, + & EUgCder,EUgD,EUgDder,DtUg2EUg,DtUg2EUgder + common /precomp2/ Ug2Db1t(2,maxres),Ug2Db1tder(2,maxres), + & CUgb2(2,maxres),CUgb2der(2,maxres),EUgC(2,2,maxres), + & EUgCder(2,2,maxres),EUgD(2,2,maxres),EUgDder(2,2,maxres), + & DtUg2EUg(2,2,maxres),DtUg2EUgder(2,2,2,maxres), + & Ug2DtEUg(2,2,maxres),Ug2DtEUgder(2,2,2,maxres) + double precision costab,sintab,costab2,sintab2 + common /rotat_old/ costab(maxres),sintab(maxres), + & costab2(maxres),sintab2(maxres),muder(2,maxres) +C This common block contains dipole-interaction matrices and their +C Cartesian derivatives. + double precision a_chuj,a_chuj_der + common /dipmat/ a_chuj(2,2,maxconts,maxres), + & a_chuj_der(2,2,3,5,maxconts,maxres) + double precision AEA,AEAderg,AEAderx,AECA,AECAderg,AECAderx, + & ADtEA,ADtEAderg,ADtEAderx,AEAb1,AEAb1derg,AEAb1derx, + & AEAb2,AEAb2derg,AEAb2derx + common /diploc/ AEA(2,2,2),AEAderg(2,2,2),AEAderx(2,2,3,5,2,2), + & EAEA(2,2,2), EAEAderg(2,2,2,2), EAEAderx(2,2,3,5,2,2), + & AECA(2,2,2),AECAderg(2,2,2),AECAderx(2,2,3,5,2,2), + & ADtEA(2,2,2),ADtEAderg(2,2,2,2),ADtEAderx(2,2,3,5,2,2), + & ADtEA1(2,2,2),ADtEA1derg(2,2,2,2),ADtEA1derx(2,2,3,5,2,2), + & AEAb1(2,2,2),AEAb1derg(2,2,2),AEAb1derx(2,3,5,2,2,2), + & AEAb2(2,2,2),AEAb2derg(2,2,2,2),AEAb2derx(2,3,5,2,2,2), + & g_contij(3,2),ekont diff --git a/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.CONTPAR b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.CONTPAR new file mode 100644 index 0000000..97a73eb --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.CONTPAR @@ -0,0 +1,3 @@ + double precision sig_comp,chi_comp,chip_comp,sc_cutoff + common /contpar/ sig_comp(ntyp,ntyp),chi_comp(ntyp,ntyp), + & chip_comp(ntyp,ntyp),sc_cutoff(ntyp,ntyp) diff --git a/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.DERIV b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.DERIV new file mode 100644 index 0000000..f1f5db5 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.DERIV @@ -0,0 +1,69 @@ + 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.DERIV.org b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.DERIV.org new file mode 100644 index 0000000..79f8630 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.DERIV.org @@ -0,0 +1,30 @@ + double precision dcdv,dxdv,dxds,gradx,gradc,gvdwc,gelc,gvdwpp, + & gradx_scp,gvdwc_scp,ghpbx,ghpbc,gloc,gvdwx,gradcorr,gradxorr, + & gradcorr5,gradcorr6,gel_loc,gcorr3_turn,gcorr4_turn,gcorr6_turn, + & gel_loc_loc,gel_loc_turn3,gel_loc_turn4,gel_loc_turn6,gcorr_loc, + & g_corr5_loc,g_corr6_loc,gradb,gradbx,gsccorc,gsccorx,gsccor_loc, + & gscloc,gsclocx + integer nfl,icg + logical calc_grad + common /derivat/ dcdv(6,maxdim),dxdv(6,maxdim),dxds(6,maxres), + & gradx(3,maxres,2),gradc(3,maxres,2),gvdwx(3,maxres), + & gvdwc(3,maxres),gelc(3,maxres),gvdwpp(3,maxres), + & gradx_scp(3,maxres), + & gvdwc_scp(3,maxres),ghpbx(3,maxres),ghpbc(3,maxres), + & gloc(maxvar,2),gradcorr(3,maxres),gradxorr(3,maxres), + & gradcorr5(3,maxres),gradcorr6(3,maxres), + & gel_loc(3,maxres),gcorr3_turn(3,maxres),gcorr4_turn(3,maxres), + & gcorr6_turn(3,maxres),gradb(3,maxres),gradbx(3,maxres), + & gel_loc_loc(maxvar),gel_loc_turn3(maxvar),gel_loc_turn4(maxvar), + & gel_loc_turn6(maxvar),gcorr_loc(maxvar), + & g_corr5_loc(maxvar),g_corr6_loc(maxvar),gsccorc(3,maxres), + & gsccorx(3,maxres),gsccor_loc(maxres), + & gscloc(3,maxres),gsclocx(3,maxres),nfl,icg,calc_grad + double precision derx,derx_turn + common /deriv_loc/ derx(3,5,2),derx_turn(3,5,2) + double precision dXX_C1tab(3,maxres),dYY_C1tab(3,maxres), + & dZZ_C1tab(3,maxres),dXX_Ctab(3,maxres),dYY_Ctab(3,maxres), + & dZZ_Ctab(3,maxres),dXX_XYZtab(3,maxres),dYY_XYZtab(3,maxres), + & dZZ_XYZtab(3,maxres) + common /deriv_scloc/ dXX_C1tab,dYY_C1tab,dZZ_C1tab,dXX_Ctab, + & dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,dZZ_XYZtab diff --git a/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.FRAG b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.FRAG new file mode 100644 index 0000000..ee151f5 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.FRAG @@ -0,0 +1,5 @@ + integer nbfrag,bfrag,nhfrag,hfrag,bvar_frag,hvar_frag,nhpb0, + & nh310frag,h310frag + COMMON /c_frag/ nbfrag,bfrag(4,maxres/3),nhfrag,hfrag(2,maxres/3), + & nh310frag,h310frag(2,maxres/2) + COMMON /frag/ bvar_frag(mxio,6),hvar_frag(mxio,3) diff --git a/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.GEO b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.GEO new file mode 100644 index 0000000..8cfbbde --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.GEO @@ -0,0 +1,2 @@ + double precision pi,dwapi,pipol,pi3,dwapi3,deg2rad,rad2deg,angmin + common /geo/ pi,dwapi,pipol,pi3,dwapi3,deg2rad,rad2deg,angmin diff --git a/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.HEADER b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.HEADER new file mode 100644 index 0000000..7154812 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.HEADER @@ -0,0 +1,2 @@ + character*80 titel + common /header/ titel diff --git a/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.INTERACT b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.INTERACT new file mode 100644 index 0000000..1c0b8db --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.INTERACT @@ -0,0 +1,36 @@ + 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) + diff --git a/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.LOCAL b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.LOCAL new file mode 100644 index 0000000..6bd5514 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.LOCAL @@ -0,0 +1,53 @@ + 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) diff --git a/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.MINIM b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.MINIM new file mode 100644 index 0000000..b231b47 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.MINIM @@ -0,0 +1,3 @@ + double precision tolf,rtolf + integer maxfun,maxmin + common /minimm/ tolf,rtolf,maxfun,maxmin diff --git a/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.SCCOR b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.SCCOR new file mode 100644 index 0000000..fffe09b --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.SCCOR @@ -0,0 +1,6 @@ +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 diff --git a/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.SCROT b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.SCROT new file mode 100644 index 0000000..a352775 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.SCROT @@ -0,0 +1,3 @@ +C Parameters of the SC rotamers (local) term + double precision sc_parmin + common/scrot/sc_parmin(maxsccoef,ntyp) diff --git a/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.SETUP b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.SETUP new file mode 100644 index 0000000..5039116 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.SETUP @@ -0,0 +1,21 @@ + 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.SPLITELE b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.SPLITELE new file mode 100644 index 0000000..a2f0447 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.SPLITELE @@ -0,0 +1,2 @@ + double precision r_cut,rlamb + common /splitele/ r_cut,rlamb diff --git a/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.TIME1 b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.TIME1 new file mode 100644 index 0000000..f7f4849 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.TIME1 @@ -0,0 +1,13 @@ + DOUBLE PRECISION BATIME,TIMLIM,STIME,PREVTIM,SAFETY,RSTIME + INTEGER WhatsUp,ndelta + logical cutoffviol,cutoffeval,llocal + COMMON/TIME1/STIME,TIMLIM,BATIME,PREVTIM,SAFETY,RSTIME + COMMON/STOPTIM/WhatsUp,ndelta,cutoffviol,cutoffeval,llocal + double precision t_func,t_grad,t_fhel,t_fbet,t_ghel,t_gbet,t_viol, + & t_gviol,t_map,t_alamap,t_betamap + integer n_func,n_grad,n_fhel,n_fbet,n_ghel,n_gbet,n_viol,n_gviol, + & n_map,n_alamap,n_betamap + common /timing/ t_func,t_grad,t_fhel,t_fbet,t_ghel,t_gbet,t_viol, + & t_gviol,t_map,t_alamap,t_betamap, + & n_func,n_grad,n_fhel,n_fbet,n_ghel,n_gbet,n_viol,n_gviol, + & n_map,n_alamap,n_betamap diff --git a/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.TORCNSTR b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.TORCNSTR new file mode 100644 index 0000000..8958b81 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.TORCNSTR @@ -0,0 +1,17 @@ + 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.TORSION b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.TORSION new file mode 100644 index 0000000..cd576c8 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.TORSION @@ -0,0 +1,60 @@ +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 diff --git a/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.TORSION.org b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.TORSION.org new file mode 100644 index 0000000..55cc7f4 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.TORSION.org @@ -0,0 +1,25 @@ +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) diff --git a/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.VECTORS b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.VECTORS new file mode 100644 index 0000000..d880c24 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.VECTORS @@ -0,0 +1,3 @@ + common /vectors/ uy(3,maxres),uz(3,maxres), + & uygrad(3,3,2,maxres),uzgrad(3,3,2,maxres) + diff --git a/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.WEIGHTS b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.WEIGHTS new file mode 100644 index 0000000..86f8d7a --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/include_unres/COMMON.WEIGHTS @@ -0,0 +1,22 @@ + double precision ww,ww0,ww_low,ww_up,ww_orig,x_orig, + & epp_low,epp_up,rpp_low,rpp_up,elpp6_low,elpp6_up,elpp3_low, + & elpp3_up,b_low,b_up,epscp_low,epscp_up,rscp_low,rscp_up, + & x_up,x_low,xm,xm1,xm2,epss_low,epss_up,epsp_low,epsp_up + integer imask,mask_elec,mask_fourier,mod_fourier,mask_scp,indz,iw, + & nsingle_sc,npair_sc,ityp_ssc,ityp_psc + logical mod_other_params,mod_elec,mod_scp,mod_side + common /chujec/ ww(max_ene),ww0(max_ene),ww_low(max_ene), + & ww_up(max_ene),ww_orig(max_ene),x_orig(max_paropt), + & epp_low(2,2),epp_up(2,2),rpp_low(2,2),rpp_up(2,2), + & elpp6_low(2,2),elpp6_up(2,2),elpp3_low(2,2),elpp3_up(2,2), + & b_low(13,3),b_up(13,3),x_up(max_paropt),x_low(max_paropt), + & epscp_low(0: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) diff --git a/source/cluster/wham/src-M-SAXS-homology/initialize.f b/source/cluster/wham/src-M-SAXS-homology/initialize.f new file mode 100644 index 0000000..12ea156 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/initialize.f @@ -0,0 +1,99 @@ + 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/initialize.f_org b/source/cluster/wham/src-M-SAXS-homology/initialize.f_org new file mode 100644 index 0000000..751c20e --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/initialize.f_org @@ -0,0 +1,92 @@ + 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/initialize_p.F b/source/cluster/wham/src-M-SAXS-homology/initialize_p.F new file mode 100644 index 0000000..87e4dde --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/initialize_p.F @@ -0,0 +1,551 @@ + 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/int_from_cart1.f b/source/cluster/wham/src-M-SAXS-homology/int_from_cart1.f new file mode 100644 index 0000000..7d266de --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/int_from_cart1.f @@ -0,0 +1,63 @@ + 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/intcor.f b/source/cluster/wham/src-M-SAXS-homology/intcor.f new file mode 100644 index 0000000..a3cd5d0 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/intcor.f @@ -0,0 +1,91 @@ +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 diff --git a/source/cluster/wham/src-M-SAXS-homology/iperm.f b/source/cluster/wham/src-M-SAXS-homology/iperm.f new file mode 100644 index 0000000..77ba7ed --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/iperm.f @@ -0,0 +1,15 @@ + 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/log b/source/cluster/wham/src-M-SAXS-homology/log new file mode 100644 index 0000000..61146b3 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/log @@ -0,0 +1,24 @@ +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 diff --git a/source/cluster/wham/src-M-SAXS-homology/main_clust.F b/source/cluster/wham/src-M-SAXS-homology/main_clust.F new file mode 100644 index 0000000..2485ecb --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/main_clust.F @@ -0,0 +1,400 @@ +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 diff --git a/source/cluster/wham/src-M-SAXS-homology/matmult.f b/source/cluster/wham/src-M-SAXS-homology/matmult.f new file mode 100644 index 0000000..2d2450e --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/matmult.f @@ -0,0 +1,17 @@ + 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/misc.f b/source/cluster/wham/src-M-SAXS-homology/misc.f new file mode 100644 index 0000000..e189839 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/misc.f @@ -0,0 +1,203 @@ +C $Date: 1994/10/12 17:24:21 $ +C $Revision: 2.5 $ +C +C +C + logical function find_arg(ipos,line,errflag) + parameter (maxlen=80) + character*80 line + character*1 empty /' '/,equal /'='/ + logical errflag +* This function returns .TRUE., if an argument follows keyword keywd; if so +* IPOS will point to the first non-blank character of the argument. Returns +* .FALSE., if no argument follows the keyword; in this case IPOS points +* to the first non-blank character of the next keyword. + do while (line(ipos:ipos) .eq. empty .and. ipos.le.maxlen) + ipos=ipos+1 + enddo + errflag=.false. + if (line(ipos:ipos).eq.equal) then + find_arg=.true. + ipos=ipos+1 + do while (line(ipos:ipos) .eq. empty .and. ipos.le.maxlen) + ipos=ipos+1 + enddo + if (ipos.gt.maxlen) errflag=.true. + else + find_arg=.false. + endif + return + end + logical function find_group(iunit,jout,key1) + character*(*) key1 + character*80 karta,ucase + integer ilen + external ilen + logical lcom + rewind (iunit) + karta=' ' + ll=ilen(key1) + do while (index(ucase(karta),key1(1:ll)).eq.0.or.lcom(1,karta)) + read (iunit,'(a)',end=10) karta + enddo + write (jout,'(2a)') '> ',karta(1:78) + find_group=.true. + return + 10 find_group=.false. + return + end + logical function iblnk(charc) + character*1 charc + integer n + n = ichar(charc) + iblnk = (n.eq.9) .or. (n.eq.10) .or. (charc.eq. ' ') + return + end + integer function ilen(string) + character*(*) string + logical iblnk + + ilen = len(string) +1 if ( ilen .gt. 0 ) then + if ( iblnk( string(ilen:ilen) ) ) then + ilen = ilen - 1 + goto 1 + endif + endif + return + end + integer function in_keywd_set(nkey,ikey,narg,keywd,keywdset) + character*16 keywd,keywdset(1:nkey,0:nkey) + character*16 ucase + do i=1,narg + if (ucase(keywd).eq.keywdset(i,ikey)) then +* Match found + in_keywd_set=i + return + endif + enddo +* No match to the allowed set of keywords if this point is reached. + in_keywd_set=0 + return + end + character*(*) function lcase(string) + integer i, k, idiff + character*(*) string + character*1 c + character*40 chtmp +c + i = len(lcase) + k = len(string) + if (i .lt. k) then + k = i + if (string(k+1:) .ne. ' ') then + chtmp = string + endif + endif + idiff = ichar('a') - ichar('A') + lcase = string + do 99 i = 1, k + c = string(i:i) + if (lge(c,'A') .and. lle(c,'Z')) then + lcase(i:i) = char(ichar(c) + idiff) + endif + 99 continue + return + end + logical function lcom(ipos,karta) + character*80 karta + character koment(2) /'!','#'/ + lcom=.false. + do i=1,2 + if (karta(ipos:ipos).eq.koment(i)) lcom=.true. + enddo + return + end + logical function lower_case(ch) + character*(*) ch + lower_case=(ch.ge.'a' .and. ch.le.'z') + return + end + subroutine mykey(line,keywd,ipos,blankline,errflag) +* This subroutine seeks a non-empty substring keywd in the string LINE. +* The substring begins with the first character different from blank and +* "=" encountered right to the pointer IPOS (inclusively) and terminates +* at the character left to the first blank or "=". When the subroutine is +* exited, the pointer IPOS is moved to the position of the terminator in LINE. +* The logical variable BLANKLINE is set at .TRUE., if LINE(IPOS:) contains +* only separators or the maximum length of the data line (80) has been reached. +* The logical variable ERRFLAG is set at .TRUE. if the string +* consists only from a "=". + parameter (maxlen=80) + character*1 empty /' '/,equal /'='/,comma /','/ + character*(*) keywd + character*80 line + logical blankline,errflag,lcom + errflag=.false. + do while (line(ipos:ipos).eq.empty .and. (ipos.le.maxlen)) + ipos=ipos+1 + enddo + if (ipos.gt.maxlen .or. lcom(ipos,line) ) then +* At this point the rest of the input line turned out to contain only blanks +* or to be commented out. + blankline=.true. + return + endif + blankline=.false. + istart=ipos +* Checks whether the current char is a separator. + do while (line(ipos:ipos).ne.empty .and. line(ipos:ipos).ne.equal + & .and. line(ipos:ipos).ne.comma .and. ipos.le.maxlen) + ipos=ipos+1 + enddo + iend=ipos-1 +* Error flag set to .true., if the length of the keyword was found less than 1. + if (iend.lt.istart) then + errflag=.true. + return + endif + keywd=line(istart:iend) + return + end + subroutine numstr(inum,numm) + character*10 huj /'0123456789'/ + character*(*) numm + inumm=inum + inum1=inumm/10 + inum2=inumm-10*inum1 + inumm=inum1 + numm(3:3)=huj(inum2+1:inum2+1) + inum1=inumm/10 + inum2=inumm-10*inum1 + inumm=inum1 + numm(2:2)=huj(inum2+1:inum2+1) + inum1=inumm/10 + inum2=inumm-10*inum1 + inumm=inum1 + numm(1:1)=huj(inum2+1:inum2+1) + return + end + character*(*) function ucase(string) + integer i, k, idiff + character*(*) string + character*1 c + character*40 chtmp +c + i = len(ucase) + k = len(string) + if (i .lt. k) then + k = i + if (string(k+1:) .ne. ' ') then + chtmp = string + endif + endif + idiff = ichar('a') - ichar('A') + ucase = string + do 99 i = 1, k + c = string(i:i) + if (lge(c,'a') .and. lle(c,'z')) then + ucase(i:i) = char(ichar(c) - idiff) + endif + 99 continue + return + end diff --git a/source/cluster/wham/src-M-SAXS-homology/noyes.f b/source/cluster/wham/src-M-SAXS-homology/noyes.f new file mode 100644 index 0000000..4cf326c --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/noyes.f @@ -0,0 +1,16 @@ + 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 + diff --git a/source/cluster/wham/src-M-SAXS-homology/oligomer.f b/source/cluster/wham/src-M-SAXS-homology/oligomer.f new file mode 100644 index 0000000..122bce0 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/oligomer.f @@ -0,0 +1,86 @@ + 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/parmread.F b/source/cluster/wham/src-M-SAXS-homology/parmread.F new file mode 100644 index 0000000..8895504 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/parmread.F @@ -0,0 +1,1598 @@ + 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/permut.F b/source/cluster/wham/src-M-SAXS-homology/permut.F new file mode 100644 index 0000000..f81abd8 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/permut.F @@ -0,0 +1,61 @@ + 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/pinorm.f b/source/cluster/wham/src-M-SAXS-homology/pinorm.f new file mode 100644 index 0000000..91392bf --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/pinorm.f @@ -0,0 +1,17 @@ + double precision function pinorm(x) + implicit real*8 (a-h,o-z) +c +c this function takes an angle (in radians) and puts it in the range of +c -pi to +pi. +c + integer n + include 'COMMON.GEO' + n = x / dwapi + pinorm = x - n * dwapi + if ( pinorm .gt. pi ) then + pinorm = pinorm - dwapi + else if ( pinorm .lt. - pi ) then + pinorm = pinorm + dwapi + end if + return + end diff --git a/source/cluster/wham/src-M-SAXS-homology/printmat.f b/source/cluster/wham/src-M-SAXS-homology/printmat.f new file mode 100644 index 0000000..be2b38f --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/printmat.f @@ -0,0 +1,16 @@ + subroutine printmat(ldim,m,n,iout,key,a) + character*3 key(n) + double precision a(ldim,n) + do 1 i=1,n,8 + nlim=min0(i+7,n) + write (iout,1000) (key(k),k=i,nlim) + write (iout,1020) + 1000 format (/5x,8(6x,a3)) + 1020 format (/80(1h-)/) + do 2 j=1,n + write (iout,1010) key(j),(a(j,k),k=i,nlim) + 2 continue + 1 continue + 1010 format (a3,2x,8(f9.4)) + return + end diff --git a/source/cluster/wham/src-M-SAXS-homology/probabl.F b/source/cluster/wham/src-M-SAXS-homology/probabl.F new file mode 100644 index 0000000..a3a664b --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/probabl.F @@ -0,0 +1,302 @@ + 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/proc_proc.c b/source/cluster/wham/src-M-SAXS-homology/proc_proc.c new file mode 100644 index 0000000..f023520 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/proc_proc.c @@ -0,0 +1,140 @@ +#include +#include +#include + +#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 diff --git a/source/cluster/wham/src-M-SAXS-homology/read_constr_homology.F b/source/cluster/wham/src-M-SAXS-homology/read_constr_homology.F new file mode 100644 index 0000000..defd236 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/read_constr_homology.F @@ -0,0 +1,713 @@ + 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/read_coords.F b/source/cluster/wham/src-M-SAXS-homology/read_coords.F new file mode 100644 index 0000000..facbc27 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/read_coords.F @@ -0,0 +1,763 @@ + 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/read_ref_str.F b/source/cluster/wham/src-M-SAXS-homology/read_ref_str.F new file mode 100644 index 0000000..5a50119 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/read_ref_str.F @@ -0,0 +1,159 @@ + 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/readpdb.F b/source/cluster/wham/src-M-SAXS-homology/readpdb.F new file mode 100644 index 0000000..dc6aa0a --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/readpdb.F @@ -0,0 +1,751 @@ + 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 + + diff --git a/source/cluster/wham/src-M-SAXS-homology/readpdb.f.safe b/source/cluster/wham/src-M-SAXS-homology/readpdb.f.safe new file mode 100644 index 0000000..6f478b5 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/readpdb.f.safe @@ -0,0 +1,307 @@ + 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/readrtns.F b/source/cluster/wham/src-M-SAXS-homology/readrtns.F new file mode 100644 index 0000000..33ac81a --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/readrtns.F @@ -0,0 +1,1427 @@ + 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/refsys.f b/source/cluster/wham/src-M-SAXS-homology/refsys.f new file mode 100644 index 0000000..4b7b763 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/refsys.f @@ -0,0 +1,70 @@ + 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/rescode.f b/source/cluster/wham/src-M-SAXS-homology/rescode.f new file mode 100644 index 0000000..fb68350 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/rescode.f @@ -0,0 +1,31 @@ + 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 + diff --git a/source/cluster/wham/src-M-SAXS-homology/rmscalc.F b/source/cluster/wham/src-M-SAXS-homology/rmscalc.F new file mode 100644 index 0000000..a572ecd --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/rmscalc.F @@ -0,0 +1,209 @@ + 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/rmsnat.f b/source/cluster/wham/src-M-SAXS-homology/rmsnat.f new file mode 100644 index 0000000..b2718d6 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/rmsnat.f @@ -0,0 +1,48 @@ + 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/seq2chains.f b/source/cluster/wham/src-M-SAXS-homology/seq2chains.f new file mode 100644 index 0000000..cf38c87 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/seq2chains.f @@ -0,0 +1,56 @@ + 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/setup_var.f b/source/cluster/wham/src-M-SAXS-homology/setup_var.f new file mode 100644 index 0000000..6937fc2 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/setup_var.f @@ -0,0 +1,31 @@ + 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/sizesclu.dat b/source/cluster/wham/src-M-SAXS-homology/sizesclu.dat new file mode 100644 index 0000000..7d0d666 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/sizesclu.dat @@ -0,0 +1,37 @@ +****************************************************************** +* +* 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) +* +******************************************************************* diff --git a/source/cluster/wham/src-M-SAXS-homology/srtclust.f b/source/cluster/wham/src-M-SAXS-homology/srtclust.f new file mode 100644 index 0000000..5d8b064 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/srtclust.f @@ -0,0 +1,117 @@ + 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/ssMD.F b/source/cluster/wham/src-M-SAXS-homology/ssMD.F new file mode 100644 index 0000000..9c23fe0 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/ssMD.F @@ -0,0 +1,2178 @@ +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 diff --git a/source/cluster/wham/src-M-SAXS-homology/timing.F b/source/cluster/wham/src-M-SAXS-homology/timing.F new file mode 100644 index 0000000..b8bfdd4 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/timing.F @@ -0,0 +1,180 @@ +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 diff --git a/source/cluster/wham/src-M-SAXS-homology/track.F b/source/cluster/wham/src-M-SAXS-homology/track.F new file mode 100644 index 0000000..a8244e3 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/track.F @@ -0,0 +1,277 @@ + 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/work_partition.F b/source/cluster/wham/src-M-SAXS-homology/work_partition.F new file mode 100644 index 0000000..f29b01f --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/work_partition.F @@ -0,0 +1,86 @@ +#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 diff --git a/source/cluster/wham/src-M-SAXS-homology/wrtclust.f b/source/cluster/wham/src-M-SAXS-homology/wrtclust.f new file mode 100644 index 0000000..fa08111 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/wrtclust.f @@ -0,0 +1,646 @@ + 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 diff --git a/source/cluster/wham/src-M-SAXS-homology/xdrf b/source/cluster/wham/src-M-SAXS-homology/xdrf new file mode 120000 index 0000000..b320ac0 --- /dev/null +++ b/source/cluster/wham/src-M-SAXS-homology/xdrf @@ -0,0 +1 @@ +../../../lib/xdrf \ No newline at end of file