--- /dev/null
+#
+# CMake project file for UNRES with MD for single chains
+#
+
+enable_language (Fortran)
+
+
+#================================
+# Set source file lists
+#================================
+set(UNRES_MD_SRC0
+ add.f
+ arcos.f
+ banach.f
+ blas.f
+ bond_move.f
+ cartder.F
+ cartprint.f
+ check_sc_distr.f
+ check_bond.f
+ chainbuild.F
+ checkder_p.F
+ compare_s1.F
+ contact.f
+ convert.f
+ cored.f
+ dihed_cons.F
+ djacob.f
+ econstr_local.F
+ eigen.f
+ elecont.f
+ energy_split-sep.F
+ entmcm.F
+ fitsq.f
+ gauss.f
+ gen_rand_conf.F
+ geomout.F
+ gnmr1.f
+ intcartderiv.F
+ initialize_p.F
+ int_to_cart.f
+ intcor.f
+ intlocal.f
+ kinetic_lesyng.f
+ lagrangian_lesyng.F
+ local_move.f
+ map.f
+ matmult.f
+ mc.F
+ mcm.F
+ MD_A-MTS.F
+ minimize_p.F
+ minim_mcmf.F
+ misc.f
+ moments.f
+ MP.F
+ MREMD.F
+ muca_md.f
+ parmread.F
+ pinorm.f
+ printmat.f
+ q_measure.F
+ randgens.f
+ rattle.F
+ readpdb.F
+ readrtns.F
+ refsys.f
+ regularize.F
+ rescode.f
+ rmdd.f
+ rmsd.F
+ sc_move.F
+ sort.f
+ stochfric.F
+ sumsld.f
+ surfatom.f
+ test.F
+ timing.F
+ thread.F
+ unres.F
+)
+
+if(Fortran_COMPILER_NAME STREQUAL "ifort")
+ set(UNRES_MD_SRC0 ${UNRES_MD_SRC0} prng.f )
+else()
+ set(UNRES_MD_SRC0 ${UNRES_MD_SRC0} prng_32.F )
+endif (Fortran_COMPILER_NAME STREQUAL "ifort")
+
+
+set(UNRES_MD_SRC3
+ energy_p_new_barrier.F
+ energy_p_new-sep_barrier.F
+ gradient_p.F )
+
+set(UNRES_MD_PP_SRC
+ cartder.F
+ chainbuild.F
+ checkder_p.F
+ compare_s1.F
+ dihed_cons.F
+ econstr_local.F
+ energy_p_new_barrier.F
+ energy_p_new-sep_barrier.F
+ energy_split-sep.F
+ entmcm.F
+ gen_rand_conf.F
+ geomout.F
+ gradient_p.F
+ initialize_p.F
+ intcartderiv.F
+ lagrangian_lesyng.F
+ mc.F
+ mcm.F
+ MD_A-MTS.F
+ minimize_p.F
+ minim_mcmf.F
+ MP.F
+ MREMD.F
+ parmread.F
+ q_measure1.F
+ q_measure3.F
+ q_measure.F
+ rattle.F
+ readpdb.F
+ readrtns.F
+ regularize.F
+ rmsd.F
+ sc_move.F
+ stochfric.F
+ test.F
+ thread.F
+ timing.F
+ unres.F
+ proc_proc.c
+)
+
+
+if(NOT Fortran_COMPILER_NAME STREQUAL "ifort")
+ set(UNRES_MD_PP_SRC ${UNRES_MD_PP_SRC} prng_32.F)
+endif(NOT Fortran_COMPILER_NAME STREQUAL "ifort")
+
+#================================================
+# Set comipiler flags for different sourcefiles
+#================================================
+if (Fortran_COMPILER_NAME STREQUAL "ifort")
+ set(FFLAGS0 "-ip -w" )
+ set(FFLAGS1 "-w -g -d2 -CA -CB" )
+ set(FFLAGS2 "-w -g -00 ")
+ #set(FFLAGS3 "-c -w -O3 -ipo -ipo_obj -opt_report" )
+ set(FFLAGS3 "-w -ipo " )
+elseif (Fortran_COMPILER_NAME STREQUAL "gfortran")
+ set(FFLAGS0 "-I. " )
+ set(FFLAGS1 "-g -I. " )
+ set(FFLAGS2 "-I. ")
+ #set(FFLAGS3 "-c -w -O3 -ipo -ipo_obj -opt_report" )
+ set(FFLAGS3 "-I. " )
+endif (Fortran_COMPILER_NAME STREQUAL "ifort")
+
+
+# Add MPI compiler flags
+if(UNRES_WITH_MPI)
+ set(FFLAGS0 "${FFLAGS0} -I${MPIF_INCLUDE_DIRECTORIES}")
+ set(FFLAGS1 "${FFLAGS1} -I${MPIF_INCLUDE_DIRECTORIES}")
+ set(FFLAGS2 "${FFLAGS2} -I${MPIF_INCLUDE_DIRECTORIES}")
+ set(FFLAGS3 "${FFLAGS3} -I${MPIF_INCLUDE_DIRECTORIES}")
+endif(UNRES_WITH_MPI)
+
+set_property(SOURCE ${UNRES_MD_SRC0} APPEND PROPERTY COMPILE_FLAGS ${FFLAGS0} )
+#set_property(SOURCE ${UNRES_MD_SRC1} PROPERTY COMPILE_FLAGS ${FFLAGS1} )
+#set_property(SOURCE ${UNRES_MD_SRC2} PROPERTY COMPILE_FLAGS ${FFLAGS2} )
+set_property(SOURCE ${UNRES_MD_SRC3} PROPERTY COMPILE_FLAGS ${FFLAGS3} )
+
+#=========================================
+# Settings for GAB force field
+#=========================================
+if(UNRES_MD_FF STREQUAL "GAB" )
+ # set preprocesor flags
+ set(CPPFLAGS "PROCOR -DUNRES -DISNAN -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC" )
+
+#=========================================
+# Settings for E0LL2Y force field
+#=========================================
+elseif(UNRES_MD_FF STREQUAL "E0LL2Y")
+ # set preprocesor flags
+ set(CPPFLAGS "PROCOR -DUNRES -DISNAN -DSPLITELE -DLANG0" )
+endif(UNRES_MD_FF STREQUAL "GAB")
+
+#=========================================
+# System specific flags
+#=========================================
+if(${CMAKE_SYSTEM_NAME} MATCHES "Linux")
+ set(CPPFLAGS "${CPPFLAGS} -DLINUX")
+endif(${CMAKE_SYSTEM_NAME} MATCHES "Linux")
+
+#=========================================
+# Compiler specific flags
+#=========================================
+
+if (Fortran_COMPILER_NAME STREQUAL "ifort")
+ # Add ifort preprocessor flags
+ set(CPPFLAGS "${CPPFLAGS} -DPGI")
+elseif (Fortran_COMPILER_NAME STREQUAL "f95")
+ # Add new gfortran flags
+ set(CPPFLAGS "${CPPFLAGS} -DG77")
+elseif (Fortran_COMPILER_NAME STREQUAL "gfortran")
+ # Add old gfortran flags
+ set(CPPFLAGS "${CPPFLAGS} -DG77")
+endif (Fortran_COMPILER_NAME STREQUAL "ifort")
+
+#=========================================
+# Add MPI preprocessor flags
+#=========================================
+if (UNRES_WITH_MPI)
+ set(CPPFLAGS "${CPPFLAGS} -DMP -DMPI")
+endif(UNRES_WITH_MPI)
+
+#=========================================
+# Apply preprocesor flags to *.F files
+#=========================================
+set_property(SOURCE ${UNRES_MD_PP_SRC} PROPERTY COMPILE_DEFINITIONS ${CPPFLAGS} )
+
+
+#========================================
+# Setting binary name
+#========================================
+if(UNRES_WITH_MPI)
+ # binary with mpi
+ set(UNRES_BIN "unres_${Fortran_COMPILER_NAME}_MPICH_${UNRES_MD_FF}.exe")
+else(UNRES_WITH_MPI)
+ # binary without mpi
+ set(UNRES_BIN "unres_${Fortran_COMPILER_NAME}_single_${UNRES_MD_FF}.exe")
+endif(UNRES_WITH_MPI)
+
+#=========================================
+# 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 ")
+
+#FILE(APPEND ${CMAKE_CURRENT_BINARY_DIR}/cinfo.f
+# CINFO_FORMAT(CPPFLAGS)
+#)
+# add include path
+set_property(SOURCE ${CMAKE_CURRENT_BINARY_DIR}/cinfo.f PROPERTY COMPILE_FLAGS "${FFLAGS0} -I${CMAKE_CURRENT_SOURCE_DIR}")
+
+#=========================================
+# Set full unres MD sources
+#=========================================
+set(UNRES_MD_SRCS ${UNRES_MD_SRC0} ${UNRES_MD_SRC3} ${CMAKE_CURRENT_BINARY_DIR}/cinfo.f )
+
+
+#=========================================
+# Build the binary
+#=========================================
+add_executable(UNRES_BIN-MD ${UNRES_MD_SRCS} )
+set_target_properties(UNRES_BIN-MD PROPERTIES OUTPUT_NAME ${UNRES_BIN})
+#set_property(TARGET ${UNRES_BIN} PROPERTY RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/bin/unres/MD )
+#add_dependencies (${UNRES_BIN} ${UNRES_XDRFLIB})
+
+
+#=========================================
+# Link libraries
+#=========================================
+# link MPI library (libmpich.a)
+if(UNRES_WITH_MPI)
+ target_link_libraries( UNRES_BIN-MD ${MPIF_LIBRARIES} )
+endif(UNRES_WITH_MPI)
+# link libxdrf.a
+#message("UNRES_XDRFLIB=${UNRES_XDRFLIB}")
+target_link_libraries( UNRES_BIN-MD xdrf )
+
+#=========================================
+# TESTS
+#=========================================
+
+#-- Copy all the data files from the test directory into the source directory
+#SET(UNRES_TEST_FILES
+# ala10.inp
+# )
+
+#FOREACH (UNRES_TEST_FILE ${UNRES_TEST_FILES})
+# SET (unres_test_dest "${CMAKE_CURRENT_BINARY_DIR}/${UNRES_TEST_FILE}")
+# MESSAGE (STATUS " Copying ${UNRES_TEST_FILE} from ${CMAKE_SOURCE_DIR}/examples/unres/MD/ff_gab/${UNRES_TEST_FILE} to ${unres_test_dest}")
+# ADD_CUSTOM_COMMAND (
+# TARGET ${UNRES_BIN}
+# POST_BUILD
+# COMMAND ${CMAKE_COMMAND} -E copy ${CMAKE_SOURCE_DIR}/examples/unres/MD/ff_gab/${UNRES_TEST_FILE} ${unres_test_dest}
+# )
+#ENDFOREACH (UNRES_TEST_FILE ${UNRES_TEST_FILES})
+
+#=========================================
+# Generate data test files
+#=========================================
+# test_single_ala.sh
+#=========================================
+
+FILE(WRITE ${CMAKE_CURRENT_BINARY_DIR}/scripts/test_single_ala.sh
+"#!/bin/sh
+export POT=GB
+export PREFIX=ala10
+#-----------------------------------------------------------------------------
+UNRES_BIN=./${UNRES_BIN}
+#-----------------------------------------------------------------------------
+DD=${CMAKE_SOURCE_DIR}/PARAM
+export BONDPAR=$DD/bond.parm
+export THETPAR=$DD/thetaml.5parm
+export ROTPAR=$DD/scgauss.parm
+export TORPAR=$DD/torsion_631Gdp.parm
+export TORDPAR=$DD/torsion_double_631Gdp.parm
+export ELEPAR=$DD/electr_631Gdp.parm
+export SIDEPAR=$DD/sc_GB_opt.1gab_3S_qclass5no310-shan2-sc-16-10-8k
+export FOURIER=$DD/fourier_opt.parm.1igd_hc_iter3_3
+export SCPPAR=$DD/scp.parm
+export SCCORPAR=$DD/rotcorr_AM1.parm
+export PATTERN=$DD/patterns.cart
+#-----------------------------------------------------------------------------
+$UNRES_BIN
+")
+
+#
+# File permissions workaround
+#
+FILE( COPY ${CMAKE_CURRENT_BINARY_DIR}/scripts/test_single_ala.sh
+ DESTINATION ${CMAKE_CURRENT_BINARY_DIR}
+ FILE_PERMISSIONS OWNER_READ OWNER_WRITE OWNER_EXECUTE GROUP_READ GROUP_EXECUTE WORLD_READ WORLD_EXECUTE
+)
+
+
+
+#=========================================
+# ala10.inp
+#=========================================
+
+file(WRITE ${CMAKE_CURRENT_BINARY_DIR}/ala10.inp
+"ala10 unblocked
+SEED=-1111333 MD ONE_LETTER rescale_mode=2
+nstep=15000 ntwe=100 ntwx=1000 dt=0.1 lang=0 tbf t_bath=300 damax=1.0 &
+reset_moment=1000 reset_vel=1000
+WLONG=1.35279 WSCP=1.59304 WELEC=0.71534 WBOND=1.00000 WANG=1.13873 &
+WSCLOC=0.16258 WTOR=1.98599 WTORD=1.57069 WCORRH=0.42887 WCORR5=0.00000 &
+WCORR6=0.00000 WEL_LOC=0.16036 WTURN3=1.68722 WTURN4=0.66230 WTURN6=0.00000 &
+WVDWPP=0.11371 WHPB=1.00000 &
+CUTOFF=7.00000 WCORR4=0.00000
+12
+XAAAAAAAAAAX
+ 0
+ 0
+ 90.0000 90.0000 90.0000 90.000 90.000 90.000 90.000 90.000
+ 90.0000 90.0000
+ 180.0000 180.0000 180.0000 180.000 180.000 180.000 180.000 180.000
+ 180.0000
+ 110.0000 110.0000 110.0000 100.000 110.000 100.000 110.000 110.000
+ 110.0000 110.0000
+ -120.0000 -120.0000 -120.000 -120.000 -120.000 -120.000 -120.000 -120.000
+ -120.0000 -120.0000
+")
+
+
+# Add tests
+
+if(NOT UNRES_WITH_MPI)
+
+ add_test(NAME UNRES_MD_Ala10 COMMAND sh ${CMAKE_CURRENT_BINARY_DIR}/test_single_ala.sh )
+
+else(NOT UNRES_WITH_MPI)
+
+
+ add_test(NAME UNRES_MD_MPI_Ala10 COMMAND mpiexec -boot ${CMAKE_CURRENT_BINARY_DIR}/test_single_ala.sh )
+
+endif(NOT UNRES_WITH_MPI)
+
--- /dev/null
+ double precision phibound(2,maxres)
+ common /bounds/ phibound
--- /dev/null
+ integer ncache,CachSrc(max_cache),isent(max_cache),
+ & iused(max_cache)
+ logical cache_update
+ double precision ecache(max_cache),xcache(maxvar,max_cache)
+ common /cache/ ecache,xcache,ncache,CachSrc,isent,iused,
+ & cache_update
--- /dev/null
+ integer i,j,k,l
+ double precision erij,rij,xj,yj,zj,dxi,dyi,dzi,dxj,dyj,dzj,
+ & chi1,chi2,chi12,chip1,chip2,chip12,alf1,alf2,alf12,om1,om2,om12,
+ & om1om2,chiom1,chiom2,chiom12,chipom1,chipom2,chipom12,eps1,
+ & faceps1,faceps1_inv,eps1_om12,facsig,sigsq,sigsq_om1,sigsq_om2,
+ & sigsq_om12,facp,facp_inv,facp1,eps2rt,eps2rt_om1,eps2rt_om2,
+ & eps2rt_om12,eps3rt,eom1,eom2,eom12,evdwij,eps2der,eps3der,sigder,
+ & dsci_inv,dscj_inv,gg
+ common /calc/ erij(3),rij,xj,yj,zj,dxi,dyi,dzi,dxj,dyj,dzj,
+ & chi1,chi2,chi12,chip1,chip2,chip12,alf1,alf2,alf12,om1,om2,om12,
+ & om1om2,chiom1,chiom2,chiom12,chipom1,chipom2,chipom12,eps1,
+ & faceps1,faceps1_inv,eps1_om12,facsig,sigsq,sigsq_om1,sigsq_om2,
+ & sigsq_om12,facp,facp_inv,facp1,eps2rt,eps2rt_om1,eps2rt_om2,
+ & eps2rt_om12,eps3rt,eom1,eom2,eom12,evdwij,eps2der,eps3der,sigder,
+ & dsci_inv,dscj_inv,gg(3),i,j
--- /dev/null
+ integer nres,nsup,nstart_sup,nz_start,nz_end,iz_sc,
+ & nres0,nstart_seq
+ double precision c,dc,dc_old,d_c_work,xloc,xrot,dc_norm,t,r,
+ & prod,rt,dc_work,cref,crefjlee,dc_norm2
+ common /chain/ c(3,maxres2+2),dc(3,0:maxres2),dc_old(3,0:maxres2),
+ & xloc(3,maxres),xrot(3,maxres),dc_norm(3,0:maxres2),
+ & dc_norm2(3,0:maxres2),
+ & dc_work(MAXRES6),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),
+ & nsup,nstart_sup,nstart_seq
+ common /from_zscore/ nz_start,nz_end,iz_sc
--- /dev/null
+C Change 12/1/95 - common block CONTACTS1 included.
+ integer ncont,ncont_ref,icont,icont_ref,num_cont,jcont
+ double precision facont,gacont
+ common /contacts/ ncont,ncont_ref,icont(2,maxcont),
+ & icont_ref(2,maxcont)
+ common /contacts1/ facont(maxconts,maxres),
+ & gacont(3,maxconts,maxres),
+ & num_cont(maxres),jcont(maxconts,maxres)
+C 12/26/95 - H-bonding contacts
+ common /contacts_hb/
+ & gacontp_hb1(3,maxconts,maxres),gacontp_hb2(3,maxconts,maxres),
+ & gacontp_hb3(3,maxconts,maxres),
+ & gacontm_hb1(3,maxconts,maxres),gacontm_hb2(3,maxconts,maxres),
+ & gacontm_hb3(3,maxconts,maxres),
+ & gacont_hbr(3,maxconts,maxres),
+ & grij_hb_cont(3,maxconts,maxres),
+ & facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
+ & ees0m(maxconts,maxres),d_cont(maxconts,maxres),
+ & num_cont_hb(maxres),jcont_hb(maxconts,maxres)
+C 9/23/99 Added improper rotation matrices and matrices of dipole-dipole
+C interactions
+c 7/25/08 Commented out; not needed when cumulants used
+C Interactions of pseudo-dipoles generated by loc-el interactions.
+c double precision dip,dipderg,dipderx
+c common /dipint/ dip(4,maxconts,maxres),dipderg(4,maxconts,maxres),
+c & dipderx(3,5,4,maxconts,maxres)
+C 10/30/99 Added other pre-computed vectors and matrices needed
+C to calculate three - six-order el-loc correlation terms
+ double precision Ug,Ugder,Ug2,Ug2der,obrot,obrot2,obrot_der,
+ & obrot2_der,Ub2,Ub2der,mu,muder,EUg,EUgder,CUg,CUgder,
+ & 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/ mu(2,maxres),muder(2,maxres),Ub2(2,maxres),
+ & Ub2der(2,maxres),Ctobr(2,maxres),Ctobrder(2,maxres),
+ & Dtobr2(2,maxres),Dtobr2der(2,maxres),
+ & EUg(2,2,maxres),EUgder(2,2,maxres),CUg(2,2,maxres),
+ & CUgder(2,2,maxres),DUg(2,2,maxres),Dugder(2,2,maxres),
+ & DtUg2(2,2,maxres),DtUg2der(2,2,maxres)
+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),Ug2DtEUg(2,2,maxres),
+ & Ug2DtEUgder(2,2,2,maxres),DtUg2EUgder(2,2,2,maxres)
+ double precision costab,sintab,costab2,sintab2
+ common /rotat_old/ costab(maxres),sintab(maxres),
+ & costab2(maxres),sintab2(maxres)
+C This common block contains dipole-interaction matrices and their
+C Cartesian derivatives.
+ double precision a_chuj,a_chuj_der
+ common /dipmat/ a_chuj(2,2,maxconts,maxres),
+ & a_chuj_der(2,2,3,5,maxconts,maxres)
+ double precision AEA,AEAderg,AEAderx,AECA,AECAderg,AECAderx,
+ & ADtEA,ADtEAderg,ADtEAderx,AEAb1,AEAb1derg,AEAb1derx,
+ & AEAb2,AEAb2derg,AEAb2derx,g_contij,ekont
+ common /diploc/ AEA(2,2,2),AEAderg(2,2,2),AEAderx(2,2,3,5,2,2),
+ & EAEA(2,2,2), EAEAderg(2,2,2,2), EAEAderx(2,2,3,5,2,2),
+ & AECA(2,2,2),AECAderg(2,2,2),AECAderx(2,2,3,5,2,2),
+ & ADtEA(2,2,2),ADtEAderg(2,2,2,2),ADtEAderx(2,2,3,5,2,2),
+ & ADtEA1(2,2,2),ADtEA1derg(2,2,2,2),ADtEA1derx(2,2,3,5,2,2),
+ & AEAb1(2,2,2),AEAb1derg(2,2,2),AEAb1derx(2,3,5,2,2,2),
+ & AEAb2(2,2,2),AEAb2derg(2,2,2,2),AEAb2derx(2,3,5,2,2,2),
+ & g_contij(3,2),ekont
+C 12/13/2008 (again Poland-Jaruzel war anniversary)
+C RE: Parallelization of 4th and higher order loc-el correlations
+ integer ncont_sent,ncont_recv,iint_sent,iisent_local,
+ & itask_cont_from,itask_cont_to,ntask_cont_from,ntask_cont_to,
+ & nat_sent,iat_sent,iturn3_sent,iturn4_sent,iturn3_sent_local,
+ & iturn4_sent_local
+ common /contdistrib/ ncont_sent(maxres),ncont_recv(maxres),
+ & iint_sent(4,maxres,maxres),iint_sent_local(4,maxres,maxres),
+ & iturn3_sent(4,maxres),iturn4_sent(4,maxres),
+ & iturn3_sent_local(4,maxres),iturn4_sent_local(4,maxres),
+ & nat_sent,iat_sent(maxres),itask_cont_from(0:max_fg_procs-1),
+ & itask_cont_to(0:max_fg_procs-1),ntask_cont_from,ntask_cont_to
--- /dev/null
+C Change 12/1/95 - common block CONTACTS1 included.
+ integer ncont,ncont_ref,icont,icont_ref,num_cont,jcont
+ double precision facont,gacont
+ common /contacts/ ncont,ncont_ref,icont(2,maxcont),
+ & icont_ref(2,maxcont)
+ common /contacts1/ facont(maxconts,maxres),
+ & gacont(3,maxconts,maxres),
+ & num_cont(maxres),jcont(maxconts,maxres)
+C 12/26/95 - H-bonding contacts
+ common /contacts_hb/
+ & gacontp_hb1(3,maxconts,maxres),gacontp_hb2(3,maxconts,maxres),
+ & gacontp_hb3(3,maxconts,maxres),
+ & gacontm_hb1(3,maxconts,maxres),gacontm_hb2(3,maxconts,maxres),
+ & gacontm_hb3(3,maxconts,maxres),
+ & gacont_hbr(3,maxconts,maxres),
+ & grij_hb_cont(3,maxconts,maxres),
+ & facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
+ & ees0m(maxconts,maxres),d_cont(maxconts,maxres),
+ & num_cont_hb(maxres),jcont_hb(maxconts,maxres)
+C 9/23/99 Added improper rotation matrices and matrices of dipole-dipole
+C interactions
+C Interactions of pseudo-dipoles generated by loc-el interactions.
+ double precision dip,dipderg,dipderx
+ common /dipint/ dip(4,maxconts,maxres),dipderg(4,maxconts,maxres),
+ & dipderx(3,5,4,maxconts,maxres)
+C 10/30/99 Added other pre-computed vectors and matrices needed
+C to calculate three - six-order el-loc correlation terms
+ double precision Ug,Ugder,Ug2,Ug2der,obrot,obrot2,obrot_der,
+ & obrot2_der,Ub2,Ub2der,mu,muder,EUg,EUgder,CUg,CUgder,
+ & DUg,DUgder,DtUg2,DtUg2der,Ctobr,Ctobrder,Dtobr2,Dtobr2der
+ common /rotat/ Ug(2,2,maxres),Ugder(2,2,maxres),Ug2(2,2,maxres),
+ & Ug2der(2,2,maxres),obrot(2,maxres),obrot2(2,maxres),
+ & obrot_der(2,maxres),obrot2_der(2,maxres)
+C This common block contains vectors and matrices dependent on a single
+C amino-acid residue.
+ common /precomp1/ Ub2(2,maxres),Ub2der(2,maxres),mu(2,maxres),
+ & EUg(2,2,maxres),EUgder(2,2,maxres),CUg(2,2,maxres),
+ & CUgder(2,2,maxres),DUg(2,2,maxres),Dugder(2,2,maxres),
+ & DtUg2(2,2,maxres),DtUg2der(2,2,maxres),Ctobr(2,maxres),
+ & Ctobrder(2,maxres),Dtobr2(2,maxres),Dtobr2der(2,maxres)
+C This common block contains vectors and matrices dependent on two
+C consecutive amino-acid residues.
+ double precision Ug2Db1t,Ug2Db1tder,CUgb2,CUgb2der,EUgC,
+ & EUgCder,EUgD,EUgDder,DtUg2EUg,DtUg2EUgder
+ common /precomp2/ Ug2Db1t(2,maxres),Ug2Db1tder(2,maxres),
+ & CUgb2(2,maxres),CUgb2der(2,maxres),EUgC(2,2,maxres),
+ & EUgCder(2,2,maxres),EUgD(2,2,maxres),EUgDder(2,2,maxres),
+ & DtUg2EUg(2,2,maxres),DtUg2EUgder(2,2,2,maxres),
+ & Ug2DtEUg(2,2,maxres),Ug2DtEUgder(2,2,2,maxres)
+ double precision costab,sintab,costab2,sintab2
+ common /rotat_old/ costab(maxres),sintab(maxres),
+ & costab2(maxres),sintab2(maxres),muder(2,maxres)
+C This common block contains dipole-interaction matrices and their
+C Cartesian derivatives.
+ double precision a_chuj,a_chuj_der
+ common /dipmat/ a_chuj(2,2,maxconts,maxres),
+ & a_chuj_der(2,2,3,5,maxconts,maxres)
+ double precision AEA,AEAderg,AEAderx,AECA,AECAderg,AECAderx,
+ & ADtEA,ADtEAderg,ADtEAderx,AEAb1,AEAb1derg,AEAb1derx,
+ & AEAb2,AEAb2derg,AEAb2derx
+ common /diploc/ AEA(2,2,2),AEAderg(2,2,2),AEAderx(2,2,3,5,2,2),
+ & EAEA(2,2,2), EAEAderg(2,2,2,2), EAEAderx(2,2,3,5,2,2),
+ & AECA(2,2,2),AECAderg(2,2,2),AECAderx(2,2,3,5,2,2),
+ & ADtEA(2,2,2),ADtEAderg(2,2,2,2),ADtEAderx(2,2,3,5,2,2),
+ & ADtEA1(2,2,2),ADtEA1derg(2,2,2,2),ADtEA1derx(2,2,3,5,2,2),
+ & AEAb1(2,2,2),AEAb1derg(2,2,2),AEAb1derx(2,3,5,2,2,2),
+ & AEAb2(2,2,2),AEAb2derg(2,2,2,2),AEAb2derx(2,3,5,2,2,2),
+ & g_contij(3,2),ekont
--- /dev/null
+ integer modecalc,iscode,indpdb,indback,indphi,iranconf,icheckgrad,
+ & inprint,i2ndstr,mucadyn,constr_dist
+ logical minim,refstr,pdbref,outpdb,outmol2,overlapsc,energy_dec,
+ & sideadd,lsecondary,read_cart,unres_pdb,
+ & vdisulf,searchsc,lmuca,dccart,extconf,out1file,
+ & gnorm_check,gradout,split_ene
+ common /cntrl/ modecalc,iscode,indpdb,indback,indphi,iranconf,
+ & icheckgrad,minim,i2ndstr,refstr,pdbref,outpdb,outmol2,iprint,
+ & overlapsc,energy_dec,sideadd,lsecondary,read_cart,unres_pdb
+ & ,vdisulf,searchsc,lmuca,dccart,mucadyn,extconf,out1file,
+ & constr_dist,gnorm_check,gradout,split_ene
+C... minim = .true. means DO minimization.
+C... energy_dec = .true. means print energy decomposition matrix
--- /dev/null
+ common /struct/ cart_base(3,maxres_base,maxseq),str_nam(maxseq),
+ & nres_base(3,maxseq),nseq
+ character*8 str_nam
--- /dev/null
+ double precision dcdv,dxdv,dxds,gradx,gradc,gvdwc,gelc,gelc_long,
+ & gvdwpp,gel_loc,gel_loc_long,gvdwc_scpp,
+ & 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,gvdwcT,gvdwxT
+ integer nfl,icg
+ common /derivatT/ gvdwcT(3,maxres),gvdwxT(3,maxres)
+ 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),gelc_long(3,maxres),
+ & gvdwpp(3,maxres),gvdwc_scpp(3,maxres),
+ & gradx_scp(3,maxres),gvdwc_scp(3,maxres),ghpbx(3,maxres),
+ & ghpbc(3,maxres),gloc(maxvar,2),gradcorr(3,maxres),
+ & gradcorr_long(3,maxres),gradcorr5_long(3,maxres),
+ & gradcorr6_long(3,maxres),gcorr6_turn_long(3,maxres),
+ & gradxorr(3,maxres),gradcorr5(3,maxres),gradcorr6(3,maxres),
+ & gloc_x(maxvar,2),gel_loc(3,maxres),gel_loc_long(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),dtheta(3,2,maxres),
+ & gscloc(3,maxres),gsclocx(3,maxres),
+ & dphi(3,3,maxres),dalpha(3,3,maxres),domega(3,3,maxres),nfl,icg
+ double precision derx,derx_turn
+ common /deriv_loc/ derx(3,5,2),derx_turn(3,5,2)
+ double precision dXX_C1tab(3,maxres),dYY_C1tab(3,maxres),
+ & dZZ_C1tab(3,maxres),dXX_Ctab(3,maxres),dYY_Ctab(3,maxres),
+ & dZZ_Ctab(3,maxres),dXX_XYZtab(3,maxres),dYY_XYZtab(3,maxres),
+ & dZZ_XYZtab(3,maxres)
+ common /deriv_scloc/ dXX_C1tab,dYY_C1tab,dZZ_C1tab,dXX_Ctab,
+ & dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,dZZ_XYZtab
+ integer igrad_start,igrad_end,jgrad_start(maxres),
+ & jgrad_end(maxres)
+ common /mpgrad/ igrad_start,igrad_end,jgrad_start,jgrad_end
--- /dev/null
+c parameter (maxres22=maxres*(maxres+1)/2)
+ parameter (maxres22=1)
+ double precision w,d0,DRDG,DD,H,XX
+ integer nbfrag,bfrag,nhfrag,hfrag,bvar_frag,hvar_frag,nhpb0,
+ 1 lvar_frag,svar_frag,avar_frag
+ COMMON /c_frag/ nbfrag,bfrag(4,maxres/3),nhfrag,hfrag(2,maxres/3)
+csa COMMON /frag/ bvar_frag(mxio,6),hvar_frag(mxio,3),
+csa 1 lvar_frag(mxio,3),svar_frag(mxio,3),
+csa 2 avar_frag(mxio,5)
+ COMMON /WAGI/ w(MAXRES22),d0(MAXRES22)
+ COMMON /POCHODNE/ NX,NY,DRDG(MAXRES22,MAXRES),DD(MAXRES22),
+ 1 H(MAXRES,MAXRES),XX(MAXRES)
+ COMMON /frozen/ mask(maxres)
+ COMMON /store0/ nhpb0
--- /dev/null
+C-----------------------------------------------------------------------
+C The following COMMON block selects the type of the force field used in
+C calculations and defines weights of various energy terms.
+C 12/1/95 wcorr added
+C-----------------------------------------------------------------------
+ integer n_ene_comp,rescale_mode
+ common /ffield/ wsc,wscp,welec,wbond,wstrain,wtor,wtor_d,wang,
+ & wscloc,wcorr,wcorr4,wcorr5,wcorr6,wsccor,wel_loc,wturn3,wturn4,
+ & wturn6,wvdwpp,wsct,weights(n_ene),temp0,
+ & scal14,cutoff_corr,delt_corr,r0_corr,ipot,n_ene_comp,
+ & rescale_mode
+ common /potentials/ potname(5)
+ character*3 potname
+C-----------------------------------------------------------------------
+C wlong,welec,wtor,wang,wscloc are the weight of the energy terms
+C corresponding to side-chain, electrostatic, torsional, valence-angle,
+C and local side-chain terms.
+C
+C IPOT determines which SC...SC interaction potential will be used:
+C 1 - LJ: 2n-n Lennard-Jones
+C 2 - LJK: 2n-n Kihara type (shifted Lennard-Jones)
+C 3 - BP; Berne-Pechukas (angular dependence)
+C 4 - GB; Gay-Berne (angular dependence)
+C 5 - GBV; Gay-Berne-Vorobjev; angularly-dependent Kihara potential
+C------------------------------------------------------------------------
--- /dev/null
+ double precision pi,dwapi,pipol,pi3,dwapi3,deg2rad,rad2deg,angmin
+ common /geo/ pi,dwapi,pipol,pi3,dwapi3,deg2rad,rad2deg,angmin
--- /dev/null
+ integer nharp_seed(max_seed),nharp_tot,
+ & iharp_seed(4,maxres/3,max_seed),iharp_use(0:4,maxres/3,max_seed),
+ & nharp_use(max_seed)
+ common /spinka/ nharp_seed,nharp_tot,iharp_seed,iharp_use,
+ & nharp_use
--- /dev/null
+ character*80 titel
+ common /header/ titel
--- /dev/null
+c NPROCS - total number of processors;
+c MyID - processor's ID;
+c MasterID - master processor's ID.
+ integer MyId,AllGrp,DontCare,MasterId,WhatsUp,ifinish
+ logical koniec
+ integer tag,status(MPI_STATUS_SIZE)
+ common /info/ myid,masterid,allgrp,dontcare,
+ & koniec(0:maxprocs-1),WhatsUp,ifinish(maxprocs-1)
+c... 5/12/96 - added variables for collective communication
+c FGPROCS - Number of fine-grain processors per coarse-grain task;
+c NCTASKS - Number of coarse-grain tasks;
+c MYGROUP - label of the processor's FG group id;
+c BOSSID - ID of group's master;
+c FGLIST - list of group's FG processors.
+c MSGLEN_VAR - length of the vector of variables passed to the fine-grain
+c slave processors
+ integer fgprocs,nctasks,mygroup,bossid,cglabel,
+ & cglist(max_cg_procs),cgGroupID,fglist(max_fg_procs),
+ & fgGroupID,MyRank
+ common /info1/ fgprocs,nctasks,mygroup,bossid,cglabel,cglist,
+ & cgGroupID,fglist,fgGroupID,MyRank,msglen_var
--- /dev/null
+ double precision aa,bb,augm,aad,bad,app,bpp,ale6,ael3,ael6
+ integer expon,expon2
+ integer nnt,nct,nint_gr,istart,iend,itype,itel,itypro,
+ & ielstart,ielend,ielstart_vdw,ielend_vdw,nscp_gr,iscpstart,
+ & iscpend,iatsc_s,iatsc_e,
+ & iatel_s,iatel_e,iatscp_s,iatscp_e,iatel_s_vdw,iatel_e_vdw,
+ & ispp,iscp
+ common /interact/aa(ntyp,ntyp),bb(ntyp,ntyp),augm(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),ielstart_vdw(maxres),
+ & ielend_vdw(maxres),nscp_gr(maxres),
+ & iscpstart(maxres,maxint_gr),iscpend(maxres,maxint_gr),
+ & iatsc_s,iatsc_e,iatel_s,iatel_e,iatel_s_vdw,iatel_e_vdw,
+ & iatscp_s,iatscp_e,ispp,iscp
+C 12/1/95 Array EPS included in the COMMON block.
+ double precision eps,sigma,sigmaii,rs0,chi,chip,alp,sigma0,sigii,
+ & rr0,r0,r0e,r0d,rpp,epp,elpp6,elpp3,eps_scp,rscp
+ common /body/eps(ntyp,ntyp),sigma(0:ntyp1,0:ntyp1),
+ & sigmaii(ntyp,ntyp),
+ & rs0(ntyp,ntyp),chi(ntyp,ntyp),chip(ntyp),alp(ntyp),sigma0(ntyp),
+ & sigii(ntyp),rr0(ntyp),r0(ntyp,ntyp),r0e(ntyp,ntyp),r0d(ntyp,2),
+ & rpp(2,2),epp(2,2),elpp6(2,2),elpp3(2,2),eps_scp(20,2),rscp(20,2)
+c 12/5/03 modified 09/18/03 Bond stretching parameters.
+ double precision vbldp0,vbldsc0,akp,aksc,abond0
+ integer nbondterm
+ common /stretch/ vbldp0,vbldsc0(maxbondterm,ntyp),akp,
+ & aksc(maxbondterm,ntyp),abond0(maxbondterm,ntyp),nbondterm(ntyp)
+ double precision wdti,wdti2,wdti4,wdti8,
+ & wdtii,wdtii2,wdtii4,wdtii8
+ common /nosehoover_dt/
+ & wdti(maxyosh),wdti2(maxyosh),wdti4(maxyosh),wdti8(maxyosh),
+ & wdtii(maxyosh),wdtii2(maxyosh),wdtii4(maxyosh),wdtii8(maxyosh)
--- /dev/null
+C-----------------------------------------------------------------------
+C I/O units used by the program
+C-----------------------------------------------------------------------
+C 9/18/99 - unit ifourier and filename fouriername included to identify
+C the file from which the coefficients of second-order Fourier expansion
+C of the local-interaction energy are read.
+C 8/9/01 - file for SCP interaction constants named scpname (unit iscpp)
+C included.
+C-----------------------------------------------------------------------
+C General I/O units & files
+ integer inp,iout,igeom,intin,ipdb,imol2,ipdbin,ithep,irotam,
+ & itorp,itordp,ifourier,ielep,isidep,iscpp,icbase,istat,
+ & ientin,ientout,izs1,isecpred,ibond,irest2,iifrag,icart,
+ & irest1,isccor,ithep_pdb,irotam_pdb
+ common /iounits/ inp,iout,igeom,intin,ipdb,imol2,ipdbin,ithep,
+ & irotam,itorp,itordp,ifourier,ielep,isidep,iscpp,icbase,
+ & istat,ientin,ientout,izs1,isecpred,ibond,irest2,iifrag,
+ & icart,irest1,isccor,ithep_pdb,irotam_pdb
+ character*256 outname,intname,pdbname,mol2name,statname,intinname,
+ & entname,prefix,secpred,rest2name,qname,cartname,tmpdir,
+ & mremd_rst_name,curdir,pref_orig
+ character*4 liczba
+ common /fnames/ outname,intname,pdbname,mol2name,statname,
+ & intinname,entname,prefix,pot,secpred,rest2name,qname,
+ & cartname,tmpdir,mremd_rst_name,curdir,pref_orig,liczba
+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,icsa_pdb
+ 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,icsa_pdb
+C Parameter files
+ character*256 bondname,thetname,rotname,torname,tordname,
+ & fouriername,elename,sidename,scpname,sccorname,patname,
+ & thetname_pdb,rotname_pdb
+ common /parfiles/ bondname,thetname,rotname,torname,tordname,
+ & fouriername,elename,sidename,scpname,sccorname,patname,
+ & thetname_pdb,rotname_pdb
+ character*3 pot
+C-----------------------------------------------------------------------
+C INP - main input file
+C IOUT - list file
+C IGEOM - geometry output in the form of virtual-chain internal coordinates
+C INTIN - geometry input (for multiple conformation processing) in int. coords.
+C IPDB - Cartesian-coordinate output in PDB format
+C IMOL2 - Cartesian-coordinate output in Tripos mol2 format
+C IPDBIN - PDB input file
+C ITHEP - virtual-bond torsional angle parametrs
+C IROTAM - side-chain geometry and local-interaction parameters
+C ITORP - torsional parameters
+C ITORDP - double torsional parameters
+C IFOURIER - coefficients of the expansion of local-interaction energy
+C IELEP - electrostatic-interaction parameters
+C ISIDEP - side-chain interaction parameters.
+C ISCPP - SCp interaction parameters.
+C IBOND - virtual-bond constant parameters and moments of inertia.
+C ISCCOR - parameters of the potential of SCCOR term
+C ICBASE - data base with Cartesian coords of known structures.
+C ISTAT - energies and other conf. characteristics from an MCM run.
+C IENTIN - entropy from preceeding simulation(s) to be read in.
+C SECPRED - SECONDARY STRUCTURE PREDICTION for dihedral constraint generation.
+C-----------------------------------------------------------------------
--- /dev/null
+ double precision friction(3,0:MAXRES2),stochforc(3,0:MAXRES2),
+ & fricmat(MAXRES2,MAXRES2),fric_work(MAXRES6),
+ & stoch_work(MAXRES6),
+ & fricgam(MAXRES6),fricvec(MAXRES2,MAXRES2),
+ & pfric_mat(MAXRES2,MAXRES2),vfric_mat(MAXRES2,MAXRES2),
+ & afric_mat(MAXRES2,MAXRES2),prand_mat(MAXRES2,MAXRES2),
+ & vrand_mat1(MAXRES2,MAXRES2),vrand_mat2(MAXRES2,MAXRES2),
+ & pfric0_mat(MAXRES2,MAXRES2,0:maxflag_stoch),
+ & afric0_mat(MAXRES2,MAXRES2,0:maxflag_stoch),
+ & vfric0_mat(MAXRES2,MAXRES2,0:maxflag_stoch),
+ & prand0_mat(MAXRES2,MAXRES2,0:maxflag_stoch),
+ & vrand0_mat1(MAXRES2,MAXRES2,0:maxflag_stoch),
+ & vrand0_mat2(MAXRES2,MAXRES2,0:maxflag_stoch),
+ & mt1(maxres2,maxres2),mt2(maxres2,maxres2),mt3(maxres2,maxres2)
+ logical flag_stoch(0:maxflag_stoch)
+ common /langforc/ friction,stochforc,
+ & fricmat,fric_work,fricgam,stoch_work,fricvec,vrand_mat1,
+ & vrand_mat2,prand_mat,vfric_mat,afric_mat,pfric_mat,
+ & pfric0_mat,afric0_mat,vfric0_mat,prand0_mat,vrand0_mat1,
+ & vrand0_mat2,flag_stoch
+ common /langmat/ mt1,mt2,mt3
--- /dev/null
+ double precision friction(3,0:MAXRES2),stochforc(3,0:MAXRES2),
+ & fricmat(MAXRES2,MAXRES2),fric_work(MAXRES6),
+ & stoch_work(MAXRES6),
+ & fricgam(MAXRES6),fricvec(MAXRES2,MAXRES2)
+ logical flag_stoch(0:maxflag_stoch)
+ common /langforc/ friction,stochforc,
+ & fricmat,fric_work,fricgam,stoch_work,fricvec,vrand_mat1,
+ & vrand_mat2,prand_mat,vfric_mat,afric_mat,pfric_mat,
+ & pfric0_mat,afric0_mat,vfric0_mat,prand0_mat,vrand0_mat1,
+ & vrand0_mat2,flag_stoch
+ common /langmat/ mt1,mt2,mt3
--- /dev/null
+ double precision a0thet,athet,bthet,polthet,gthet,theta0,sig0,
+ & sigc0,dsc,dsc_inv,bsc,censc,gaussc,dsc0
+ integer nlob
+C Parameters of the virtual-bond-angle probability distribution
+ common /thetas/ a0thet(ntyp),athet(2,ntyp),bthet(2,ntyp),
+ & polthet(0:3,ntyp),gthet(3,ntyp),theta0(ntyp),sig0(ntyp),
+ & sigc0(ntyp)
+C Parameters of the side-chain probability distribution
+ common /sclocal/ dsc(ntyp1),dsc_inv(ntyp1),bsc(maxlob,ntyp),
+ & censc(3,maxlob,ntyp),gaussc(3,3,maxlob,ntyp),dsc0(ntyp1),
+ & nlob(ntyp1)
+C Parameters of ab initio-derived potential of virtual-bond-angle bending
+ integer nthetyp,ntheterm,ntheterm2,ntheterm3,nsingle,ndouble,
+ & ithetyp(ntyp1),nntheterm
+ double precision aa0thet(maxthetyp1,maxthetyp1,maxthetyp1),
+ & aathet(maxtheterm,maxthetyp1,maxthetyp1,maxthetyp1),
+ & bbthet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1),
+ & ccthet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1),
+ & ddthet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1),
+ & eethet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1),
+ & ffthet(maxdouble,maxdouble,maxtheterm3,maxthetyp1,maxthetyp1,
+ & maxthetyp1),
+ & ggthet(maxdouble,maxdouble,maxtheterm3,maxthetyp1,maxthetyp1,
+ & maxthetyp1)
+ common /theta_abinitio/aa0thet,aathet,bbthet,ccthet,ddthet,eethet,
+ & ffthet,
+ & ggthet,ithetyp,nthetyp,ntheterm,ntheterm2,ntheterm3,nsingle,
+ & ndouble,nntheterm
+C Virtual-bond lenghts
+ double precision vbl,vblinv,vblinv2,vbl_cis,vbl0,vbld_inv
+ integer loc_start,loc_end,ithet_start,ithet_end,iphi_start,
+ & iphi_end,iphid_start,iphid_end,itau_start,itau_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,
+ & ibond_displ(0:max_fg_procs-1),ibond_count(0:max_fg_procs-1),
+ & ithet_displ(0:max_fg_procs-1),ithet_count(0:max_fg_procs-1),
+ & iphi_displ(0:max_fg_procs-1),iphi_count(0:max_fg_procs-1),
+ & iphi1_displ(0:max_fg_procs-1),iphi1_count(0:max_fg_procs-1),
+ & ivec_displ(0:max_fg_procs-1),ivec_count(0:max_fg_procs-1),
+ & iset_displ(0:max_fg_procs-1),iset_count(0:max_fg_procs-1),
+ & iint_count(0:max_fg_procs-1),iint_displ(0:max_fg_procs-1)
+ 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,itau_start,itau_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,iint_count,iint_displ,ivec_displ,
+ & ivec_count,iset_displ,
+ & iset_count,ibond_displ,ibond_count,ithet_displ,ithet_count,
+ & iphi_displ,iphi_count,iphi1_displ,iphi1_count
+C Inverses of the actual virtual bond lengths
+ common /invlen/ vbld_inv(maxres2)
--- /dev/null
+c Variables (set in init routine) never modified by local_move
+ integer init_called
+ logical locmove_output
+ double precision min_theta, max_theta
+ double precision dmin2,dmax2
+ double precision flag,small,small2
+
+ common /loc_const/ init_called,locmove_output,min_theta,
+ + max_theta,dmin2,dmax2,flag,small,small2
+
+c Workspace for local_move
+ integer a_n,b_n,res_n
+ double precision a_ang,b_ang,res_ang
+ logical a_tab,b_tab,res_tab
+
+ common /loc_work/ res_ang(0:11),a_ang(0:7),b_ang(0:3),
+ + res_n,res_tab(0:2,0:2,0:11),
+ + a_n,a_tab(0:2,0:7),
+ + b_n,b_tab(0:2,0:3)
--- /dev/null
+ integer nmap,res1,res2,nstep
+ double precision ang_from,ang_to
+ common /mapp/ ang_from(maxvar),ang_to(maxvar),nmap,kang(maxvar),
+ & res1(maxvar),res2(maxvar),nstep(maxvar)
--- /dev/null
+ double precision
+ & gvdwc_max,gvdwc_scp_max,gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
+ & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
+ & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
+ & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
+ & gsccorx_max,gsclocx_max
+ common /maxgrad/
+ & gvdwc_max,gvdwc_scp_max,gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
+ & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
+ & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
+ & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
+ & gsccorx_max,gsclocx_max
--- /dev/null
+ double precision entropy(-max_ene-4:max_ene),nminima(maxsave),
+ & nhist(-max_ene:max_ene)
+ logical ent_read,multican
+ common /mce/ entropy,emin,emax,nhist,nminima,ent_read,multican,
+ & indminn,indmaxx
+ integer npool
+ double precision xpool,epool,pool_fraction
+ common /pool/ xpool(maxvar,max_pool),epool(max_pool),
+ & pool_fraction,npool
+ integer save_frequency,message_frequency,pool_read_freq,
+ & pool_save_freq,print_freq
+ common /mce_counters/ save_frequency,message_frequency,
+ & pool_read_freq,pool_save_freq,print_freq
--- /dev/null
+C... Following COMMON block contains general variables controlling the MC/MCM
+C... procedure
+c-----------------------------------------------------------------------------
+ double precision Tcur,Tmin,Tmax,TstepH,TstepC,RanFract,
+ & overlap_cut,e_up,delte
+ integer nstepH,nstepC,maxacc,maxgen,maxtrial,maxtrial_iter,
+ & maxrepm,ngen,ntrial,ntherm,nrepm,neneval,nsave,maxoverlap,
+ & nsave_part,max_mcm_it,nsweep,print_mc
+ logical print_stat,print_int
+ common /mcm/ Tcur,Tmin,Tmax,TstepH,TstepC,Rbol,betbol,RanFract,
+ & overlap_cut,e_up,delte,
+ & nstepH,nstepC,maxacc,maxgen,maxtrial,maxtrial_iter,maxrepm,
+ & maxoverlap,ntrial,max_mcm_it,
+ & ngen,ntherm,nrepm,neneval,nsave,nsave_part(max_cg_procs),nsweep,
+ & print_mc,print_stat,print_int
+c-----------------------------------------------------------------------------
+C... The meaning of the above variables is as follows:
+C... Tcur,Tmin,Tmax - Current,minimum and maximum temperature, respectively;
+C... NstepC,NStepH - Number of cooling and heating steps, respectively;
+C... TstepH,TstepC - factors by which T is multiplied in order to be
+C... increased or decreased.
+C... betbol - Boltzmann's inverse temperature (1/(Rbol*Tcur));
+C... Rbol - the gas constant;
+C... RanFract - the chance that a new conformation will be random-generated;
+C... maxacc - maximum number of accepted conformations;
+C... maxgen,ngen - Maximum and current number of generated conformations;
+C... maxtrial,ntrial - maximum number of trials before temperature is increased
+C... and current number of trials, respectively;
+C... maxrepm,nrepm - maximum number of allowed minima repetition and current
+C... number of minima repetitions, respectively;
+C... maxoverlap - max. # of overlapping confs generated in a single iteration;
+C... neneval - number of energy evaluations;
+C... nsave - number of confs. in the backup array;
+C... nsweep - the number of macroiterations in generating the distributions.
+c------------------------------------------------------------------------------
+C... Following COMMON block contains variables controlling motion.
+c------------------------------------------------------------------------------
+ double precision sumpro_type,sumpro_bond
+ integer koniecl, Nbm,MaxSideMove,nmove,moves(-1:MaxMoveType+1),
+ & moves_acc(-1:MaxMoveType+1),nacc_tot,nacc_part(0:MaxProcs)
+ common /move/ sumpro_type(0:MaxMoveType),sumpro_bond(0:maxres),
+ & koniecl,Nbm,MaxSideMove,nmove,nbond_move(maxres),
+ & nbond_acc(maxres),moves,moves_acc
+ common /accept_stats/ nacc_tot,nacc_part
+ integer nwindow,winstart,winend,winlen
+ common /windows/ nwindow,winstart(maxres),winend(maxres),
+ & winlen(maxres)
+ character*16 MovTypID
+ common /moveID/ MovTypID(-1:MaxMoveType+1)
+c------------------------------------------------------------------------------
+C... koniecl - the number of bonds to be considered "end bonds" subjected to
+C... end moves;
+C... Nbm - The maximum length of N-bond segment to be moved;
+C... MaxSideMove - maximum number of side chains subjected to local moves
+C... simultaneously;
+C... nmove - the current number of attempted moves;
+C... nbond_move(*) array that stores the total numbers of 2-bond,3-bond,...
+C... moves;
+C... nendmove - number of endmoves;
+C... nbackmove - number of backbone moves;
+C... nsidemove - number of local side chain moves;
+C... sumpro_type(*) - array that stores the lower and upper boundary of the
+C... random-number range that determines the type of move
+C... (N-bond, backbone or side chain);
+C... sumpro_bond(*) - array that stores the probabilities to perform bond
+C... moves of consecutive segment length.
+C... winstart(*) - the starting position of the perturbation window;
+C... winend(*) - the end position of the perturbation window;
+C... winlen(*) - length of the perturbation window;
+C... nwindow - the number of perturbation windows (0 - entire chain).
--- /dev/null
+ double precision gcart, gxcart, gradcag,gradxag
+ common /mdgrad/ gcart(3,0:MAXRES), gxcart(3,0:MAXRES),
+ & gradcag(3,MAXRES),gradxag(3,MAXRES)
+ integer dimen,dimen1, dimen3, ifrag(2,50,maxprocs/20),
+ & ipair(2,100,maxprocs/20),iset,
+ & mset(maxprocs/20),nset
+ double precision IP,ISC(ntyp+1),mp,
+ & msc(ntyp+1),d_t_work(MAXRES6),
+ & d_t_work_new(MAXRES6),d_t(3,0:MAXRES2),d_t_new(3,0:MAXRES2),
+ & d_af_work(MAXRES6),d_as_work(MAXRES6),
+ & d_t_old(3,0:MAXRES2),d_a_old(3,0:MAXRES2),d_a_short(3,0:MAXRES2),
+ & Gmat(MAXRES2,MAXRES2),Ginv(MAXRES2,MAXRES2),A(MAXRES2,MAXRES2),
+ & d_a(3,0:MAXRES2),d_a_work(6*MAXRES),kinetic_force(MAXRES6),
+ & Gsqrp(MAXRES2,MAXRES2),Gsqrm(MAXRES2,MAXRES2),
+ & vtot(MAXRES2),Gvec(maxres2,maxres2),Geigen(maxres2)
+ double precision v_ini,d_time,d_time0,t_bath,tau_bath,
+ & EK,potE,potEcomp(0:n_ene+4),totE,totT,amax,kinetic_T,dvmax,damax,
+ & edriftmax,
+ & eq_time,wfrag(50,maxprocs/20),wpair(100,maxprocs/20),
+ & qfrag(50),qpair(100),
+ & qinfrag(50,maxprocs/20),qinpair(100,maxprocs/20),
+ & Ucdfrag,Ucdpair,dUdconst(3,0:MAXRES),Uconst,
+ & dUdxconst(3,0:MAXRES),dqwol(3,0:MAXRES),dxqwol(3,0:MAXRES),
+ & utheta(maxfrag_back),ugamma(maxfrag_back),uscdiff(maxfrag_back),
+ & dutheta(maxres),dugamma(maxres),duscdiff(3,maxres),
+ & duscdiffx(3,maxres),wfrag_back(3,maxfrag_back,maxprocs/20),
+ & uconst_back
+ integer n_timestep,ntwx,ntwe,lang,count_reset_moment,
+ & count_reset_vel,reset_fricmat,nfrag,npair,nfrag_back,
+ & ifrag_back(3,maxfrag_back,maxprocs/20),ntime_split,ntime_split0,
+ & maxtime_split
+ integer nresn,nyosh,nnos
+ double precision glogs,qmass,vlogs,xlogs
+ logical large,print_compon,tbf,rest,reset_moment,reset_vel,
+ & surfarea,rattle,usampl,mdpdb,RESPA,tnp,tnp1,tnh,xiresp
+ integer igmult_start,igmult_end,my_ng_count,ng_start,ng_counts,
+ & nginv_start,nginv_counts,myginv_ng_count
+ common /back_constr/ uconst_back,utheta,ugamma,uscdiff,
+ & dutheta,dugamma,duscdiff,duscdiffx,
+ & wfrag_back,nfrag_back,ifrag_back
+ common /qmeas/ qfrag,qpair,qinfrag,qinpair,wfrag,wpair,eq_time,
+ & Ucdfrag,Ucdpair,dUdconst,dUdxconst,dqwol,dxqwol,Uconst,
+ & iset,mset,nset,usampl,ifrag,ipair,npair,nfrag
+ common /mdpar/ v_ini,d_time,d_time0,scal_fric,
+ & t_bath,tau_bath,dvmax,damax,n_timestep,mdpdb,
+ & ntime_split,ntime_split0,maxtime_split,
+ & ntwx,ntwe,large,print_compon,tbf,rest,tnp,tnp1,tnh
+ common /MDcalc/ totT,totE,potE,potEcomp,EK,amax,edriftmax,
+ & kinetic_T
+ common /lagrange/ d_t,d_t_old,d_t_new,d_t_work,
+ & d_t_work_new,d_a,d_a_old,d_a_work,d_af_work,d_as_work,d_a_short,
+ & kinetic_force,
+ & A,Ginv,Gmat,Gvec,Geigen,Gsqrp,Gsqrm,
+ & vtot,dimen,dimen1,dimen3,lang,
+ & reset_moment,reset_vel,count_reset_moment,count_reset_vel,
+ & rattle,RESPA
+ common /inertia/ IP,ISC,MP,MSC
+ double precision scal_fric,rwat,etawat,gamp,
+ & gamsc(ntyp),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,surfarea,
+ & reset_fricmat
+ common /mdpmpi/ igmult_start,igmult_end,my_ng_count,
+ & myginv_ng_count,
+ & ng_start(0:MaxProcs-1),ng_counts(0:MaxProcs-1),
+ & nginv_start(0:MaxProcs),nginv_counts(0:MaxProcs-1)
+ double precision pi_np,pistar,s_np,s12_np,Q_np,E_old,H0,E_long,
+ & sold_np,d_t_half,Csplit,hhh
+ common /nosepoincare/ pi_np,pistar,s_np,s12_np,Q_np,E_old,H0,
+ & E_long,sold_np,d_t_half(3,0:MAXRES2),Csplit,hhh
+ common /nosehoover/ glogs(maxmnh),qmass(maxmnh),
+ & vlogs(maxmnh),xlogs(maxmnh),
+ & nresn,nyosh,nnos,xiresp
+ integer hmc,hmc_acc
+ double precision dc_hmc,hmc_etot,totThmc
+ common /hmc_md/ dc_hmc(3,0:maxres2),hmc_etot,hmc,totThmc,hmc_acc
--- /dev/null
+ double precision tolf,rtolf
+ integer maxfun,maxmin,minfun,minmin,
+ & print_min_ini,print_min_stat,print_min_res
+ common /minimm/ tolf,rtolf,maxfun,maxmin,minfun,minmin,
+ & print_min_ini,print_min_stat,print_min_res
--- /dev/null
+ double precision emuca(4*maxres),nemuca(4*maxres),
+ & nemuca2(4*maxres),elow,ehigh,factor,
+ & elowi(maxprocs),ehighi(maxprocs),hbin,
+ & hist(4*maxres),factor_min
+ integer nmuca,imtime,muca_smooth
+ common /double_muca/ emuca,nemuca,
+ & nemuca2,elow,ehigh,factor,hbin,hist,factor_min
+ common /integer_muca/ nmuca,imtime,muca_smooth
+ common /mucarem/ elowi,ehighi
+
--- /dev/null
+ character*3 restyp
+ character*1 onelet
+ common /names/ restyp(ntyp+1),onelet(ntyp+1)
+ character*10 ename,wname
+ integer nprint_ene,print_order
+ common /namterm/ ename(n_ene),wname(n_ene),nprint_ene,
+ & print_order(n_ene)
--- /dev/null
+ double precision e1,e2,e3,u,z,s1,s2
+ integer i1,i2,i3,i4
+ common /refer/ e1(3),e2(3),e3(3),u(3),z(3),s1,s2,i1,i2,i3,i4
--- /dev/null
+ integer nrep,nstex,hremd
+ logical remd_tlist,remd_mlist,mremdsync,restart1file,traj1file
+ double precision retmin,retmax,remd_t(maxprocs)
+ double precision hweights(maxprocs/20,n_ene)
+ integer remd_m(maxprocs),i_sync_step
+ integer*2 i2rep(0:maxprocs),i2set(0:maxprocs)
+ integer*2 ifirst(maxprocs)
+ integer*2 nupa(0:maxprocs/4,0:maxprocs),
+ & ndowna(0:maxprocs/4,0:maxprocs)
+ real t_restart1(5,maxprocs)
+ integer iset_restart1(maxprocs)
+ logical t_exchange_only
+ common /remdcommon/ nrep,nstex,retmin,retmax,remd_t,remd_tlist,
+ & remd_mlist,remd_m,mremdsync,restart1file,
+ & traj1file,i_sync_step,t_exchange_only
+ common /hamilt_remd/ hweights,hremd
+ common /remdrestart/ i2rep,i2set,ifirst,nupa,ndowna,t_restart1,
+ & iset_restart1
+ real totT_cache,EK_cache,potE_cache,t_bath_cache,Uconst_cache,
+ & qfrag_cache,qpair_cache,c_cache,
+ & ugamma_cache,utheta_cache
+ integer ntwx_cache,ii_write,max_cache_traj_use
+ common /traj1cache/ totT_cache(max_cache_traj),
+ & EK_cache(max_cache_traj),
+ & potE_cache(max_cache_traj),
+ & t_bath_cache(max_cache_traj),
+ & Uconst_cache(max_cache_traj),
+ & qfrag_cache(50,max_cache_traj),
+ & qpair_cache(100,max_cache_traj),
+ & ugamma_cache(maxfrag_back,max_cache_traj),
+ & utheta_cache(maxfrag_back,max_cache_traj),
+ & uscdiff_cache(maxfrag_back,max_cache_traj),
+ & c_cache(3,maxres2+2,max_cache_traj),
+ & iset_cache(max_cache_traj),ntwx_cache,
+ & ii_write,max_cache_traj_use
+
--- /dev/null
+ double precision ebr,d0cm,akcm,akth,akct,v1ss,v2ss,v3ss
+ integer ns,nss,nfree,iss
+ common /sbridge/ ebr,d0cm,akcm,akth,akct,v1ss,v2ss,v3ss,
+ & ns,nss,nfree,iss(maxss)
+ double precision dhpb,dhpb1,forcon
+ integer ihpb,jhpb,nhpb
+ common /links/ dhpb(maxdim),dhpb1(maxdim),forcon(maxdim),
+ & ihpb(maxdim),jhpb(maxdim),ibecarb(maxdim),nhpb
+ double precision weidis
+ common /restraints/ weidis
+ integer link_start,link_end
+ common /links_split/ link_start,link_end
--- /dev/null
+cc Parameters of the SCCOR term
+ double precision v1sccor,v2sccor,vlor1sccor,
+ & vlor2sccor,vlor3sccor,gloc_sc,
+ & dcostau,dsintau,dtauangle,dcosomicron,
+ & domicron
+ integer nterm_sccor,isccortyp,nsccortyp,nlor_sccor
+ common/sccor/v1sccor(maxterm_sccor,3,20,20),
+ & v2sccor(maxterm_sccor,3,20,20),
+ & v0sccor(ntyp,ntyp),
+ & nterm_sccor(ntyp,ntyp),isccortyp(ntyp),nsccortyp,
+ & nlor_sccor(ntyp,ntyp),vlor1sccor(maxterm_sccor,20,20),
+ & vlor2sccor(maxterm_sccor,20,20),
+ & vlor3sccor(maxterm_sccor,20,20),gloc_sc(3,0:maxres2,10),
+ & dcostau(3,3,3,maxres2),dsintau(3,3,3,maxres2),
+ & dtauangle(3,3,3,maxres2),dcosomicron(3,3,3,maxres2),
+ & domicron(3,3,3,maxres2)
--- /dev/null
+C Parameters of the SC rotamers (local) term
+ double precision sc_parmin
+ common/scrot/sc_parmin(maxsccoef,20)
--- /dev/null
+ integer king,idint,idreal,idchar,is_done
+ parameter (king=0,idint=1105,idreal=1729,idchar=1597,is_done=1)
+ integer me,cg_rank,fg_rank,fg_rank1,nodes,Nprocs,nfgtasks,kolor,
+ & koniec(0:maxprocs-1),WhatsUp,ifinish(maxprocs-1),CG_COMM,FG_COMM,
+ & FG_COMM1,CONT_FROM_COMM,CONT_TO_COMM,lentyp(0:maxprocs-1),
+ & kolor1,key1,nfgtasks1,MyRank,
+ & max_gs_size
+ logical yourjob, finished, cgdone
+ common/setup/me,MyRank,cg_rank,fg_rank,fg_rank1,nodes,Nprocs,
+ & nfgtasks,nfgtasks1,
+ & max_gs_size,kolor,koniec,WhatsUp,ifinish,CG_COMM,FG_COMM,
+ & FG_COMM1,CONT_FROM_COMM,CONT_TO_COMM,lentyp
+ integer MPI_UYZ,MPI_UYZGRAD,MPI_MU,MPI_MAT1,MPI_MAT2,
+ & MPI_THET,MPI_GAM,
+ & MPI_ROTAT1(0:1),MPI_ROTAT2(0:1),MPI_ROTAT_OLD(0:1),
+ & MPI_PRECOMP11(0:1),MPI_PRECOMP12(0:1),MPI_PRECOMP22(0:1),
+ & MPI_PRECOMP23(0:1)
+ common /types/ MPI_UYZ,MPI_UYZGRAD,MPI_MU,MPI_MAT1,MPI_MAT2,
+ & MPI_THET,MPI_GAM,
+ & MPI_ROTAT1,MPI_ROTAT2,MPI_ROTAT_OLD,MPI_PRECOMP11,MPI_PRECOMP12,
+ & MPI_PRECOMP22,MPI_PRECOMP23
--- /dev/null
+ double precision r_cut,rlamb
+ common /splitele/ r_cut,rlamb
--- /dev/null
+ 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+2,maxthread),ener(n_ene+2,maxthread),
+ & max_time_for_thread,ave_time_for_thread
--- /dev/null
+ DOUBLE PRECISION BATIME,TIMLIM,STIME,PREVTIM,SAFETY
+ DOUBLE PRECISION WALLTIME
+ INTEGER ISTOP
+c FOUND_NAN - set by calcf to stop sumsl via stopx
+ logical FOUND_NAN
+ COMMON/TIME1/STIME,TIMLIM,BATIME,PREVTIM,SAFETY,WALLTIME
+ COMMON/STOPTIM/ISTOP
+ common /sumsl_flag/ FOUND_NAN
+ double precision t_init,t_MDsetup,t_langsetup,t_MD,
+ & t_enegrad,t_sdsetup,time_bcast,time_reduce,time_gather,
+ & time_sendrecv,time_barrier_e,time_barrier_g,time_scatter,
+ & t_eelecij,time_bcast7,time_bcastc,time_bcastw,time_allreduce,
+ & time_enecalc,time_sumene,time_lagrangian,time_cartgrad,
+ & time_sumgradient,time_intcartderiv,time_inttocart,time_intfcart,
+ & time_vec,time_mat,time_ginvmult,time_fricmatmult,time_fric,
+ & time_scatter_fmat,time_scatter_ginv,
+ & time_fsample,time_scatter_fmatmult,time_scatter_ginvmult,
+ & time_stoch,t_eshort,t_elong,t_etotal
+ common /timing/ t_init,t_MDsetup,t_langsetup,
+ & t_MD,t_enegrad,t_sdsetup,time_bcast,time_reduce,time_gather,
+ & time_sendrecv,time_scatter,time_barrier_e,time_barrier_g,
+ & time_bcast7,time_bcastc,time_bcastw,time_allreduce,
+ & t_eelecij,time_enecalc,time_sumene,time_lagrangian,time_cartgrad,
+ & time_sumgradient,time_intcartderiv,time_inttocart,time_intfcart,
+ & time_vec,time_mat,time_ginvmult,time_fricmatmult,time_fric,
+ & time_fsample,time_scatter_fmatmult,time_scatter_ginvmult,
+ & time_scatter_fmat,time_scatter_ginv,
+ & time_stoch,t_eshort,t_elong,t_etotal
--- /dev/null
+ integer ndih_constr,idih_constr(maxdih_constr)
+ integer ndih_nconstr,idih_nconstr(maxdih_constr)
+ integer idihconstr_start,idihconstr_end
+ double precision phi0(maxdih_constr),drange(maxdih_constr),ftors
+ common /torcnstr/ phi0,drange,ftors,ndih_constr,idih_constr,
+ & ndih_nconstr,idih_nconstr,idihconstr_start,idihconstr_end
--- /dev/null
+C Torsional constants of the rotation about virtual-bond dihedral angles
+ double precision v1,v2,vlor1,vlor2,vlor3,v0
+ integer itortyp,ntortyp,nterm,nlor,nterm_old
+ common/torsion/v0(maxtor,maxtor),v1(maxterm,maxtor,maxtor),
+ & v2(maxterm,maxtor,maxtor),vlor1(maxlor,maxtor,maxtor),
+ & vlor2(maxlor,maxtor,maxtor),vlor3(maxlor,maxtor,maxtor),
+ & itortyp(ntyp),ntortyp,nterm(maxtor,maxtor),nlor(maxtor,maxtor)
+ & ,nterm_old
+C 6/23/01 - constants for double torsionals
+ double precision v1c,v1s,v2c,v2s
+ integer ntermd_1,ntermd_2
+ common /torsiond/ v1c(2,maxtermd_1,maxtor,maxtor,maxtor),
+ & v1s(2,maxtermd_1,maxtor,maxtor,maxtor),
+ & v2c(maxtermd_2,maxtermd_2,maxtor,maxtor,maxtor),
+ & v2s(maxtermd_2,maxtermd_2,maxtor,maxtor,maxtor),
+ & ntermd_1(maxtor,maxtor,maxtor),ntermd_2(maxtor,maxtor,maxtor)
+C 9/18/99 - added Fourier coeffficients of the expansion of local energy
+C surface
+ double precision b1,b2,cc,dd,ee,ctilde,dtilde,b2tilde
+ 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
--- /dev/null
+C Store the geometric variables in the following COMMON block.
+ integer ntheta,nphi,nside,nvar,Origin,nstore,ialph,ivar,
+ & mask_theta,mask_phi,mask_side
+ double precision theta,phi,alph,omeg,varsave,esave,varall,vbld,
+ & thetaref,phiref,costtab,sinttab,cost2tab,sint2tab,
+ & xxtab,yytab,zztab,xxref,yyref,zzref,tauangle,omicron
+ common /var/ theta(maxres),phi(maxres),alph(maxres),omeg(maxres),
+ & omicron(2,maxres),tauangle(3,maxres),
+ & vbld(2*maxres),thetaref(maxres),phiref(maxres),
+ & costtab(maxres), sinttab(maxres), cost2tab(maxres),
+ & sint2tab(maxres),xxtab(maxres),yytab(maxres),
+ & zztab(maxres),xxref(maxres),yyref(maxres),zzref(maxres),
+ & ialph(maxres,2),ivar(4*maxres2),ntheta,nphi,nside,nvar
+C Store the angles and variables corresponding to old conformations (for use
+C in MCM).
+ common /oldgeo/ varsave(maxvar,maxsave),esave(maxsave),
+ & Origin(maxsave),nstore
+C freeze some variables
+ logical mask_r
+ common /restr/ varall(maxvar),mask_r,mask_theta(maxres),
+ & mask_phi(maxres),mask_side(maxres)
--- /dev/null
+ common /vectors/ uy(3,maxres),uz(3,maxres),
+ & uygrad(3,3,2,maxres),uzgrad(3,3,2,maxres)
+
--- /dev/null
+********************************************************************************
+* Settings for the program of united-residue peptide simulation in real space *
+* *
+* ------- As of 6/23/01 ----------- *
+* *
+********************************************************************************
+C Max. number of processors.
+ integer maxprocs
+ parameter (maxprocs=2048)
+C Max. number of fine-grain processors
+ integer max_fg_procs
+c parameter (max_fg_procs=maxprocs)
+ parameter (max_fg_procs=512)
+C Max. number of coarse-grain processors
+ integer max_cg_procs
+ parameter (max_cg_procs=maxprocs)
+C Max. number of AA residues
+ integer maxres
+ parameter (maxres=800)
+C Appr. max. number of interaction sites
+ integer maxres2,maxres6,mmaxres2
+ parameter (maxres2=2*maxres,maxres6=6*maxres)
+ parameter (mmaxres2=(maxres2*(maxres2+1)/2))
+C Max. number of variables
+ integer maxvar
+ parameter (maxvar=6*maxres)
+C Max. number of groups of interactions that a given SC is involved in
+ integer maxint_gr
+ parameter (maxint_gr=2)
+C Max. number of derivatives of virtual-bond and side-chain vectors in theta
+C or phi.
+ integer maxdim
+ parameter (maxdim=(maxres-1)*(maxres-2)/2)
+C Max. number of SC contacts
+ integer maxcont
+ parameter (maxcont=12*maxres)
+C Max. number of contacts per residue
+ integer maxconts
+ parameter (maxconts=maxres/4)
+c parameter (maxconts=50)
+C Number of AA types (at present only natural AA's will be handled
+ integer ntyp,ntyp1
+ parameter (ntyp=20,ntyp1=ntyp+1)
+C Max. number of types of dihedral angles & multiplicity of torsional barriers
+C and the number of terms in double torsionals
+ integer maxtor,maxterm,maxlor,maxtermd_1,maxtermd_2
+ parameter (maxtor=4,maxterm=10,maxlor=3,maxtermd_1=8,maxtermd_2=8)
+C Max. number of 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 torsional terms in SCCOR
+ integer maxterm_sccor
+ parameter (maxterm_sccor=6)
+C Max. number of lobes in SC distribution
+ integer maxlob
+ parameter (maxlob=4)
+C Max. number of S-S bridges
+ integer maxss
+ parameter (maxss=20)
+C Max. number of dihedral angle constraints
+ integer maxdih_constr
+ parameter (maxdih_constr=maxres)
+C Max. number of patterns in the pattern database
+ integer maxseq
+ parameter (maxseq=10)
+C Max. number of residues in a peptide in the database
+ integer maxres_base
+ parameter (maxres_base=10)
+C Max. number of threading attempts
+ integer maxthread
+ parameter (maxthread=20)
+C Max. number of move types in MCM
+ integer maxmovetype
+ parameter (maxmovetype=4)
+C Max. number of stored confs. in MC/MCM simulation
+ integer maxsave
+ parameter (maxsave=20)
+C Max. number of energy intervals
+ integer max_ene
+ parameter (max_ene=10)
+C Max. number of conformations in Master's cache array
+ integer max_cache
+ parameter (max_cache=10)
+C Max. number of conformations in the pool
+ integer max_pool
+ parameter (max_pool=10)
+C Number of energy components
+ integer n_ene,n_ene2
+ parameter (n_ene=23,n_ene2=2*n_ene)
+C Number of threads in deformation
+ integer max_thread,max_thread2
+ parameter (max_thread=4,max_thread2=2*max_thread)
+C Number of structures to compare at t=0
+ integer max_threadss,max_threadss2
+ parameter (max_threadss=8,max_threadss2=2*max_threadss)
+C Maxmimum number of angles per residue
+ integer mxang
+ parameter (mxang=4)
+C Maximum number of groups of angles
+ integer mxgr
+ parameter (mxgr=2*maxres)
+C Maximum number of chains
+ integer mxch
+ parameter (mxch=1)
+csaC Maximum number of generated conformations
+csa integer mxio
+csa parameter (mxio=2)
+csaC Maximum number of n7 generated conformations
+csa integer mxio2
+csa parameter (mxio2=2)
+csaC Maximum number of moves (n1-n8)
+csa integer mxmv
+csa parameter (mxmv=18)
+csaC Maximum number of seed
+csa integer max_seed
+csa parameter (max_seed=1)
+C Maximum number of timesteps for which stochastic MD matrices can be stored
+ integer maxflag_stoch
+ parameter (maxflag_stoch=0)
+C Maximum number of backbone fragments in restraining
+ integer maxfrag_back
+ parameter (maxfrag_back=4)
+C Maximum number of SC local term fitting function coefficiants
+ integer maxsccoef
+ parameter (maxsccoef=65)
+C Maximum number of terms in SC bond-stretching potential
+ integer maxbondterm
+ parameter (maxbondterm=3)
+C Maximum number of conformation stored in cache on each CPU before sending
+C to master; depends on nstex / ntwx ratio
+ integer max_cache_traj
+ parameter (max_cache_traj=10)
+C Nose-Hoover chain - chain length and order of Yoshida algorithm
+ integer maxmnh,maxyosh
+ parameter(maxmnh=10,maxyosh=5)
--- /dev/null
+********************************************************************************
+* Settings for the program of united-residue peptide simulation in real space *
+* *
+* ------- As of 6/23/01 ----------- *
+* *
+********************************************************************************
+C Max. number of processors.
+ parameter (maxprocs=2100)
+C Max. number of fine-grain processors
+ parameter (max_fg_procs=maxprocs)
+C Max. number of coarse-grain processors
+ parameter (max_cg_procs=maxprocs)
+C Max. number of AA residues
+ parameter (maxres=150)
+C Appr. max. number of interaction sites
+ parameter (maxres2=2*maxres,maxres6=6*maxres)
+ parameter (mmaxres6=(maxres6*(maxres6+1)/2))
+C Max. number of variables
+ parameter (maxvar=6*maxres)
+C Max. number of groups of interactions that a given SC is involved in
+ parameter (maxint_gr=2)
+C Max. number of derivatives of virtual-bond and side-chain vectors in theta
+C or phi.
+ parameter (maxdim=(maxres-1)*(maxres-2)/2)
+C Max. number of SC contacts
+ parameter (maxcont=12*maxres)
+C Max. number of contacts per residue
+ parameter (maxconts=maxres)
+C Number of AA types (at present only natural AA's will be handled
+ parameter (ntyp=20,ntyp1=ntyp+1)
+C Max. number of types of dihedral angles & multiplicity of torsional barriers
+C and the number of terms in double torsionals
+ parameter (maxtor=4,maxterm=10,maxlor=3,maxtermd_1=8,maxtermd_2=8)
+C Max. number of lobes in SC distribution
+ parameter (maxlob=4)
+C Max. number of S-S bridges
+ parameter (maxss=20)
+C Max. number of dihedral angle constraints
+ parameter (maxdih_constr=maxres)
+C Max. number of patterns in the pattern database
+ parameter (maxseq=10)
+C Max. number of residues in a peptide in the database
+ parameter (maxres_base=10)
+C Max. number of threading attempts
+ parameter (maxthread=20)
+C Max. number of move types in MCM
+ parameter (maxmovetype=4)
+C Max. number of stored confs. in MC/MCM simulation
+ parameter (maxsave=20)
+C Max. number of energy intervals
+ parameter (max_ene=10)
+C Max. number of conformations in Master's cache array
+ parameter (max_cache=10)
+C Max. number of conformations in the pool
+ parameter (max_pool=10)
+C Number of energy components
+ parameter (n_ene=21,n_ene2=2*n_ene)
+C Number of threads in deformation
+ integer max_thread,max_thread2
+ parameter (max_thread=4,max_thread2=2*max_thread)
+C Number of structures to compare at t=0
+ integer max_threadss,max_threadss2
+ parameter (max_threadss=8,max_threadss2=2*max_threadss)
+C Maxmimum number of angles per residue
+ parameter (mxang=4)
+C Maximum number of groups of angles
+ parameter (mxgr=2*maxres)
+C Maximum number of chains
+ parameter (mxch=1)
+C Maximum number of generated conformations
+ parameter (mxio=2)
+C Maximum number of n7 generated conformations
+ parameter (mxio2=2)
+C Maximum number of moves (n1-n8)
+ parameter (mxmv=18)
+C Maximum number of seed
+ parameter (max_seed=1)
+C Maximum number of timesteps for which stochastic MD matrices can be stored
+ integer maxflag_stoch
+ parameter (maxflag_stoch=0)
--- /dev/null
+********************************************************************************
+* Settings for the program of united-residue peptide simulation in real space *
+* *
+* ------- As of 6/23/01 ----------- *
+* *
+********************************************************************************
+C Max. number of processors.
+ parameter (maxprocs=4100)
+C Max. number of fine-grain processors
+ parameter (max_fg_procs=maxprocs)
+C Max. number of coarse-grain processors
+ parameter (max_cg_procs=maxprocs)
+C Max. number of AA residues
+ parameter (maxres=150)
+C Appr. max. number of interaction sites
+ parameter (maxres2=2*maxres,maxres6=6*maxres)
+ parameter (mmaxres6=(maxres6*(maxres6+1)/2))
+C Max. number of variables
+ parameter (maxvar=6*maxres)
+C Max. number of groups of interactions that a given SC is involved in
+ parameter (maxint_gr=2)
+C Max. number of derivatives of virtual-bond and side-chain vectors in theta
+C or phi.
+ parameter (maxdim=(maxres-1)*(maxres-2)/2)
+C Max. number of SC contacts
+ parameter (maxcont=12*maxres)
+C Max. number of contacts per residue
+ parameter (maxconts=maxres)
+C Number of AA types (at present only natural AA's will be handled
+ parameter (ntyp=20,ntyp1=ntyp+1)
+C Max. number of types of dihedral angles & multiplicity of torsional barriers
+C and the number of terms in double torsionals
+ parameter (maxtor=4,maxterm=10,maxlor=3,maxtermd_1=8,maxtermd_2=8)
+C Max. number of lobes in SC distribution
+ parameter (maxlob=4)
+C Max. number of S-S bridges
+ parameter (maxss=20)
+C Max. number of dihedral angle constraints
+ parameter (maxdih_constr=maxres)
+C Max. number of patterns in the pattern database
+ parameter (maxseq=10)
+C Max. number of residues in a peptide in the database
+ parameter (maxres_base=10)
+C Max. number of threading attempts
+ parameter (maxthread=20)
+C Max. number of move types in MCM
+ parameter (maxmovetype=4)
+C Max. number of stored confs. in MC/MCM simulation
+ parameter (maxsave=20)
+C Max. number of energy intervals
+ parameter (max_ene=10)
+C Max. number of conformations in Master's cache array
+ parameter (max_cache=10)
+C Max. number of conformations in the pool
+ parameter (max_pool=10)
+C Number of energy components
+ parameter (n_ene=21,n_ene2=2*n_ene)
+C Number of threads in deformation
+ integer max_thread,max_thread2
+ parameter (max_thread=4,max_thread2=2*max_thread)
+C Number of structures to compare at t=0
+ integer max_threadss,max_threadss2
+ parameter (max_threadss=8,max_threadss2=2*max_threadss)
+C Maxmimum number of angles per residue
+ parameter (mxang=4)
+C Maximum number of groups of angles
+ parameter (mxgr=2*maxres)
+C Maximum number of chains
+ parameter (mxch=1)
+C Maximum number of generated conformations
+ parameter (mxio=2)
+C Maximum number of n7 generated conformations
+ parameter (mxio2=2)
+C Maximum number of moves (n1-n8)
+ parameter (mxmv=18)
+C Maximum number of seed
+ parameter (max_seed=1)
+C Maximum number of timesteps for which stochastic MD matrices can be stored
+ integer maxflag_stoch
+ parameter (maxflag_stoch=0)
--- /dev/null
+ subroutine MD
+c------------------------------------------------
+c The driver for molecular dynamics subroutines
+c------------------------------------------------
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include "mpif.h"
+ integer IERROR,ERRCODE
+#endif
+ include 'COMMON.SETUP'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+#ifndef LANG0
+ include 'COMMON.LANGEVIN'
+#else
+ include 'COMMON.LANGEVIN.lang0'
+#endif
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ include 'COMMON.TIME1'
+ double precision cm(3),L(3),vcm(3)
+#ifdef VOUT
+ double precision v_work(maxres6),v_transf(maxres6)
+#endif
+ integer ilen,rstcount
+ external ilen
+ character*50 tytul
+ common /gucio/ cm
+ integer itime
+c
+#ifdef MPI
+ if (ilen(tmpdir).gt.0)
+ & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_"
+ & //liczba(:ilen(liczba))//'.rst')
+#else
+ if (ilen(tmpdir).gt.0)
+ & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_"//'.rst')
+#endif
+ t_MDsetup=0.0d0
+ t_langsetup=0.0d0
+ t_MD=0.0d0
+ t_enegrad=0.0d0
+ t_sdsetup=0.0d0
+ write (iout,'(20(1h=),a20,20(1h=))') "MD calculation started"
+#ifdef MPI
+ tt0=MPI_Wtime()
+#else
+ tt0 = tcpu()
+#endif
+c Determine the inverse of the inertia matrix.
+ call setup_MD_matrices
+c Initialize MD
+ call init_MD
+#ifdef MPI
+ t_MDsetup = MPI_Wtime()-tt0
+#else
+ t_MDsetup = tcpu()-tt0
+#endif
+ rstcount=0
+c Entering the MD loop
+#ifdef MPI
+ tt0 = MPI_Wtime()
+#else
+ tt0 = tcpu()
+#endif
+ if (lang.eq.2 .or. lang.eq.3) then
+#ifndef LANG0
+ call setup_fricmat
+ if (lang.eq.2) then
+ call sd_verlet_p_setup
+ else
+ call sd_verlet_ciccotti_setup
+ endif
+ do i=1,dimen3
+ do j=1,dimen3
+ pfric0_mat(i,j,0)=pfric_mat(i,j)
+ afric0_mat(i,j,0)=afric_mat(i,j)
+ vfric0_mat(i,j,0)=vfric_mat(i,j)
+ prand0_mat(i,j,0)=prand_mat(i,j)
+ vrand0_mat1(i,j,0)=vrand_mat1(i,j)
+ vrand0_mat2(i,j,0)=vrand_mat2(i,j)
+ enddo
+ enddo
+ flag_stoch(0)=.true.
+ do i=1,maxflag_stoch
+ flag_stoch(i)=.false.
+ enddo
+#else
+ write (iout,*)
+ & "LANG=2 or 3 NOT SUPPORTED. Recompile without -DLANG0"
+#ifdef MPI
+ call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE)
+#endif
+ stop
+#endif
+ else if (lang.eq.1 .or. lang.eq.4) then
+ call setup_fricmat
+ endif
+#ifdef MPI
+ t_langsetup=MPI_Wtime()-tt0
+ tt0=MPI_Wtime()
+#else
+ t_langsetup=tcpu()-tt0
+ tt0=tcpu()
+#endif
+ do itime=1,n_timestep
+ rstcount=rstcount+1
+ if (lang.gt.0 .and. surfarea .and.
+ & mod(itime,reset_fricmat).eq.0) then
+ if (lang.eq.2 .or. lang.eq.3) then
+#ifndef LANG0
+ call setup_fricmat
+ if (lang.eq.2) then
+ call sd_verlet_p_setup
+ else
+ call sd_verlet_ciccotti_setup
+ endif
+ do i=1,dimen3
+ do j=1,dimen3
+ pfric0_mat(i,j,0)=pfric_mat(i,j)
+ afric0_mat(i,j,0)=afric_mat(i,j)
+ vfric0_mat(i,j,0)=vfric_mat(i,j)
+ prand0_mat(i,j,0)=prand_mat(i,j)
+ vrand0_mat1(i,j,0)=vrand_mat1(i,j)
+ vrand0_mat2(i,j,0)=vrand_mat2(i,j)
+ enddo
+ enddo
+ flag_stoch(0)=.true.
+ do i=1,maxflag_stoch
+ flag_stoch(i)=.false.
+ enddo
+#endif
+ else if (lang.eq.1 .or. lang.eq.4) then
+ call setup_fricmat
+ endif
+ write (iout,'(a,i10)')
+ & "Friction matrix reset based on surface area, itime",itime
+ endif
+ if (reset_vel .and. tbf .and. lang.eq.0
+ & .and. mod(itime,count_reset_vel).eq.0) then
+ call random_vel
+ write(iout,'(a,f20.2)')
+ & "Velocities reset to random values, time",totT
+ do i=0,2*nres
+ do j=1,3
+ d_t_old(j,i)=d_t(j,i)
+ enddo
+ enddo
+ endif
+ if (reset_moment .and. mod(itime,count_reset_moment).eq.0) then
+ call inertia_tensor
+ call vcm_vel(vcm)
+ do j=1,3
+ d_t(j,0)=d_t(j,0)-vcm(j)
+ enddo
+ call kinetic(EK)
+ kinetic_T=2.0d0/(dimen3*Rb)*EK
+ scalfac=dsqrt(T_bath/kinetic_T)
+ write(iout,'(a,f20.2)') "Momenta zeroed out, time",totT
+ do i=0,2*nres
+ do j=1,3
+ d_t_old(j,i)=scalfac*d_t(j,i)
+ enddo
+ enddo
+ endif
+ if (lang.ne.4) then
+ if (RESPA) then
+c Time-reversible RESPA algorithm
+c (Tuckerman et al., J. Chem. Phys., 97, 1990, 1992)
+ call RESPA_step(itime)
+ else
+c Variable time step algorithm.
+ call velverlet_step(itime)
+ endif
+ else
+#ifdef BROWN
+ call brown_step(itime)
+#else
+ print *,"Brown dynamics not here!"
+#ifdef MPI
+ call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE)
+#endif
+ stop
+#endif
+ endif
+ if (ntwe.ne.0) then
+ if (mod(itime,ntwe).eq.0) call statout(itime)
+#ifdef VOUT
+ do j=1,3
+ v_work(j)=d_t(j,0)
+ enddo
+ ind=3
+ do i=nnt,nct-1
+ do j=1,3
+ ind=ind+1
+ v_work(ind)=d_t(j,i)
+ enddo
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ do j=1,3
+ ind=ind+1
+ v_work(ind)=d_t(j,i+nres)
+ enddo
+ endif
+ enddo
+
+ write (66,'(80f10.5)')
+ & ((d_t(j,i),j=1,3),i=0,nres-1),((d_t(j,i+nres),j=1,3),i=1,nres)
+ do i=1,ind
+ v_transf(i)=0.0d0
+ do j=1,ind
+ v_transf(i)=v_transf(i)+gvec(j,i)*v_work(j)
+ enddo
+ v_transf(i)= v_transf(i)*dsqrt(geigen(i))
+ enddo
+ write (67,'(80f10.5)') (v_transf(i),i=1,ind)
+#endif
+ endif
+ if (mod(itime,ntwx).eq.0) then
+ write (tytul,'("time",f8.2)') totT
+ if(mdpdb) then
+ call pdbout(potE,tytul,ipdb)
+ else
+ call cartout(totT)
+ endif
+ endif
+ if (rstcount.eq.1000.or.itime.eq.n_timestep) then
+ open(irest2,file=rest2name,status='unknown')
+ write(irest2,*) totT,EK,potE,totE,t_bath
+ do i=1,2*nres
+ write (irest2,'(3e15.5)') (d_t(j,i),j=1,3)
+ enddo
+ do i=1,2*nres
+ write (irest2,'(3e15.5)') (dc(j,i),j=1,3)
+ enddo
+ close(irest2)
+ rstcount=0
+ endif
+ enddo
+#ifdef MPI
+ t_MD=MPI_Wtime()-tt0
+#else
+ t_MD=tcpu()-tt0
+#endif
+ write (iout,'(//35(1h=),a10,35(1h=)/10(/a40,1pe15.5))')
+ & ' Timing ',
+ & 'MD calculations setup:',t_MDsetup,
+ & 'Energy & gradient evaluation:',t_enegrad,
+ & 'Stochastic MD setup:',t_langsetup,
+ & 'Stochastic MD step setup:',t_sdsetup,
+ & 'MD steps:',t_MD
+ write (iout,'(/28(1h=),a25,27(1h=))')
+ & ' End of MD calculation '
+#ifdef TIMING_ENE
+ write (iout,*) "time for etotal",t_etotal," elong",t_elong,
+ & " eshort",t_eshort
+ write (iout,*) "time_fric",time_fric," time_stoch",time_stoch,
+ & " time_fricmatmult",time_fricmatmult," time_fsample ",
+ & time_fsample
+#endif
+ return
+ end
+c-------------------------------------------------------------------------------
+ subroutine velverlet_step(itime)
+c-------------------------------------------------------------------------------
+c Perform a single velocity Verlet step; the time step can be rescaled if
+c increments in accelerations exceed the threshold
+c-------------------------------------------------------------------------------
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+ integer ierror,ierrcode
+#endif
+ include 'COMMON.SETUP'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+#ifndef LANG0
+ include 'COMMON.LANGEVIN'
+#else
+ include 'COMMON.LANGEVIN.lang0'
+#endif
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ include 'COMMON.TIME1'
+ include 'COMMON.MUCA'
+ double precision vcm(3),incr(3)
+ double precision cm(3),L(3)
+ integer ilen,count,rstcount
+ external ilen
+ character*50 tytul
+ integer maxcount_scale /20/
+ common /gucio/ cm
+ double precision stochforcvec(MAXRES6)
+ common /stochcalc/ stochforcvec
+ integer itime
+ logical scale
+ double precision HNose1,HNose,HNose_nh,H,vtnp(maxres6)
+ double precision vtnp_(maxres6),vtnp_a(maxres6)
+c
+ scale=.true.
+ icount_scale=0
+ if (lang.eq.1) then
+ call sddir_precalc
+ else if (lang.eq.2 .or. lang.eq.3) then
+#ifndef LANG0
+ call stochastic_force(stochforcvec)
+#else
+ write (iout,*)
+ & "LANG=2 or 3 NOT SUPPORTED. Recompile without -DLANG0"
+#ifdef MPI
+ call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE)
+#endif
+ stop
+#endif
+ endif
+ itime_scal=0
+ do while (scale)
+ icount_scale=icount_scale+1
+ if (icount_scale.gt.maxcount_scale) then
+ write (iout,*)
+ & "ERROR: too many attempts at scaling down the time step. ",
+ & "amax=",amax,"epdrift=",epdrift,
+ & "damax=",damax,"edriftmax=",edriftmax,
+ & "d_time=",d_time
+ call flush(iout)
+#ifdef MPI
+ call MPI_Abort(MPI_COMM_WORLD,IERROR,IERRCODE)
+#endif
+ stop
+ endif
+c First step of the velocity Verlet algorithm
+ if (lang.eq.2) then
+#ifndef LANG0
+ call sd_verlet1
+#endif
+ else if (lang.eq.3) then
+#ifndef LANG0
+ call sd_verlet1_ciccotti
+#endif
+ else if (lang.eq.1) then
+ call sddir_verlet1
+ else if (tnp1) then
+ call tnp1_step1
+ else if (tnp) then
+ call tnp_step1
+ else
+ if (tnh) then
+ call nhcint(EK,scale_nh,wdti,wdti2,wdti4,wdti8)
+ do i=0,2*nres
+ do j=1,3
+ d_t_old(j,i)=d_t_old(j,i)*scale_nh
+ enddo
+ enddo
+ endif
+ call verlet1
+ endif
+c Build the chain from the newly calculated coordinates
+ call chainbuild_cart
+ if (rattle) call rattle1
+ if (ntwe.ne.0) then
+ if (large.and. mod(itime,ntwe).eq.0) then
+ write (iout,*) "Cartesian and internal coordinates: step 1"
+ call cartprint
+ call intout
+ write (iout,*) "dC"
+ do i=0,nres
+ write (iout,'(i3,3f10.5,3x,3f10.5)') i,(dc(j,i),j=1,3),
+ & (dc(j,i+nres),j=1,3)
+ enddo
+ write (iout,*) "Accelerations"
+ do i=0,nres
+ write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3),
+ & (d_a(j,i+nres),j=1,3)
+ enddo
+ write (iout,*) "Velocities, step 1"
+ do i=0,nres
+ write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),
+ & (d_t(j,i+nres),j=1,3)
+ enddo
+ endif
+ endif
+#ifdef MPI
+ tt0 = MPI_Wtime()
+#else
+ tt0 = tcpu()
+#endif
+c Calculate energy and forces
+ call zerograd
+ call etotal(potEcomp)
+#ifdef TIMING_ENE
+#ifdef MPI
+ t_etotal=t_etotal+MPI_Wtime()-tt0
+#else
+ t_etotal=t_etotal+tcpu()-tt0
+#endif
+#endif
+ E_old=potE
+ potE=potEcomp(0)-potEcomp(20)
+ call cartgrad
+c Get the new accelerations
+ call lagrangian
+#ifdef MPI
+ t_enegrad=t_enegrad+MPI_Wtime()-tt0
+#else
+ t_enegrad=t_enegrad+tcpu()-tt0
+#endif
+c Determine maximum acceleration and scale down the timestep if needed
+ call max_accel
+ amax=amax/(itime_scal+1)**2
+ call predict_edrift(epdrift)
+ if (amax/(itime_scal+1).gt.damax .or. epdrift.gt.edriftmax) then
+c Maximum acceleration or maximum predicted energy drift exceeded, rescale the time step
+ scale=.true.
+ ifac_time=dmax1(dlog(amax/damax),dlog(epdrift/edriftmax))
+ & /dlog(2.0d0)+1
+ itime_scal=itime_scal+ifac_time
+c fac_time=dmin1(damax/amax,0.5d0)
+ fac_time=0.5d0**ifac_time
+ d_time=d_time*fac_time
+ if (lang.eq.2 .or. lang.eq.3) then
+#ifndef LANG0
+c write (iout,*) "Calling sd_verlet_setup: 1"
+c Rescale the stochastic forces and recalculate or restore
+c the matrices of tinker integrator
+ if (itime_scal.gt.maxflag_stoch) then
+ if (large) write (iout,'(a,i5,a)')
+ & "Calculate matrices for stochastic step;",
+ & " itime_scal ",itime_scal
+ if (lang.eq.2) then
+ call sd_verlet_p_setup
+ else
+ call sd_verlet_ciccotti_setup
+ endif
+ write (iout,'(2a,i3,a,i3,1h.)')
+ & "Warning: cannot store matrices for stochastic",
+ & " integration because the index",itime_scal,
+ & " is greater than",maxflag_stoch
+ write (iout,'(2a)')"Increase MAXFLAG_STOCH or use direct",
+ & " integration Langevin algorithm for better efficiency."
+ else if (flag_stoch(itime_scal)) then
+ if (large) write (iout,'(a,i5,a,l1)')
+ & "Restore matrices for stochastic step; itime_scal ",
+ & itime_scal," flag ",flag_stoch(itime_scal)
+ do i=1,dimen3
+ do j=1,dimen3
+ pfric_mat(i,j)=pfric0_mat(i,j,itime_scal)
+ afric_mat(i,j)=afric0_mat(i,j,itime_scal)
+ vfric_mat(i,j)=vfric0_mat(i,j,itime_scal)
+ prand_mat(i,j)=prand0_mat(i,j,itime_scal)
+ vrand_mat1(i,j)=vrand0_mat1(i,j,itime_scal)
+ vrand_mat2(i,j)=vrand0_mat2(i,j,itime_scal)
+ enddo
+ enddo
+ else
+ if (large) write (iout,'(2a,i5,a,l1)')
+ & "Calculate & store matrices for stochastic step;",
+ & " itime_scal ",itime_scal," flag ",flag_stoch(itime_scal)
+ if (lang.eq.2) then
+ call sd_verlet_p_setup
+ else
+ call sd_verlet_ciccotti_setup
+ endif
+ flag_stoch(ifac_time)=.true.
+ do i=1,dimen3
+ do j=1,dimen3
+ pfric0_mat(i,j,itime_scal)=pfric_mat(i,j)
+ afric0_mat(i,j,itime_scal)=afric_mat(i,j)
+ vfric0_mat(i,j,itime_scal)=vfric_mat(i,j)
+ prand0_mat(i,j,itime_scal)=prand_mat(i,j)
+ vrand0_mat1(i,j,itime_scal)=vrand_mat1(i,j)
+ vrand0_mat2(i,j,itime_scal)=vrand_mat2(i,j)
+ enddo
+ enddo
+ endif
+ fac_time=1.0d0/dsqrt(fac_time)
+ do i=1,dimen3
+ stochforcvec(i)=fac_time*stochforcvec(i)
+ enddo
+#endif
+ else if (lang.eq.1) then
+c Rescale the accelerations due to stochastic forces
+ fac_time=1.0d0/dsqrt(fac_time)
+ do i=1,dimen3
+ d_as_work(i)=d_as_work(i)*fac_time
+ enddo
+ endif
+ if (large) write (iout,'(a,i10,a,f8.6,a,i3,a,i3)')
+ & "itime",itime," Timestep scaled down to ",
+ & d_time," ifac_time",ifac_time," itime_scal",itime_scal
+ else
+c Second step of the velocity Verlet algorithm
+ if (lang.eq.2) then
+#ifndef LANG0
+ call sd_verlet2
+#endif
+ else if (lang.eq.3) then
+#ifndef LANG0
+ call sd_verlet2_ciccotti
+#endif
+ else if (lang.eq.1) then
+ call sddir_verlet2
+ else if (tnp1) then
+ call tnp1_step2
+ else if (tnp) then
+ call tnp_step2
+ else
+ call verlet2
+ if (tnh) then
+ call kinetic(EK)
+ call nhcint(EK,scale_nh,wdti,wdti2,wdti4,wdti8)
+ do i=0,2*nres
+ do j=1,3
+ d_t(j,i)=d_t(j,i)*scale_nh
+ enddo
+ enddo
+ endif
+ endif
+ if (rattle) call rattle2
+ totT=totT+d_time
+ if (d_time.ne.d_time0) then
+ d_time=d_time0
+#ifndef LANG0
+ if (lang.eq.2 .or. lang.eq.3) then
+ if (large) write (iout,'(a)')
+ & "Restore original matrices for stochastic step"
+c write (iout,*) "Calling sd_verlet_setup: 2"
+c Restore the matrices of tinker integrator if the time step has been restored
+ do i=1,dimen3
+ do j=1,dimen3
+ pfric_mat(i,j)=pfric0_mat(i,j,0)
+ afric_mat(i,j)=afric0_mat(i,j,0)
+ vfric_mat(i,j)=vfric0_mat(i,j,0)
+ prand_mat(i,j)=prand0_mat(i,j,0)
+ vrand_mat1(i,j)=vrand0_mat1(i,j,0)
+ vrand_mat2(i,j)=vrand0_mat2(i,j,0)
+ enddo
+ enddo
+ endif
+#endif
+ endif
+ scale=.false.
+ endif
+ enddo
+c Calculate the kinetic and the total energy and the kinetic temperature
+ if (tnp .or. tnp1) then
+ do i=0,2*nres
+ do j=1,3
+ d_t_old(j,i)=d_t(j,i)
+ d_t(j,i)=d_t(j,i)/s_np
+ enddo
+ enddo
+ endif
+ call kinetic(EK)
+ totE=EK+potE
+c diagnostics
+c call kinetic1(EK1)
+c write (iout,*) "step",itime," EK",EK," EK1",EK1
+c end diagnostics
+c Couple the system to Berendsen bath if needed
+ if (tbf .and. lang.eq.0) then
+ call verlet_bath
+ endif
+ kinetic_T=2.0d0/(dimen3*Rb)*EK
+c Backup the coordinates, velocities, and accelerations
+ do i=0,2*nres
+ do j=1,3
+ dc_old(j,i)=dc(j,i)
+ if(.not.(tnp .or. tnp1)) d_t_old(j,i)=d_t(j,i)
+ d_a_old(j,i)=d_a(j,i)
+ enddo
+ enddo
+ if (ntwe.ne.0) then
+ if (mod(itime,ntwe).eq.0) then
+
+ if(tnp .or. tnp1) then
+ HNose1=Hnose(EK,s_np,potE,pi_np,Q_np,t_bath,dimen3)
+ H=(HNose1-H0)*s_np
+cd write (iout,'(a,10f)') "hhh",EK,s_np,potE,pi_np,H0
+cd & ,EK+potE+pi_np**2/(2*Q_np)+dimen3*0.001986d0*t_bath*log(s_np)
+cd write (iout,*) "HHH H=",H,abs(HNose1-H0)/H0
+ hhh=h
+ endif
+
+ if(tnh) then
+ HNose1=Hnose_nh(EK,potE)
+ H=HNose1-H0
+ hhh=h
+cd write (iout,*) "HHH H=",H,abs(HNose1-H0)/H0
+ endif
+
+ if (large) then
+ itnp=0
+ do j=1,3
+ itnp=itnp+1
+ vtnp(itnp)=d_t(j,0)
+ enddo
+ do i=nnt,nct-1
+ do j=1,3
+ itnp=itnp+1
+ vtnp(itnp)=d_t(j,i)
+ enddo
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ inres=i+nres
+ do j=1,3
+ itnp=itnp+1
+ vtnp(itnp)=d_t(j,inres)
+ enddo
+ endif
+ enddo
+
+c Transform velocities from UNRES coordinate space to cartesian and Gvec
+c eigenvector space
+
+ do i=1,dimen3
+ vtnp_(i)=0.0d0
+ vtnp_a(i)=0.0d0
+ do j=1,dimen3
+ vtnp_(i)=vtnp_(i)+Gvec(j,i)*vtnp(j)
+ vtnp_a(i)=vtnp_a(i)+A(i,j)*vtnp(j)
+ enddo
+ vtnp_(i)=vtnp_(i)*dsqrt(geigen(i))
+ enddo
+
+ do i=1,dimen3
+ write (iout,'("WWW",i3,3f10.5)') i,vtnp(i),vtnp_(i),vtnp_a(i)
+ enddo
+
+ write (iout,*) "Velocities, step 2"
+ do i=0,nres
+ write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),
+ & (d_t(j,i+nres),j=1,3)
+ enddo
+ endif
+ endif
+ endif
+ return
+ end
+c-------------------------------------------------------------------------------
+ subroutine RESPA_step(itime)
+c-------------------------------------------------------------------------------
+c Perform a single RESPA step.
+c-------------------------------------------------------------------------------
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+ integer IERROR,ERRCODE
+#endif
+ include 'COMMON.SETUP'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+#ifndef LANG0
+ include 'COMMON.LANGEVIN'
+#else
+ include 'COMMON.LANGEVIN.lang0'
+#endif
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ include 'COMMON.TIME1'
+ double precision energia_short(0:n_ene),
+ & energia_long(0:n_ene)
+ double precision cm(3),L(3),vcm(3),incr(3)
+ double precision dc_old0(3,0:maxres2),d_t_old0(3,0:maxres2),
+ & d_a_old0(3,0:maxres2)
+ integer ilen,count,rstcount
+ external ilen
+ character*50 tytul
+ integer maxcount_scale /10/
+ common /gucio/ cm,energia_short
+ double precision stochforcvec(MAXRES6)
+ common /stochcalc/ stochforcvec
+ integer itime
+ logical scale
+ double precision vtnp(maxres6), vtnp_(maxres6), vtnp_a(maxres6)
+ common /cipiszcze/ itt
+ itt=itime
+ if (ntwe.ne.0) then
+ if (large.and. mod(itime,ntwe).eq.0) then
+ write (iout,*) "***************** RESPA itime",itime
+ write (iout,*) "Cartesian and internal coordinates: step 0"
+c call cartprint
+ call pdbout(0.0d0,"cipiszcze",iout)
+ call intout
+ write (iout,*) "Accelerations from long-range forces"
+ do i=0,nres
+ write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3),
+ & (d_a(j,i+nres),j=1,3)
+ enddo
+ write (iout,*) "Velocities, step 0"
+ do i=0,nres
+ write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),
+ & (d_t(j,i+nres),j=1,3)
+ enddo
+ endif
+ endif
+c
+c Perform the initial RESPA step (increment velocities)
+c write (iout,*) "*********************** RESPA ini"
+ if (tnp1) then
+ call tnp_respa_step1
+ else if (tnp) then
+ call tnp_respa_step1
+ else
+ if (tnh.and..not.xiresp) then
+ call nhcint(EK,scale_nh,wdti,wdti2,wdti4,wdti8)
+ do i=0,2*nres
+ do j=1,3
+ d_t(j,i)=d_t(j,i)*scale_nh
+ enddo
+ enddo
+ endif
+ call RESPA_vel
+ endif
+
+cd if(tnp .or. tnp1) then
+cd write (iout,'(a,3f)') "EE1 NP S, pi",totT, s_np, pi_np
+cd endif
+
+ if (ntwe.ne.0) then
+ if (mod(itime,ntwe).eq.0 .and. large) then
+ write (iout,*) "Velocities, end"
+ do i=0,nres
+ write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),
+ & (d_t(j,i+nres),j=1,3)
+ enddo
+ endif
+ endif
+c Compute the short-range forces
+#ifdef MPI
+ tt0 =MPI_Wtime()
+#else
+ tt0 = tcpu()
+#endif
+C 7/2/2009 commented out
+c call zerograd
+c call etotal_short(energia_short)
+ if (tnp.or.tnp1) potE=energia_short(0)
+c call cartgrad
+c call lagrangian
+C 7/2/2009 Copy accelerations due to short-lange forces from previous MD step
+ do i=0,2*nres
+ do j=1,3
+ d_a(j,i)=d_a_short(j,i)
+ enddo
+ enddo
+ if (ntwe.ne.0) then
+ if (large.and. mod(itime,ntwe).eq.0) then
+ write (iout,*) "energia_short",energia_short(0)
+ write (iout,*) "Accelerations from short-range forces"
+ do i=0,nres
+ write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3),
+ & (d_a(j,i+nres),j=1,3)
+ enddo
+ endif
+ endif
+#ifdef MPI
+ t_enegrad=t_enegrad+MPI_Wtime()-tt0
+#else
+ t_enegrad=t_enegrad+tcpu()-tt0
+#endif
+ do i=0,2*nres
+ do j=1,3
+ dc_old(j,i)=dc(j,i)
+ if(.not.(tnp .or. tnp1)) d_t_old(j,i)=d_t(j,i)
+ d_a_old(j,i)=d_a(j,i)
+ enddo
+ enddo
+c 6/30/08 A-MTS: attempt at increasing the split number
+ do i=0,2*nres
+ do j=1,3
+ dc_old0(j,i)=dc_old(j,i)
+ d_t_old0(j,i)=d_t_old(j,i)
+ d_a_old0(j,i)=d_a_old(j,i)
+ enddo
+ enddo
+ if (ntime_split.gt.ntime_split0) ntime_split=ntime_split/2
+ if (ntime_split.lt.ntime_split0) ntime_split=ntime_split0
+c
+ scale=.true.
+ d_time0=d_time
+ do while (scale)
+
+ scale=.false.
+c write (iout,*) "itime",itime," ntime_split",ntime_split
+c Split the time step
+ d_time=d_time0/ntime_split
+c Perform the short-range RESPA steps (velocity Verlet increments of
+c positions and velocities using short-range forces)
+c write (iout,*) "*********************** RESPA split"
+ do itsplit=1,ntime_split
+ if (lang.eq.1) then
+ call sddir_precalc
+ else if (lang.eq.2 .or. lang.eq.3) then
+#ifndef LANG0
+ call stochastic_force(stochforcvec)
+#else
+ write (iout,*)
+ & "LANG=2 or 3 NOT SUPPORTED. Recompile without -DLANG0"
+#ifdef MPI
+ call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE)
+#endif
+ stop
+#endif
+ endif
+c First step of the velocity Verlet algorithm
+ if (lang.eq.2) then
+#ifndef LANG0
+ call sd_verlet1
+#endif
+ else if (lang.eq.3) then
+#ifndef LANG0
+ call sd_verlet1_ciccotti
+#endif
+ else if (lang.eq.1) then
+ call sddir_verlet1
+ else if (tnp1) then
+ call tnp1_respa_i_step1
+ else if (tnp) then
+ call tnp_respa_i_step1
+ else
+ if (tnh.and.xiresp) then
+ call kinetic(EK)
+ call nhcint(EK,scale_nh,wdtii,wdtii2,wdtii4,wdtii8)
+ do i=0,2*nres
+ do j=1,3
+ d_t_old(j,i)=d_t_old(j,i)*scale_nh
+ enddo
+ enddo
+cd write(iout,*) "SSS1",itsplit,EK,scale_nh
+ endif
+ call verlet1
+ endif
+c Build the chain from the newly calculated coordinates
+ call chainbuild_cart
+ if (rattle) call rattle1
+ if (ntwe.ne.0) then
+ if (large.and. mod(itime,ntwe).eq.0) then
+ write (iout,*) "***** ITSPLIT",itsplit
+ write (iout,*) "Cartesian and internal coordinates: step 1"
+ call pdbout(0.0d0,"cipiszcze",iout)
+c call cartprint
+ call intout
+ write (iout,*) "Velocities, step 1"
+ do i=0,nres
+ write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),
+ & (d_t(j,i+nres),j=1,3)
+ enddo
+ endif
+ endif
+#ifdef MPI
+ tt0 = MPI_Wtime()
+#else
+ tt0 = tcpu()
+#endif
+c Calculate energy and forces
+ call zerograd
+ call etotal_short(energia_short)
+ E_old=potE
+ potE=energia_short(0)
+#ifdef TIMING_ENE
+#ifdef MPI
+ t_eshort=t_eshort+MPI_Wtime()-tt0
+#else
+ t_eshort=t_eshort+tcpu()-tt0
+#endif
+#endif
+ call cartgrad
+c Get the new accelerations
+ call lagrangian
+C 7/2/2009 Copy accelerations due to short-lange forces to an auxiliary array
+ do i=0,2*nres
+ do j=1,3
+ d_a_short(j,i)=d_a(j,i)
+ enddo
+ enddo
+ if (ntwe.ne.0) then
+ if (large.and. mod(itime,ntwe).eq.0) then
+ write (iout,*)"energia_short",energia_short(0)
+ write (iout,*) "Accelerations from short-range forces"
+ do i=0,nres
+ write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3),
+ & (d_a(j,i+nres),j=1,3)
+ enddo
+ endif
+ endif
+c 6/30/08 A-MTS
+c Determine maximum acceleration and scale down the timestep if needed
+ call max_accel
+ amax=amax/ntime_split**2
+ call predict_edrift(epdrift)
+ if (ntwe.gt.0 .and. large .and. mod(itime,ntwe).eq.0)
+ & write (iout,*) "amax",amax," damax",damax,
+ & " epdrift",epdrift," epdriftmax",epdriftmax
+c Exit loop and try with increased split number if the change of
+c acceleration is too big
+ if (amax.gt.damax .or. epdrift.gt.edriftmax) then
+ if (ntime_split.lt.maxtime_split) then
+ scale=.true.
+ ntime_split=ntime_split*2
+ do i=0,2*nres
+ do j=1,3
+ dc_old(j,i)=dc_old0(j,i)
+ d_t_old(j,i)=d_t_old0(j,i)
+ d_a_old(j,i)=d_a_old0(j,i)
+ enddo
+ enddo
+ write (iout,*) "acceleration/energy drift too large",amax,
+ & epdrift," split increased to ",ntime_split," itime",itime,
+ & " itsplit",itsplit
+ exit
+ else
+ write (iout,*)
+ & "Uh-hu. Bumpy landscape. Maximum splitting number",
+ & maxtime_split,
+ & " already reached!!! Trying to carry on!"
+ endif
+ endif
+#ifdef MPI
+ t_enegrad=t_enegrad+MPI_Wtime()-tt0
+#else
+ t_enegrad=t_enegrad+tcpu()-tt0
+#endif
+c Second step of the velocity Verlet algorithm
+ if (lang.eq.2) then
+#ifndef LANG0
+ call sd_verlet2
+#endif
+ else if (lang.eq.3) then
+#ifndef LANG0
+ call sd_verlet2_ciccotti
+#endif
+ else if (lang.eq.1) then
+ call sddir_verlet2
+ else if (tnp1) then
+ call tnp1_respa_i_step2
+ else if (tnp) then
+ call tnp_respa_i_step2
+ else
+ call verlet2
+ if (tnh.and.xiresp) then
+ call kinetic(EK)
+ call nhcint(EK,scale_nh,wdtii,wdtii2,wdtii4,wdtii8)
+ do i=0,2*nres
+ do j=1,3
+ d_t(j,i)=d_t(j,i)*scale_nh
+ enddo
+ enddo
+cd write(iout,*) "SSS2",itsplit,EK,scale_nh
+ endif
+ endif
+ if (rattle) call rattle2
+c Backup the coordinates, velocities, and accelerations
+ if (tnp .or. tnp1) then
+ do i=0,2*nres
+ do j=1,3
+ d_t_old(j,i)=d_t(j,i)
+ if (tnp) d_t(j,i)=d_t(j,i)/s_np
+ if (tnp1) d_t(j,i)=d_t(j,i)/s_np
+ enddo
+ enddo
+ endif
+
+ do i=0,2*nres
+ do j=1,3
+ dc_old(j,i)=dc(j,i)
+ if(.not.(tnp .or. tnp1)) d_t_old(j,i)=d_t(j,i)
+ d_a_old(j,i)=d_a(j,i)
+ enddo
+ enddo
+ enddo
+
+ enddo ! while scale
+
+c Restore the time step
+ d_time=d_time0
+c Compute long-range forces
+#ifdef MPI
+ tt0 =MPI_Wtime()
+#else
+ tt0 = tcpu()
+#endif
+ call zerograd
+ call etotal_long(energia_long)
+ E_long=energia_long(0)
+ potE=energia_short(0)+energia_long(0)
+#ifdef TIMING_ENE
+#ifdef MPI
+ t_elong=t_elong+MPI_Wtime()-tt0
+#else
+ t_elong=t_elong+tcpu()-tt0
+#endif
+#endif
+ call cartgrad
+ call lagrangian
+#ifdef MPI
+ t_enegrad=t_enegrad+MPI_Wtime()-tt0
+#else
+ t_enegrad=t_enegrad+tcpu()-tt0
+#endif
+c Compute accelerations from long-range forces
+ if (ntwe.ne.0) then
+ if (large.and. mod(itime,ntwe).eq.0) then
+ write (iout,*) "energia_long",energia_long(0)
+ write (iout,*) "Cartesian and internal coordinates: step 2"
+c call cartprint
+ call pdbout(0.0d0,"cipiszcze",iout)
+ call intout
+ write (iout,*) "Accelerations from long-range forces"
+ do i=0,nres
+ write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3),
+ & (d_a(j,i+nres),j=1,3)
+ enddo
+ write (iout,*) "Velocities, step 2"
+ do i=0,nres
+ write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),
+ & (d_t(j,i+nres),j=1,3)
+ enddo
+ endif
+ endif
+c Compute the final RESPA step (increment velocities)
+c write (iout,*) "*********************** RESPA fin"
+ if (tnp1) then
+ call tnp_respa_step2
+ else if (tnp) then
+ call tnp_respa_step2
+ else
+ call RESPA_vel
+ if (tnh.and..not.xiresp) then
+ call kinetic(EK)
+ call nhcint(EK,scale_nh,wdti,wdti2,wdti4,wdti8)
+ do i=0,2*nres
+ do j=1,3
+ d_t(j,i)=d_t(j,i)*scale_nh
+ enddo
+ enddo
+ endif
+ endif
+
+ if (tnp .or. tnp1) then
+ do i=0,2*nres
+ do j=1,3
+ d_t(j,i)=d_t_old(j,i)/s_np
+ enddo
+ enddo
+ endif
+
+c Compute the complete potential energy
+ do i=0,n_ene
+ potEcomp(i)=energia_short(i)+energia_long(i)
+ enddo
+ potE=potEcomp(0)-potEcomp(20)
+c potE=energia_short(0)+energia_long(0)
+ totT=totT+d_time
+c Calculate the kinetic and the total energy and the kinetic temperature
+ call kinetic(EK)
+ totE=EK+potE
+c Couple the system to Berendsen bath if needed
+ if (tbf .and. lang.eq.0) then
+ call verlet_bath
+ endif
+ kinetic_T=2.0d0/(dimen3*Rb)*EK
+c Backup the coordinates, velocities, and accelerations
+ if (ntwe.ne.0) then
+ if (mod(itime,ntwe).eq.0 .and. large) then
+ write (iout,*) "Velocities, end"
+ do i=0,nres
+ write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),
+ & (d_t(j,i+nres),j=1,3)
+ enddo
+ endif
+
+ if (mod(itime,ntwe).eq.0) then
+
+ if(tnp .or. tnp1) then
+#ifndef G77
+ write (iout,'(a3,7f)') "TTT",EK,s_np,potE,pi_np,Csplit,
+ & E_long,energia_short(0)
+#else
+ write (iout,'(a3,7f20.10)') "TTT",EK,s_np,potE,pi_np,Csplit,
+ & E_long,energia_short(0)
+#endif
+ HNose1=Hnose(EK,s_np,potE,pi_np,Q_np,t_bath,dimen3)
+ H=(HNose1-H0)*s_np
+cd write (iout,'(a,10f)') "hhh",EK,s_np,potE,pi_np,H0
+cd & ,EK+potE+pi_np**2/(2*Q_np)+dimen3*0.001986d0*t_bath*log(s_np)
+cd write (iout,*) "HHH H=",H,abs(HNose1-H0)/H0
+ hhh=h
+cd write (iout,'(a,3f)') "EE2 NP S, pi",totT, s_np, pi_np
+ endif
+
+ if(tnh) then
+ HNose1=Hnose_nh(EK,potE)
+ H=HNose1-H0
+cd write (iout,*) "HHH H=",H,abs(HNose1-H0)/H0
+ hhh=h
+ endif
+
+
+ if (large) then
+ itnp=0
+ do j=1,3
+ itnp=itnp+1
+ vtnp(itnp)=d_t(j,0)
+ enddo
+ do i=nnt,nct-1
+ do j=1,3
+ itnp=itnp+1
+ vtnp(itnp)=d_t(j,i)
+ enddo
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ inres=i+nres
+ do j=1,3
+ itnp=itnp+1
+ vtnp(itnp)=d_t(j,inres)
+ enddo
+ endif
+ enddo
+
+c Transform velocities from UNRES coordinate space to cartesian and Gvec
+c eigenvector space
+
+ do i=1,dimen3
+ vtnp_(i)=0.0d0
+ vtnp_a(i)=0.0d0
+ do j=1,dimen3
+ vtnp_(i)=vtnp_(i)+Gvec(j,i)*vtnp(j)
+ vtnp_a(i)=vtnp_a(i)+A(i,j)*vtnp(j)
+ enddo
+ vtnp_(i)=vtnp_(i)*dsqrt(geigen(i))
+ enddo
+
+ do i=1,dimen3
+ write (iout,'("WWW",i3,3f10.5)') i,vtnp(i),vtnp_(i),vtnp_a(i)
+ enddo
+
+ endif
+ endif
+ endif
+
+
+ return
+ end
+c---------------------------------------------------------------------
+ subroutine RESPA_vel
+c First and last RESPA step (incrementing velocities using long-range
+c forces).
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ do j=1,3
+ d_t(j,0)=d_t(j,0)+0.5d0*d_a(j,0)*d_time
+ enddo
+ do i=nnt,nct-1
+ do j=1,3
+ d_t(j,i)=d_t(j,i)+0.5d0*d_a(j,i)*d_time
+ enddo
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ inres=i+nres
+ do j=1,3
+ d_t(j,inres)=d_t(j,inres)+0.5d0*d_a(j,inres)*d_time
+ enddo
+ endif
+ enddo
+ return
+ end
+c-----------------------------------------------------------------
+ subroutine verlet1
+c Applying velocity Verlet algorithm - step 1 to coordinates
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ double precision adt,adt2
+
+#ifdef DEBUG
+ write (iout,*) "VELVERLET1 START: DC"
+ do i=0,nres
+ write (iout,'(i3,3f10.5,5x,3f10.5)') i,(dc(j,i),j=1,3),
+ & (dc(j,i+nres),j=1,3)
+ enddo
+#endif
+ do j=1,3
+ adt=d_a_old(j,0)*d_time
+ adt2=0.5d0*adt
+ dc(j,0)=dc_old(j,0)+(d_t_old(j,0)+adt2)*d_time
+ d_t_new(j,0)=d_t_old(j,0)+adt2
+ d_t(j,0)=d_t_old(j,0)+adt
+ enddo
+ do i=nnt,nct-1
+ do j=1,3
+ adt=d_a_old(j,i)*d_time
+ adt2=0.5d0*adt
+ dc(j,i)=dc_old(j,i)+(d_t_old(j,i)+adt2)*d_time
+ d_t_new(j,i)=d_t_old(j,i)+adt2
+ d_t(j,i)=d_t_old(j,i)+adt
+ enddo
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ inres=i+nres
+ do j=1,3
+ adt=d_a_old(j,inres)*d_time
+ adt2=0.5d0*adt
+ dc(j,inres)=dc_old(j,inres)+(d_t_old(j,inres)+adt2)*d_time
+ d_t_new(j,inres)=d_t_old(j,inres)+adt2
+ d_t(j,inres)=d_t_old(j,inres)+adt
+ enddo
+ endif
+ enddo
+#ifdef DEBUG
+ write (iout,*) "VELVERLET1 END: DC"
+ do i=0,nres
+ write (iout,'(i3,3f10.5,5x,3f10.5)') i,(dc(j,i),j=1,3),
+ & (dc(j,i+nres),j=1,3)
+ enddo
+#endif
+ return
+ end
+c---------------------------------------------------------------------
+ subroutine verlet2
+c Step 2 of the velocity Verlet algorithm: update velocities
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ do j=1,3
+ d_t(j,0)=d_t_new(j,0)+0.5d0*d_a(j,0)*d_time
+ enddo
+ do i=nnt,nct-1
+ do j=1,3
+ d_t(j,i)=d_t_new(j,i)+0.5d0*d_a(j,i)*d_time
+ enddo
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ inres=i+nres
+ do j=1,3
+ d_t(j,inres)=d_t_new(j,inres)+0.5d0*d_a(j,inres)*d_time
+ enddo
+ endif
+ enddo
+ return
+ end
+c-----------------------------------------------------------------
+ subroutine sddir_precalc
+c Applying velocity Verlet algorithm - step 1 to coordinates
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+#ifndef LANG0
+ include 'COMMON.LANGEVIN'
+#else
+ include 'COMMON.LANGEVIN.lang0'
+#endif
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ include 'COMMON.TIME1'
+ double precision stochforcvec(MAXRES6)
+ common /stochcalc/ stochforcvec
+c
+c Compute friction and stochastic forces
+c
+#ifdef MPI
+ time00=MPI_Wtime()
+#else
+ time00=tcpu()
+#endif
+ call friction_force
+#ifdef MPI
+ time_fric=time_fric+MPI_Wtime()-time00
+ time00=MPI_Wtime()
+#else
+ time_fric=time_fric+tcpu()-time00
+ time00=tcpu()
+#endif
+ call stochastic_force(stochforcvec)
+#ifdef MPI
+ time_stoch=time_stoch+MPI_Wtime()-time00
+#else
+ time_stoch=time_stoch+tcpu()-time00
+#endif
+c
+c Compute the acceleration due to friction forces (d_af_work) and stochastic
+c forces (d_as_work)
+c
+ call ginv_mult(fric_work, d_af_work)
+ call ginv_mult(stochforcvec, d_as_work)
+ return
+ end
+c---------------------------------------------------------------------
+ subroutine sddir_verlet1
+c Applying velocity Verlet algorithm - step 1 to velocities
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+#ifndef LANG0
+ include 'COMMON.LANGEVIN'
+#else
+ include 'COMMON.LANGEVIN.lang0'
+#endif
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+c Revised 3/31/05 AL: correlation between random contributions to
+c position and velocity increments included.
+ double precision sqrt13 /0.57735026918962576451d0/ ! 1/sqrt(3)
+ double precision adt,adt2
+c
+c Add the contribution from BOTH friction and stochastic force to the
+c coordinates, but ONLY the contribution from the friction forces to velocities
+c
+ do j=1,3
+ adt=(d_a_old(j,0)+d_af_work(j))*d_time
+ adt2=0.5d0*adt+sqrt13*d_as_work(j)*d_time
+ dc(j,0)=dc_old(j,0)+(d_t_old(j,0)+adt2)*d_time
+ d_t_new(j,0)=d_t_old(j,0)+0.5d0*adt
+ d_t(j,0)=d_t_old(j,0)+adt
+ enddo
+ ind=3
+ do i=nnt,nct-1
+ do j=1,3
+ adt=(d_a_old(j,i)+d_af_work(ind+j))*d_time
+ adt2=0.5d0*adt+sqrt13*d_as_work(ind+j)*d_time
+ dc(j,i)=dc_old(j,i)+(d_t_old(j,i)+adt2)*d_time
+ d_t_new(j,i)=d_t_old(j,i)+0.5d0*adt
+ d_t(j,i)=d_t_old(j,i)+adt
+ enddo
+ ind=ind+3
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ inres=i+nres
+ do j=1,3
+ adt=(d_a_old(j,inres)+d_af_work(ind+j))*d_time
+ adt2=0.5d0*adt+sqrt13*d_as_work(ind+j)*d_time
+ dc(j,inres)=dc_old(j,inres)+(d_t_old(j,inres)+adt2)*d_time
+ d_t_new(j,inres)=d_t_old(j,inres)+0.5d0*adt
+ d_t(j,inres)=d_t_old(j,inres)+adt
+ enddo
+ ind=ind+3
+ endif
+ enddo
+ return
+ end
+c---------------------------------------------------------------------
+ subroutine sddir_verlet2
+c Calculating the adjusted velocities for accelerations
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+#ifndef LANG0
+ include 'COMMON.LANGEVIN'
+#else
+ include 'COMMON.LANGEVIN.lang0'
+#endif
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ double precision stochforcvec(MAXRES6),d_as_work1(MAXRES6)
+ double precision cos60 /0.5d0/, sin60 /0.86602540378443864676d0/
+c Revised 3/31/05 AL: correlation between random contributions to
+c position and velocity increments included.
+c The correlation coefficients are calculated at low-friction limit.
+c Also, friction forces are now not calculated with new velocities.
+
+c call friction_force
+ call stochastic_force(stochforcvec)
+c
+c Compute the acceleration due to friction forces (d_af_work) and stochastic
+c forces (d_as_work)
+c
+ call ginv_mult(stochforcvec, d_as_work1)
+
+c
+c Update velocities
+c
+ do j=1,3
+ d_t(j,0)=d_t_new(j,0)+(0.5d0*(d_a(j,0)+d_af_work(j))
+ & +sin60*d_as_work(j)+cos60*d_as_work1(j))*d_time
+ enddo
+ ind=3
+ do i=nnt,nct-1
+ do j=1,3
+ d_t(j,i)=d_t_new(j,i)+(0.5d0*(d_a(j,i)+d_af_work(ind+j))
+ & +sin60*d_as_work(ind+j)+cos60*d_as_work1(ind+j))*d_time
+ enddo
+ ind=ind+3
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ inres=i+nres
+ do j=1,3
+ d_t(j,inres)=d_t_new(j,inres)+(0.5d0*(d_a(j,inres)
+ & +d_af_work(ind+j))+sin60*d_as_work(ind+j)
+ & +cos60*d_as_work1(ind+j))*d_time
+ enddo
+ ind=ind+3
+ endif
+ enddo
+ return
+ end
+c---------------------------------------------------------------------
+ subroutine max_accel
+c
+c Find the maximum difference in the accelerations of the the sites
+c at the beginning and the end of the time step.
+c
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ double precision aux(3),accel(3),accel_old(3),dacc
+ do j=1,3
+c aux(j)=d_a(j,0)-d_a_old(j,0)
+ accel_old(j)=d_a_old(j,0)
+ accel(j)=d_a(j,0)
+ enddo
+ amax=0.0d0
+ do i=nnt,nct
+c Backbone
+ if (i.lt.nct) then
+c 7/3/08 changed to asymmetric difference
+ do j=1,3
+c accel(j)=aux(j)+0.5d0*(d_a(j,i)-d_a_old(j,i))
+ accel_old(j)=accel_old(j)+0.5d0*d_a_old(j,i)
+ accel(j)=accel(j)+0.5d0*d_a(j,i)
+c if (dabs(accel(j)).gt.amax) amax=dabs(accel(j))
+ if (dabs(accel(j)).gt.dabs(accel_old(j))) then
+ dacc=dabs(accel(j)-accel_old(j))
+ if (dacc.gt.amax) amax=dacc
+ endif
+ enddo
+ endif
+ enddo
+c Side chains
+ do j=1,3
+c accel(j)=aux(j)
+ accel_old(j)=d_a_old(j,0)
+ accel(j)=d_a(j,0)
+ enddo
+ if (nnt.eq.2) then
+ do j=1,3
+ accel_old(j)=accel_old(j)+d_a_old(j,1)
+ accel(j)=accel(j)+d_a(j,1)
+ enddo
+ endif
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ do j=1,3
+c accel(j)=accel(j)+d_a(j,i+nres)-d_a_old(j,i+nres)
+ accel_old(j)=accel_old(j)+d_a_old(j,i+nres)
+ accel(j)=accel(j)+d_a(j,i+nres)
+ enddo
+ endif
+ do j=1,3
+c if (dabs(accel(j)).gt.amax) amax=dabs(accel(j))
+ if (dabs(accel(j)).gt.dabs(accel_old(j))) then
+ dacc=dabs(accel(j)-accel_old(j))
+ if (dacc.gt.amax) amax=dacc
+ endif
+ enddo
+ do j=1,3
+ accel_old(j)=accel_old(j)+d_a_old(j,i)
+ accel(j)=accel(j)+d_a(j,i)
+c aux(j)=aux(j)+d_a(j,i)-d_a_old(j,i)
+ enddo
+ enddo
+ return
+ end
+c---------------------------------------------------------------------
+ subroutine predict_edrift(epdrift)
+c
+c Predict the drift of the potential energy
+c
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.MUCA'
+ double precision epdrift,epdriftij
+c Drift of the potential energy
+ epdrift=0.0d0
+ do i=nnt,nct
+c Backbone
+ if (i.lt.nct) then
+ do j=1,3
+ epdriftij=dabs((d_a(j,i)-d_a_old(j,i))*gcart(j,i))
+ if (lmuca) epdriftij=epdriftij*factor
+c write (iout,*) "back",i,j,epdriftij
+ if (epdriftij.gt.epdrift) epdrift=epdriftij
+ enddo
+ endif
+c Side chains
+ if (itype(i).ne.10) then
+ do j=1,3
+ epdriftij=
+ & dabs((d_a(j,i+nres)-d_a_old(j,i+nres))*gxcart(j,i))
+ if (lmuca) epdriftij=epdriftij*factor
+c write (iout,*) "side",i,j,epdriftij
+ if (epdriftij.gt.epdrift) epdrift=epdriftij
+ enddo
+ endif
+ enddo
+ epdrift=0.5d0*epdrift*d_time*d_time
+c write (iout,*) "epdrift",epdrift
+ return
+ end
+c-----------------------------------------------------------------------
+ subroutine verlet_bath
+c
+c Coupling to the thermostat by using the Berendsen algorithm
+c
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ double precision T_half,fact
+c
+ T_half=2.0d0/(dimen3*Rb)*EK
+ fact=dsqrt(1.0d0+(d_time/tau_bath)*(t_bath/T_half-1.0d0))
+c write(iout,*) "T_half", T_half
+c write(iout,*) "EK", EK
+c write(iout,*) "fact", fact
+ do j=1,3
+ d_t(j,0)=fact*d_t(j,0)
+ enddo
+ do i=nnt,nct-1
+ do j=1,3
+ d_t(j,i)=fact*d_t(j,i)
+ enddo
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ inres=i+nres
+ do j=1,3
+ d_t(j,inres)=fact*d_t(j,inres)
+ enddo
+ endif
+ enddo
+ return
+ end
+c---------------------------------------------------------
+ subroutine init_MD
+c Set up the initial conditions of a MD simulation
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MP
+ include 'mpif.h'
+ character*16 form
+ integer IERROR,ERRCODE
+#endif
+ include 'COMMON.SETUP'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+#ifndef LANG0
+ include 'COMMON.LANGEVIN'
+#else
+ include 'COMMON.LANGEVIN.lang0'
+#endif
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ include 'COMMON.REMD'
+ real*8 energia_long(0:n_ene),
+ & energia_short(0:n_ene),vcm(3),incr(3),E_short
+ double precision cm(3),L(3),xv,sigv,lowb,highb
+ double precision varia(maxvar)
+ character*256 qstr
+ integer ilen
+ external ilen
+ character*50 tytul
+ logical file_exist
+ common /gucio/ cm
+ d_time0=d_time
+c write(iout,*) "d_time", d_time
+c Compute the standard deviations of stochastic forces for Langevin dynamics
+c if the friction coefficients do not depend on surface area
+ if (lang.gt.0 .and. .not.surfarea) then
+ do i=nnt,nct-1
+ stdforcp(i)=stdfp*dsqrt(gamp)
+ enddo
+ do i=nnt,nct
+ stdforcsc(i)=stdfsc(itype(i))*dsqrt(gamsc(itype(i)))
+ enddo
+ endif
+c Open the pdb file for snapshotshots
+#ifdef MPI
+ if(mdpdb) then
+ if (ilen(tmpdir).gt.0)
+ & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD"//
+ & liczba(:ilen(liczba))//".pdb")
+ open(ipdb,
+ & file=prefix(:ilen(prefix))//"_MD"//liczba(:ilen(liczba))
+ & //".pdb")
+ else
+#ifdef NOXDR
+ if (ilen(tmpdir).gt.0 .and. (me.eq.king .or. .not.traj1file))
+ & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD"//
+ & liczba(:ilen(liczba))//".x")
+ cartname=prefix(:ilen(prefix))//"_MD"//liczba(:ilen(liczba))
+ & //".x"
+#else
+ if (ilen(tmpdir).gt.0 .and. (me.eq.king .or. .not.traj1file))
+ & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD"//
+ & liczba(:ilen(liczba))//".cx")
+ cartname=prefix(:ilen(prefix))//"_MD"//liczba(:ilen(liczba))
+ & //".cx"
+#endif
+ endif
+#else
+ if(mdpdb) then
+ if (ilen(tmpdir).gt.0)
+ & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD.pdb")
+ open(ipdb,file=prefix(:ilen(prefix))//"_MD.pdb")
+ else
+ if (ilen(tmpdir).gt.0)
+ & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD.cx")
+ cartname=prefix(:ilen(prefix))//"_MD.cx"
+ endif
+#endif
+ if (usampl) then
+ write (qstr,'(256(1h ))')
+ ipos=1
+ do i=1,nfrag
+ iq = qinfrag(i,iset)*10
+ iw = wfrag(i,iset)/100
+ if (iw.gt.0) then
+ if(me.eq.king.or..not.out1file)
+ & write (iout,*) "Frag",qinfrag(i,iset),wfrag(i,iset),iq,iw
+ write (qstr(ipos:ipos+6),'(2h_f,i1,1h_,i1,1h_,i1)') i,iq,iw
+ ipos=ipos+7
+ endif
+ enddo
+ do i=1,npair
+ iq = qinpair(i,iset)*10
+ iw = wpair(i,iset)/100
+ if (iw.gt.0) then
+ if(me.eq.king.or..not.out1file)
+ & write (iout,*) "Pair",i,qinpair(i,iset),wpair(i,iset),iq,iw
+ write (qstr(ipos:ipos+6),'(2h_p,i1,1h_,i1,1h_,i1)') i,iq,iw
+ ipos=ipos+7
+ endif
+ enddo
+c pdbname=pdbname(:ilen(pdbname)-4)//qstr(:ipos-1)//'.pdb'
+#ifdef NOXDR
+c cartname=cartname(:ilen(cartname)-2)//qstr(:ipos-1)//'.x'
+#else
+c cartname=cartname(:ilen(cartname)-3)//qstr(:ipos-1)//'.cx'
+#endif
+c statname=statname(:ilen(statname)-5)//qstr(:ipos-1)//'.stat'
+ endif
+ icg=1
+ if (rest) then
+ if (restart1file) then
+ if (me.eq.king)
+ & inquire(file=mremd_rst_name,exist=file_exist)
+ write (*,*) me," Before broadcast: file_exist",file_exist
+#ifdef MPI
+ call MPI_Bcast(file_exist,1,MPI_LOGICAL,king,CG_COMM,
+ & IERR)
+ write (*,*) me," After broadcast: file_exist",file_exist
+#endif
+c inquire(file=mremd_rst_name,exist=file_exist)
+ if(me.eq.king.or..not.out1file)
+ & write(iout,*) "Initial state read by master and distributed"
+ else
+ if (ilen(tmpdir).gt.0)
+ & call copy_to_tmp(pref_orig(:ilen(pref_orig))//'_'
+ & //liczba(:ilen(liczba))//'.rst')
+ inquire(file=rest2name,exist=file_exist)
+ endif
+ if(file_exist) then
+ if(.not.restart1file) then
+ if(me.eq.king.or..not.out1file)
+ & write(iout,*) "Initial state will be read from file ",
+ & rest2name(:ilen(rest2name))
+ call readrst
+ endif
+ call rescale_weights(t_bath)
+ else
+ if(me.eq.king.or..not.out1file)then
+ if (restart1file) then
+ write(iout,*) "File ",mremd_rst_name(:ilen(mremd_rst_name)),
+ & " does not exist"
+ else
+ write(iout,*) "File ",rest2name(:ilen(rest2name)),
+ & " does not exist"
+ endif
+ write(iout,*) "Initial velocities randomly generated"
+ endif
+ call random_vel
+ totT=0.0d0
+ endif
+ else
+c Generate initial velocities
+ if(me.eq.king.or..not.out1file)
+ & write(iout,*) "Initial velocities randomly generated"
+ call random_vel
+ totT=0.0d0
+ endif
+c rest2name = prefix(:ilen(prefix))//'.rst'
+ if(me.eq.king.or..not.out1file)then
+ write (iout,*) "Initial velocities"
+ do i=0,nres
+ write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),
+ & (d_t(j,i+nres),j=1,3)
+ enddo
+ call flush(iout)
+c Zeroing the total angular momentum of the system
+ write(iout,*) "Calling the zero-angular
+ & momentum subroutine"
+ endif
+ call inertia_tensor
+c Getting the potential energy and forces and velocities and accelerations
+ call vcm_vel(vcm)
+c write (iout,*) "velocity of the center of the mass:"
+c write (iout,*) (vcm(j),j=1,3)
+ do j=1,3
+ d_t(j,0)=d_t(j,0)-vcm(j)
+ enddo
+c Removing the velocity of the center of mass
+ call vcm_vel(vcm)
+ if(me.eq.king.or..not.out1file)then
+ write (iout,*) "vcm right after adjustment:"
+ write (iout,*) (vcm(j),j=1,3)
+ call flush(iout)
+ endif
+ if (.not.rest) then
+ call chainbuild
+ if(iranconf.ne.0) then
+ if (overlapsc) then
+ print *, 'Calling OVERLAP_SC'
+ call overlap_sc(fail)
+ endif
+
+ if (searchsc) then
+ call sc_move(2,nres-1,10,1d10,nft_sc,etot)
+ print *,'SC_move',nft_sc,etot
+ if(me.eq.king.or..not.out1file)
+ & write(iout,*) 'SC_move',nft_sc,etot
+ endif
+
+ if(dccart)then
+ print *, 'Calling MINIM_DC'
+ call minim_dc(etot,iretcode,nfun)
+ else
+ call geom_to_var(nvar,varia)
+ print *,'Calling MINIMIZE.'
+ call minimize(etot,varia,iretcode,nfun)
+ call var_to_geom(nvar,varia)
+ endif
+ if(me.eq.king.or..not.out1file)
+ & write(iout,*) 'SUMSL return code is',iretcode,' eval ',nfun
+ endif
+ endif
+ call chainbuild_cart
+ call kinetic(EK)
+ if (tbf) then
+ call verlet_bath(EK)
+ endif
+ kinetic_T=2.0d0/(dimen3*Rb)*EK
+ if(me.eq.king.or..not.out1file)then
+ call cartprint
+ call intout
+ endif
+#ifdef MPI
+ tt0=MPI_Wtime()
+#else
+ tt0=tcpu()
+#endif
+ call zerograd
+ call etotal(potEcomp)
+#ifdef TIMING_ENE
+#ifdef MPI
+ t_etotal=t_etotal+MPI_Wtime()-tt0
+#else
+ t_etotal=t_etotal+tcpu()-tt0
+#endif
+#endif
+ potE=potEcomp(0)
+
+ if(tnp .or. tnp1) then
+ s_np=1.0
+ pi_np=0.0
+ HNose1=Hnose(EK,s_np,potE,pi_np,Q_np,t_bath,dimen3)
+ H0=Hnose1
+ write(iout,*) 'H0= ',H0
+ endif
+
+ if(tnh) then
+ HNose1=Hnose_nh(EK,potE)
+ H0=HNose1
+ write (iout,*) 'H0= ',H0
+ endif
+
+ if (hmc.gt.0) then
+ hmc_acc=0
+ hmc_etot=potE+EK
+ if(me.eq.king.or..not.out1file)
+ & write(iout,*) 'HMC',hmc_etot,potE,EK
+ do i=1,2*nres
+ do j=1,3
+ dc_hmc(j,i)=dc(j,i)
+ enddo
+ enddo
+ endif
+
+ call cartgrad
+ call lagrangian
+ call max_accel
+ if (amax*d_time .gt. dvmax) then
+ d_time=d_time*dvmax/amax
+ if(me.eq.king.or..not.out1file) write (iout,*)
+ & "Time step reduced to",d_time,
+ & " because of too large initial acceleration."
+ endif
+ if(me.eq.king.or..not.out1file)then
+ write(iout,*) "Potential energy and its components"
+ call enerprint(potEcomp)
+c write(iout,*) (potEcomp(i),i=0,n_ene)
+ endif
+ potE=potEcomp(0)-potEcomp(20)
+ totE=EK+potE
+ itime=0
+ if (ntwe.ne.0) call statout(itime)
+ if(me.eq.king.or..not.out1file)
+ & write (iout,'(/a/3(a25,1pe14.5/))') "Initial:",
+ & " Kinetic energy",EK," potential energy",potE,
+ & " total energy",totE," maximum acceleration ",
+ & amax
+ if (large) then
+ write (iout,*) "Initial coordinates"
+ do i=1,nres
+ write (iout,'(i3,3f10.5,3x,3f10.5)') i,(c(j,i),j=1,3),
+ & (c(j,i+nres),j=1,3)
+ enddo
+ write (iout,*) "Initial dC"
+ do i=0,nres
+ write (iout,'(i3,3f10.5,3x,3f10.5)') i,(dc(j,i),j=1,3),
+ & (dc(j,i+nres),j=1,3)
+ enddo
+ write (iout,*) "Initial velocities"
+ write (iout,"(13x,' backbone ',23x,' side chain')")
+ do i=0,nres
+ write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3),
+ & (d_t(j,i+nres),j=1,3)
+ enddo
+ write (iout,*) "Initial accelerations"
+ do i=0,nres
+c write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3),
+ write (iout,'(i3,3f15.10,3x,3f15.10)') i,(d_a(j,i),j=1,3),
+ & (d_a(j,i+nres),j=1,3)
+ enddo
+ endif
+ do i=0,2*nres
+ do j=1,3
+ dc_old(j,i)=dc(j,i)
+ d_t_old(j,i)=d_t(j,i)
+ d_a_old(j,i)=d_a(j,i)
+ enddo
+c write (iout,*) "dc_old",i,(dc_old(j,i),j=1,3)
+ enddo
+ if (RESPA) then
+#ifdef MPI
+ tt0 =MPI_Wtime()
+#else
+ tt0 = tcpu()
+#endif
+ call zerograd
+ call etotal_short(energia_short)
+#ifdef TIMING_ENE
+#ifdef MPI
+ t_eshort=t_eshort+MPI_Wtime()-tt0
+#else
+ t_eshort=t_eshort+tcpu()-tt0
+#endif
+#endif
+
+ if(tnp .or. tnp1) then
+ E_short=energia_short(0)
+ HNose1=Hnose(EK,s_np,E_short,pi_np,Q_np,t_bath,dimen3)
+ Csplit=Hnose1
+c Csplit =110
+c_new_var_csplit Csplit=H0-E_long
+c Csplit = H0-energia_short(0)
+ write(iout,*) 'Csplit= ',Csplit
+ endif
+
+
+ call cartgrad
+ call lagrangian
+ if(.not.out1file .and. large) then
+ write (iout,*) "energia_long",energia_long(0),
+ & " energia_short",energia_short(0),
+ & " total",energia_long(0)+energia_short(0)
+ write (iout,*) "Initial fast-force accelerations"
+ do i=0,nres
+ write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3),
+ & (d_a(j,i+nres),j=1,3)
+ enddo
+ endif
+C 7/2/2009 Copy accelerations due to short-lange forces to an auxiliary array
+ do i=0,2*nres
+ do j=1,3
+ d_a_short(j,i)=d_a(j,i)
+ enddo
+ enddo
+#ifdef MPI
+ tt0=MPI_Wtime()
+#else
+ tt0=tcpu()
+#endif
+ call zerograd
+ call etotal_long(energia_long)
+#ifdef TIMING_ENE
+#ifdef MPI
+ t_elong=t_elong+MPI_Wtime()-tt0
+#else
+ t_elong=t_elong+tcpu()-tt0
+#endif
+#endif
+ call cartgrad
+ call lagrangian
+ if(.not.out1file .and. large) then
+ write (iout,*) "energia_long",energia_long(0)
+ write (iout,*) "Initial slow-force accelerations"
+ do i=0,nres
+ write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3),
+ & (d_a(j,i+nres),j=1,3)
+ enddo
+ endif
+#ifdef MPI
+ t_enegrad=t_enegrad+MPI_Wtime()-tt0
+#else
+ t_enegrad=t_enegrad+tcpu()-tt0
+#endif
+ endif
+
+
+
+ return
+ end
+c-----------------------------------------------------------
+ subroutine random_vel
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+#ifndef LANG0
+ include 'COMMON.LANGEVIN'
+#else
+ include 'COMMON.LANGEVIN.lang0'
+#endif
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ include 'COMMON.TIME1'
+ double precision xv,sigv,lowb,highb
+c Generate random velocities from Gaussian distribution of mean 0 and std of KT/m
+c First generate velocities in the eigenspace of the G matrix
+c write (iout,*) "Calling random_vel dimen dimen3",dimen,dimen3
+c call flush(iout)
+c write (iout,*) "RANDOM_VEL dimen",dimen
+ xv=0.0d0
+ ii=0
+ do i=1,dimen
+ do k=1,3
+ ii=ii+1
+ sigv=dsqrt((Rb*t_bath)/geigen(i))
+ lowb=-5*sigv
+ highb=5*sigv
+ d_t_work_new(ii)=anorm_distr(xv,sigv,lowb,highb)
+c write (iout,*) "i",i," ii",ii," geigen",geigen(i),
+c & " d_t_work_new",d_t_work_new(ii)
+ enddo
+ enddo
+ call flush(iout)
+c diagnostics
+c Ek1=0.0d0
+c ii=0
+c do i=1,dimen
+c do k=1,3
+c ii=ii+1
+c Ek1=Ek1+0.5d0*geigen(i)*d_t_work_new(ii)**2
+c enddo
+c enddo
+c write (iout,*) "Ek from eigenvectors",Ek1
+c end diagnostics
+c Transform velocities to UNRES coordinate space
+ do k=0,2
+ do i=1,dimen
+ ind=(i-1)*3+k+1
+ d_t_work(ind)=0.0d0
+ do j=1,dimen
+ d_t_work(ind)=d_t_work(ind)
+ & +Gvec(i,j)*d_t_work_new((j-1)*3+k+1)
+ enddo
+c write (iout,*) "i",i," ind",ind," d_t_work",d_t_work(ind)
+c call flush(iout)
+ enddo
+ enddo
+c Transfer to the d_t vector
+ do j=1,3
+ d_t(j,0)=d_t_work(j)
+ enddo
+ ind=3
+ do i=nnt,nct-1
+ do j=1,3
+ ind=ind+1
+ d_t(j,i)=d_t_work(ind)
+ enddo
+ enddo
+c do i=0,nres-1
+c write (iout,*) "d_t",i,(d_t(j,i),j=1,3)
+c enddo
+c call flush(iout)
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ do j=1,3
+ ind=ind+1
+ d_t(j,i+nres)=d_t_work(ind)
+ enddo
+ endif
+ enddo
+c call kinetic(EK)
+c write (iout,*) "Kinetic energy",Ek,EK1," kinetic temperature",
+c & 2.0d0/(dimen3*Rb)*EK,2.0d0/(dimen3*Rb)*EK1
+c call flush(iout)
+ return
+ end
+#ifndef LANG0
+c-----------------------------------------------------------
+ subroutine sd_verlet_p_setup
+c Sets up the parameters of stochastic Verlet algorithm
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+#ifndef LANG0
+ include 'COMMON.LANGEVIN'
+#else
+ include 'COMMON.LANGEVIN.lang0'
+#endif
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ include 'COMMON.TIME1'
+ double precision emgdt(MAXRES6),
+ & pterm,vterm,rho,rhoc,vsig,
+ & pfric_vec(MAXRES6),vfric_vec(MAXRES6),
+ & afric_vec(MAXRES6),prand_vec(MAXRES6),
+ & vrand_vec1(MAXRES6),vrand_vec2(MAXRES6)
+ logical lprn /.false./
+ double precision zero /1.0d-8/, gdt_radius /0.05d0/
+ double precision ktm
+#ifdef MPI
+ tt0 = MPI_Wtime()
+#else
+ tt0 = tcpu()
+#endif
+c
+c AL 8/17/04 Code adapted from tinker
+c
+c Get the frictional and random terms for stochastic dynamics in the
+c eigenspace of mass-scaled UNRES friction matrix
+c
+ do i = 1, dimen
+ gdt = fricgam(i) * d_time
+c
+c Stochastic dynamics reduces to simple MD for zero friction
+c
+ if (gdt .le. zero) then
+ pfric_vec(i) = 1.0d0
+ vfric_vec(i) = d_time
+ afric_vec(i) = 0.5d0 * d_time * d_time
+ prand_vec(i) = 0.0d0
+ vrand_vec1(i) = 0.0d0
+ vrand_vec2(i) = 0.0d0
+c
+c Analytical expressions when friction coefficient is large
+c
+ else
+ if (gdt .ge. gdt_radius) then
+ egdt = dexp(-gdt)
+ pfric_vec(i) = egdt
+ vfric_vec(i) = (1.0d0-egdt) / fricgam(i)
+ afric_vec(i) = (d_time-vfric_vec(i)) / fricgam(i)
+ pterm = 2.0d0*gdt - 3.0d0 + (4.0d0-egdt)*egdt
+ vterm = 1.0d0 - egdt**2
+ rho = (1.0d0-egdt)**2 / sqrt(pterm*vterm)
+c
+c Use series expansions when friction coefficient is small
+c
+ else
+ gdt2 = gdt * gdt
+ gdt3 = gdt * gdt2
+ gdt4 = gdt2 * gdt2
+ gdt5 = gdt2 * gdt3
+ gdt6 = gdt3 * gdt3
+ gdt7 = gdt3 * gdt4
+ gdt8 = gdt4 * gdt4
+ gdt9 = gdt4 * gdt5
+ afric_vec(i) = (gdt2/2.0d0 - gdt3/6.0d0 + gdt4/24.0d0
+ & - gdt5/120.0d0 + gdt6/720.0d0
+ & - gdt7/5040.0d0 + gdt8/40320.0d0
+ & - gdt9/362880.0d0) / fricgam(i)**2
+ vfric_vec(i) = d_time - fricgam(i)*afric_vec(i)
+ pfric_vec(i) = 1.0d0 - fricgam(i)*vfric_vec(i)
+ pterm = 2.0d0*gdt3/3.0d0 - gdt4/2.0d0
+ & + 7.0d0*gdt5/30.0d0 - gdt6/12.0d0
+ & + 31.0d0*gdt7/1260.0d0 - gdt8/160.0d0
+ & + 127.0d0*gdt9/90720.0d0
+ vterm = 2.0d0*gdt - 2.0d0*gdt2 + 4.0d0*gdt3/3.0d0
+ & - 2.0d0*gdt4/3.0d0 + 4.0d0*gdt5/15.0d0
+ & - 4.0d0*gdt6/45.0d0 + 8.0d0*gdt7/315.0d0
+ & - 2.0d0*gdt8/315.0d0 + 4.0d0*gdt9/2835.0d0
+ rho = sqrt(3.0d0) * (0.5d0 - 3.0d0*gdt/16.0d0
+ & - 17.0d0*gdt2/1280.0d0
+ & + 17.0d0*gdt3/6144.0d0
+ & + 40967.0d0*gdt4/34406400.0d0
+ & - 57203.0d0*gdt5/275251200.0d0
+ & - 1429487.0d0*gdt6/13212057600.0d0)
+ end if
+c
+c Compute the scaling factors of random terms for the nonzero friction case
+c
+ ktm = 0.5d0*d_time/fricgam(i)
+ psig = dsqrt(ktm*pterm) / fricgam(i)
+ vsig = dsqrt(ktm*vterm)
+ rhoc = dsqrt(1.0d0 - rho*rho)
+ prand_vec(i) = psig
+ vrand_vec1(i) = vsig * rho
+ vrand_vec2(i) = vsig * rhoc
+ end if
+ end do
+ if (lprn) then
+ write (iout,*)
+ & "pfric_vec, vfric_vec, afric_vec, prand_vec, vrand_vec1,",
+ & " vrand_vec2"
+ do i=1,dimen
+ write (iout,'(i5,6e15.5)') i,pfric_vec(i),vfric_vec(i),
+ & afric_vec(i),prand_vec(i),vrand_vec1(i),vrand_vec2(i)
+ enddo
+ endif
+c
+c Transform from the eigenspace of mass-scaled friction matrix to UNRES variables
+c
+#ifndef LANG0
+ call eigtransf(dimen,maxres2,mt3,mt2,pfric_vec,pfric_mat)
+ call eigtransf(dimen,maxres2,mt3,mt2,vfric_vec,vfric_mat)
+ call eigtransf(dimen,maxres2,mt3,mt2,afric_vec,afric_mat)
+ call eigtransf(dimen,maxres2,mt3,mt1,prand_vec,prand_mat)
+ call eigtransf(dimen,maxres2,mt3,mt1,vrand_vec1,vrand_mat1)
+ call eigtransf(dimen,maxres2,mt3,mt1,vrand_vec2,vrand_mat2)
+#endif
+#ifdef MPI
+ t_sdsetup=t_sdsetup+MPI_Wtime()
+#else
+ t_sdsetup=t_sdsetup+tcpu()-tt0
+#endif
+ return
+ end
+c-------------------------------------------------------------
+ subroutine eigtransf1(n,ndim,ab,d,c)
+ implicit none
+ integer n,ndim
+ double precision ab(ndim,ndim,n),c(ndim,n),d(ndim)
+ integer i,j,k
+ do i=1,n
+ do j=1,n
+ c(i,j)=0.0d0
+ do k=1,n
+ c(i,j)=c(i,j)+ab(k,j,i)*d(k)
+ enddo
+ enddo
+ enddo
+ return
+ end
+c-------------------------------------------------------------
+ subroutine eigtransf(n,ndim,a,b,d,c)
+ implicit none
+ integer n,ndim
+ double precision a(ndim,n),b(ndim,n),c(ndim,n),d(ndim)
+ integer i,j,k
+ do i=1,n
+ do j=1,n
+ c(i,j)=0.0d0
+ do k=1,n
+ c(i,j)=c(i,j)+a(i,k)*b(k,j)*d(k)
+ enddo
+ enddo
+ enddo
+ return
+ end
+c-------------------------------------------------------------
+ subroutine sd_verlet1
+c Applying stochastic velocity Verlet algorithm - step 1 to velocities
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+#ifndef LANG0
+ include 'COMMON.LANGEVIN'
+#else
+ include 'COMMON.LANGEVIN.lang0'
+#endif
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ double precision stochforcvec(MAXRES6)
+ common /stochcalc/ stochforcvec
+ logical lprn /.false./
+
+c write (iout,*) "dc_old"
+c do i=0,nres
+c write (iout,'(i5,3f10.5,5x,3f10.5)')
+c & i,(dc_old(j,i),j=1,3),(dc_old(j,i+nres),j=1,3)
+c enddo
+ do j=1,3
+ dc_work(j)=dc_old(j,0)
+ d_t_work(j)=d_t_old(j,0)
+ d_a_work(j)=d_a_old(j,0)
+ enddo
+ ind=3
+ do i=nnt,nct-1
+ do j=1,3
+ dc_work(ind+j)=dc_old(j,i)
+ d_t_work(ind+j)=d_t_old(j,i)
+ d_a_work(ind+j)=d_a_old(j,i)
+ enddo
+ ind=ind+3
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ do j=1,3
+ dc_work(ind+j)=dc_old(j,i+nres)
+ d_t_work(ind+j)=d_t_old(j,i+nres)
+ d_a_work(ind+j)=d_a_old(j,i+nres)
+ enddo
+ ind=ind+3
+ endif
+ enddo
+#ifndef LANG0
+ if (lprn) then
+ write (iout,*)
+ & "pfric_mat, vfric_mat, afric_mat, prand_mat, vrand_mat1,",
+ & " vrand_mat2"
+ do i=1,dimen
+ do j=1,dimen
+ write (iout,'(2i5,6e15.5)') i,j,pfric_mat(i,j),
+ & vfric_mat(i,j),afric_mat(i,j),
+ & prand_mat(i,j),vrand_mat1(i,j),vrand_mat2(i,j)
+ enddo
+ enddo
+ endif
+ do i=1,dimen
+ ddt1=0.0d0
+ ddt2=0.0d0
+ do j=1,dimen
+ dc_work(i)=dc_work(i)+vfric_mat(i,j)*d_t_work(j)
+ & +afric_mat(i,j)*d_a_work(j)+prand_mat(i,j)*stochforcvec(j)
+ ddt1=ddt1+pfric_mat(i,j)*d_t_work(j)
+ ddt2=ddt2+vfric_mat(i,j)*d_a_work(j)
+ enddo
+ d_t_work_new(i)=ddt1+0.5d0*ddt2
+ d_t_work(i)=ddt1+ddt2
+ enddo
+#endif
+ do j=1,3
+ dc(j,0)=dc_work(j)
+ d_t(j,0)=d_t_work(j)
+ enddo
+ ind=3
+ do i=nnt,nct-1
+ do j=1,3
+ dc(j,i)=dc_work(ind+j)
+ d_t(j,i)=d_t_work(ind+j)
+ enddo
+ ind=ind+3
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ inres=i+nres
+ do j=1,3
+ dc(j,inres)=dc_work(ind+j)
+ d_t(j,inres)=d_t_work(ind+j)
+ enddo
+ ind=ind+3
+ endif
+ enddo
+ return
+ end
+c--------------------------------------------------------------------------
+ subroutine sd_verlet2
+c Calculating the adjusted velocities for accelerations
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+#ifndef LANG0
+ include 'COMMON.LANGEVIN'
+#else
+ include 'COMMON.LANGEVIN.lang0'
+#endif
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ double precision stochforcvec(MAXRES6),stochforcvecV(MAXRES6)
+ common /stochcalc/ stochforcvec
+c
+c Compute the stochastic forces which contribute to velocity change
+c
+ call stochastic_force(stochforcvecV)
+
+#ifndef LANG0
+ do i=1,dimen
+ ddt1=0.0d0
+ ddt2=0.0d0
+ do j=1,dimen
+ ddt1=ddt1+vfric_mat(i,j)*d_a_work(j)
+ ddt2=ddt2+vrand_mat1(i,j)*stochforcvec(j)+
+ & vrand_mat2(i,j)*stochforcvecV(j)
+ enddo
+ d_t_work(i)=d_t_work_new(i)+0.5d0*ddt1+ddt2
+ enddo
+#endif
+ do j=1,3
+ d_t(j,0)=d_t_work(j)
+ enddo
+ ind=3
+ do i=nnt,nct-1
+ do j=1,3
+ d_t(j,i)=d_t_work(ind+j)
+ enddo
+ ind=ind+3
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ inres=i+nres
+ do j=1,3
+ d_t(j,inres)=d_t_work(ind+j)
+ enddo
+ ind=ind+3
+ endif
+ enddo
+ return
+ end
+c-----------------------------------------------------------
+ subroutine sd_verlet_ciccotti_setup
+c Sets up the parameters of stochastic velocity Verlet algorithmi; Ciccotti's
+c version
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+#ifndef LANG0
+ include 'COMMON.LANGEVIN'
+#else
+ include 'COMMON.LANGEVIN.lang0'
+#endif
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ include 'COMMON.TIME1'
+ double precision emgdt(MAXRES6),
+ & pterm,vterm,rho,rhoc,vsig,
+ & pfric_vec(MAXRES6),vfric_vec(MAXRES6),
+ & afric_vec(MAXRES6),prand_vec(MAXRES6),
+ & vrand_vec1(MAXRES6),vrand_vec2(MAXRES6)
+ logical lprn /.false./
+ double precision zero /1.0d-8/, gdt_radius /0.05d0/
+ double precision ktm
+#ifdef MPI
+ tt0 = MPI_Wtime()
+#else
+ tt0 = tcpu()
+#endif
+c
+c AL 8/17/04 Code adapted from tinker
+c
+c Get the frictional and random terms for stochastic dynamics in the
+c eigenspace of mass-scaled UNRES friction matrix
+c
+ do i = 1, dimen
+ write (iout,*) "i",i," fricgam",fricgam(i)
+ gdt = fricgam(i) * d_time
+c
+c Stochastic dynamics reduces to simple MD for zero friction
+c
+ if (gdt .le. zero) then
+ pfric_vec(i) = 1.0d0
+ vfric_vec(i) = d_time
+ afric_vec(i) = 0.5d0*d_time*d_time
+ prand_vec(i) = afric_vec(i)
+ vrand_vec2(i) = vfric_vec(i)
+c
+c Analytical expressions when friction coefficient is large
+c
+ else
+ egdt = dexp(-gdt)
+ pfric_vec(i) = egdt
+ vfric_vec(i) = dexp(-0.5d0*gdt)*d_time
+ afric_vec(i) = 0.5d0*dexp(-0.25d0*gdt)*d_time*d_time
+ prand_vec(i) = afric_vec(i)
+ vrand_vec2(i) = vfric_vec(i)
+c
+c Compute the scaling factors of random terms for the nonzero friction case
+c
+c ktm = 0.5d0*d_time/fricgam(i)
+c psig = dsqrt(ktm*pterm) / fricgam(i)
+c vsig = dsqrt(ktm*vterm)
+c prand_vec(i) = psig*afric_vec(i)
+c vrand_vec2(i) = vsig*vfric_vec(i)
+ end if
+ end do
+ if (lprn) then
+ write (iout,*)
+ & "pfric_vec, vfric_vec, afric_vec, prand_vec, vrand_vec1,",
+ & " vrand_vec2"
+ do i=1,dimen
+ write (iout,'(i5,6e15.5)') i,pfric_vec(i),vfric_vec(i),
+ & afric_vec(i),prand_vec(i),vrand_vec1(i),vrand_vec2(i)
+ enddo
+ endif
+c
+c Transform from the eigenspace of mass-scaled friction matrix to UNRES variables
+c
+ call eigtransf(dimen,maxres2,mt3,mt2,pfric_vec,pfric_mat)
+ call eigtransf(dimen,maxres2,mt3,mt2,vfric_vec,vfric_mat)
+ call eigtransf(dimen,maxres2,mt3,mt2,afric_vec,afric_mat)
+ call eigtransf(dimen,maxres2,mt3,mt1,prand_vec,prand_mat)
+ call eigtransf(dimen,maxres2,mt3,mt1,vrand_vec2,vrand_mat2)
+#ifdef MPI
+ t_sdsetup=t_sdsetup+MPI_Wtime()
+#else
+ t_sdsetup=t_sdsetup+tcpu()-tt0
+#endif
+ return
+ end
+c-------------------------------------------------------------
+ subroutine sd_verlet1_ciccotti
+c Applying stochastic velocity Verlet algorithm - step 1 to velocities
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+#ifndef LANG0
+ include 'COMMON.LANGEVIN'
+#else
+ include 'COMMON.LANGEVIN.lang0'
+#endif
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ double precision stochforcvec(MAXRES6)
+ common /stochcalc/ stochforcvec
+ logical lprn /.false./
+
+c write (iout,*) "dc_old"
+c do i=0,nres
+c write (iout,'(i5,3f10.5,5x,3f10.5)')
+c & i,(dc_old(j,i),j=1,3),(dc_old(j,i+nres),j=1,3)
+c enddo
+ do j=1,3
+ dc_work(j)=dc_old(j,0)
+ d_t_work(j)=d_t_old(j,0)
+ d_a_work(j)=d_a_old(j,0)
+ enddo
+ ind=3
+ do i=nnt,nct-1
+ do j=1,3
+ dc_work(ind+j)=dc_old(j,i)
+ d_t_work(ind+j)=d_t_old(j,i)
+ d_a_work(ind+j)=d_a_old(j,i)
+ enddo
+ ind=ind+3
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ do j=1,3
+ dc_work(ind+j)=dc_old(j,i+nres)
+ d_t_work(ind+j)=d_t_old(j,i+nres)
+ d_a_work(ind+j)=d_a_old(j,i+nres)
+ enddo
+ ind=ind+3
+ endif
+ enddo
+
+#ifndef LANG0
+ if (lprn) then
+ write (iout,*)
+ & "pfric_mat, vfric_mat, afric_mat, prand_mat, vrand_mat1,",
+ & " vrand_mat2"
+ do i=1,dimen
+ do j=1,dimen
+ write (iout,'(2i5,6e15.5)') i,j,pfric_mat(i,j),
+ & vfric_mat(i,j),afric_mat(i,j),
+ & prand_mat(i,j),vrand_mat1(i,j),vrand_mat2(i,j)
+ enddo
+ enddo
+ endif
+ do i=1,dimen
+ ddt1=0.0d0
+ ddt2=0.0d0
+ do j=1,dimen
+ dc_work(i)=dc_work(i)+vfric_mat(i,j)*d_t_work(j)
+ & +afric_mat(i,j)*d_a_work(j)+prand_mat(i,j)*stochforcvec(j)
+ ddt1=ddt1+pfric_mat(i,j)*d_t_work(j)
+ ddt2=ddt2+vfric_mat(i,j)*d_a_work(j)
+ enddo
+ d_t_work_new(i)=ddt1+0.5d0*ddt2
+ d_t_work(i)=ddt1+ddt2
+ enddo
+#endif
+ do j=1,3
+ dc(j,0)=dc_work(j)
+ d_t(j,0)=d_t_work(j)
+ enddo
+ ind=3
+ do i=nnt,nct-1
+ do j=1,3
+ dc(j,i)=dc_work(ind+j)
+ d_t(j,i)=d_t_work(ind+j)
+ enddo
+ ind=ind+3
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ inres=i+nres
+ do j=1,3
+ dc(j,inres)=dc_work(ind+j)
+ d_t(j,inres)=d_t_work(ind+j)
+ enddo
+ ind=ind+3
+ endif
+ enddo
+ return
+ end
+c--------------------------------------------------------------------------
+ subroutine sd_verlet2_ciccotti
+c Calculating the adjusted velocities for accelerations
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+#ifndef LANG0
+ include 'COMMON.LANGEVIN'
+#else
+ include 'COMMON.LANGEVIN.lang0'
+#endif
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ double precision stochforcvec(MAXRES6),stochforcvecV(MAXRES6)
+ common /stochcalc/ stochforcvec
+c
+c Compute the stochastic forces which contribute to velocity change
+c
+ call stochastic_force(stochforcvecV)
+#ifndef LANG0
+ do i=1,dimen
+ ddt1=0.0d0
+ ddt2=0.0d0
+ do j=1,dimen
+
+ ddt1=ddt1+vfric_mat(i,j)*d_a_work(j)
+c ddt2=ddt2+vrand_mat2(i,j)*stochforcvecV(j)
+ ddt2=ddt2+vrand_mat2(i,j)*stochforcvec(j)
+ enddo
+ d_t_work(i)=d_t_work_new(i)+0.5d0*ddt1+ddt2
+ enddo
+#endif
+ do j=1,3
+ d_t(j,0)=d_t_work(j)
+ enddo
+ ind=3
+ do i=nnt,nct-1
+ do j=1,3
+ d_t(j,i)=d_t_work(ind+j)
+ enddo
+ ind=ind+3
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ inres=i+nres
+ do j=1,3
+ d_t(j,inres)=d_t_work(ind+j)
+ enddo
+ ind=ind+3
+ endif
+ enddo
+ return
+ end
+#endif
+c------------------------------------------------------
+ double precision function HNose(ek,s,e,pi,Q,t_bath,dimenl)
+ implicit none
+ double precision ek,s,e,pi,Q,t_bath,Rb
+ integer dimenl
+ Rb=0.001986d0
+ HNose=ek+e+pi**2/(2*Q)+dimenl*Rb*t_bath*log(s)
+c print '(6f15.5,i5,a2,2f15.5)',ek,s,e,pi,Q,t_bath,dimenl,"--",
+c & pi**2/(2*Q),dimenl*Rb*t_bath*log(s)
+ return
+ end
+c-----------------------------------------------------------------
+ double precision function HNose_nh(eki,e)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.MD'
+ HNose_nh=eki+e+dimen3*Rb*t_bath*xlogs(1)+qmass(1)*vlogs(1)**2/2
+ do i=2,nnos
+ HNose_nh=HNose_nh+qmass(i)*vlogs(i)**2/2+Rb*t_bath*xlogs(i)
+ enddo
+c write(4,'(5e15.5)')
+c & vlogs(1),xlogs(1),HNose,eki,e
+ return
+ end
+c-----------------------------------------------------------------
+ SUBROUTINE NHCINT(akin,scale,wdti,wdti2,wdti4,wdti8)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.MD'
+ double precision akin,gnkt,dt,aa,gkt,scale
+ double precision wdti(maxyosh),wdti2(maxyosh),
+ & wdti4(maxyosh),wdti8(maxyosh)
+ integer i,iresn,iyosh,inos,nnos1
+
+ dt=d_time
+ nnos1=nnos+1
+ GKT = Rb*t_bath
+ GNKT = dimen3*GKT
+ akin=akin*2
+
+
+C THIS ROUTINE DOES THE NOSE-HOOVER PART OF THE
+C INTEGRATION FROM t=0 TO t=DT/2
+C GET THE TOTAL KINETIC ENERGY
+ SCALE = 1.D0
+c CALL GETKINP(MASS,VX,VY,VZ,AKIN)
+C UPDATE THE FORCES
+ GLOGS(1) = (AKIN - GNKT)/QMASS(1)
+C START THE MULTIPLE TIME STEP PROCEDURE
+ DO IRESN = 1,NRESN
+ DO IYOSH = 1,NYOSH
+C UPDATE THE THERMOSTAT VELOCITIES
+ VLOGS(NNOS) = VLOGS(NNOS) + GLOGS(NNOS)*WDTI4(IYOSH)
+ DO INOS = 1,NNOS-1
+ AA = EXP(-WDTI8(IYOSH)*VLOGS(NNOS1-INOS) )
+ VLOGS(NNOS-INOS) = VLOGS(NNOS-INOS)*AA*AA
+ & + WDTI4(IYOSH)*GLOGS(NNOS-INOS)*AA
+ ENDDO
+C UPDATE THE PARTICLE VELOCITIES
+ AA = EXP(-WDTI2(IYOSH)*VLOGS(1) )
+ SCALE = SCALE*AA
+C UPDATE THE FORCES
+ GLOGS(1) = (SCALE*SCALE*AKIN - GNKT)/QMASS(1)
+C UPDATE THE THERMOSTAT POSITIONS
+ DO INOS = 1,NNOS
+ XLOGS(INOS) = XLOGS(INOS) + VLOGS(INOS)*WDTI2(IYOSH)
+ ENDDO
+C UPDATE THE THERMOSTAT VELOCITIES
+ DO INOS = 1,NNOS-1
+ AA = EXP(-WDTI8(IYOSH)*VLOGS(INOS+1) )
+ VLOGS(INOS) = VLOGS(INOS)*AA*AA
+ & + WDTI4(IYOSH)*GLOGS(INOS)*AA
+ GLOGS(INOS+1) = (QMASS(INOS)*VLOGS(INOS)*VLOGS(INOS)
+ & -GKT)/QMASS(INOS+1)
+ ENDDO
+ VLOGS(NNOS) = VLOGS(NNOS) + GLOGS(NNOS)*WDTI4(IYOSH)
+ ENDDO
+ ENDDO
+C UPDATE THE PARTICLE VELOCITIES
+c outside of this subroutine
+c DO I = 1,N
+c VX(I) = VX(I)*SCALE
+c VY(I) = VY(I)*SCALE
+c VZ(I) = VZ(I)*SCALE
+c ENDDO
+ RETURN
+ END
+c-----------------------------------------------------------------
+ subroutine tnp1_respa_i_step1
+c Applying Nose-Poincare algorithm - step 1 to coordinates
+c JPSJ 70 75 (2001) S. Nose
+c
+c d_t is not updated here
+c
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ double precision adt,adt2,tmp
+
+ tmp=1+pi_np/(2*Q_np)*0.5*d_time
+ s12_np=s_np*tmp**2
+ pistar=pi_np/tmp
+ s12_dt=d_time/s12_np
+ d_time_s12=d_time*0.5*s12_np
+
+ do j=1,3
+ d_t_new(j,0)=d_t_old(j,0)+d_a_old(j,0)*d_time_s12
+ dc(j,0)=dc_old(j,0)+d_t_new(j,0)*s12_dt
+ enddo
+ do i=nnt,nct-1
+ do j=1,3
+ d_t_new(j,i)=d_t_old(j,i)+d_a_old(j,i)*d_time_s12
+ dc(j,i)=dc_old(j,i)+d_t_new(j,i)*s12_dt
+ enddo
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ inres=i+nres
+ do j=1,3
+ d_t_new(j,inres)=d_t_old(j,inres)+d_a_old(j,inres)*d_time_s12
+ dc(j,inres)=dc_old(j,inres)+d_t_new(j,inres)*s12_dt
+ enddo
+ endif
+ enddo
+ return
+ end
+c---------------------------------------------------------------------
+ subroutine tnp1_respa_i_step2
+c Step 2 of the velocity Verlet algorithm: update velocities
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+
+ double precision d_time_s12
+
+ do i=0,2*nres
+ do j=1,3
+ d_t(j,i)=d_t_new(j,i)
+ enddo
+ enddo
+
+ call kinetic(EK)
+ EK=EK/s12_np**2
+
+ d_time_s12=0.5d0*s12_np*d_time
+
+ do j=1,3
+ d_t(j,0)=d_t_new(j,0)+d_a(j,0)*d_time_s12
+ enddo
+ do i=nnt,nct-1
+ do j=1,3
+ d_t(j,i)=d_t_new(j,i)+d_a(j,i)*d_time_s12
+ enddo
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ inres=i+nres
+ do j=1,3
+ d_t(j,inres)=d_t_new(j,inres)+d_a(j,inres)*d_time_s12
+ enddo
+ endif
+ enddo
+
+ pistar=pistar+(EK-0.5*(E_old+potE)
+ & -dimen3*Rb*t_bath*log(s12_np)+Csplit-dimen3*Rb*t_bath)*d_time
+ tmp=1+pistar/(2*Q_np)*0.5*d_time
+ s_np=s12_np*tmp**2
+ pi_np=pistar/tmp
+
+ return
+ end
+c-------------------------------------------------------
+
+ subroutine tnp1_step1
+c Applying Nose-Poincare algorithm - step 1 to coordinates
+c JPSJ 70 75 (2001) S. Nose
+c
+c d_t is not updated here
+c
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ double precision adt,adt2,tmp
+
+ tmp=1+pi_np/(2*Q_np)*0.5*d_time
+ s12_np=s_np*tmp**2
+ pistar=pi_np/tmp
+ s12_dt=d_time/s12_np
+ d_time_s12=d_time*0.5*s12_np
+
+ do j=1,3
+ d_t_new(j,0)=d_t_old(j,0)+d_a_old(j,0)*d_time_s12
+ dc(j,0)=dc_old(j,0)+d_t_new(j,0)*s12_dt
+ enddo
+ do i=nnt,nct-1
+ do j=1,3
+ d_t_new(j,i)=d_t_old(j,i)+d_a_old(j,i)*d_time_s12
+ dc(j,i)=dc_old(j,i)+d_t_new(j,i)*s12_dt
+ enddo
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ inres=i+nres
+ do j=1,3
+ d_t_new(j,inres)=d_t_old(j,inres)+d_a_old(j,inres)*d_time_s12
+ dc(j,inres)=dc_old(j,inres)+d_t_new(j,inres)*s12_dt
+ enddo
+ endif
+ enddo
+ return
+ end
+c---------------------------------------------------------------------
+ subroutine tnp1_step2
+c Step 2 of the velocity Verlet algorithm: update velocities
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+
+ double precision d_time_s12
+
+ do i=0,2*nres
+ do j=1,3
+ d_t(j,i)=d_t_new(j,i)
+ enddo
+ enddo
+
+ call kinetic(EK)
+ EK=EK/s12_np**2
+
+ d_time_s12=0.5d0*s12_np*d_time
+
+ do j=1,3
+ d_t(j,0)=d_t_new(j,0)+d_a(j,0)*d_time_s12
+ enddo
+ do i=nnt,nct-1
+ do j=1,3
+ d_t(j,i)=d_t_new(j,i)+d_a(j,i)*d_time_s12
+ enddo
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ inres=i+nres
+ do j=1,3
+ d_t(j,inres)=d_t_new(j,inres)+d_a(j,inres)*d_time_s12
+ enddo
+ endif
+ enddo
+
+cd write(iout,*) 'pistar',pistar,EK,E_old,potE,s12_np
+ pistar=pistar+(EK-0.5*(E_old+potE)
+ & -dimen3*Rb*t_bath*log(s12_np)+H0-dimen3*Rb*t_bath)*d_time
+ tmp=1+pistar/(2*Q_np)*0.5*d_time
+ s_np=s12_np*tmp**2
+ pi_np=pistar/tmp
+
+ return
+ end
+
+c-----------------------------------------------------------------
+ subroutine tnp_respa_i_step1
+c Applying Nose-Poincare algorithm - step 1 to coordinates
+c J.Comput.Phys. 151 114 (1999) S.D.Bond B.J.Leimkuhler B.B.Laird
+c
+c d_t is not updated here, it is destroyed
+c
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ double precision C_np,d_time_s,tmp,d_time_ss
+
+ d_time_s=d_time*0.5*s_np
+ct2 d_time_s=d_time*0.5*s12_np
+
+ do j=1,3
+ d_t_new(j,0)=d_t_old(j,0)+d_a_old(j,0)*d_time_s
+ enddo
+ do i=nnt,nct-1
+ do j=1,3
+ d_t_new(j,i)=d_t_old(j,i)+d_a_old(j,i)*d_time_s
+ enddo
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ inres=i+nres
+ do j=1,3
+ d_t_new(j,inres)=d_t_old(j,inres)+d_a_old(j,inres)*d_time_s
+ enddo
+ endif
+ enddo
+
+ do i=0,2*nres
+ do j=1,3
+ d_t(j,i)=d_t_new(j,i)
+ enddo
+ enddo
+
+ call kinetic(EK)
+ EK=EK/s_np**2
+
+ C_np=0.5*d_time*(dimen3*Rb*t_bath*(1.0+log(s_np))-EK+potE-Csplit)
+ & -pi_np
+
+ pistar=-2.0*C_np/(1.0+sqrt(1.0-C_np*d_time/Q_np))
+ tmp=0.5*d_time*pistar/Q_np
+ s12_np=s_np*(1.0+tmp)/(1.0-tmp)
+
+ d_time_ss=0.5*d_time*(1.0/s12_np+1.0/s_np)
+ct2 d_time_ss=d_time/s12_np
+c d_time_ss=0.5*d_time*(1.0/sold_np+1.0/s_np)
+
+ do j=1,3
+ dc(j,0)=dc_old(j,0)+d_t_new(j,0)*d_time_ss
+ enddo
+ do i=nnt,nct-1
+ do j=1,3
+ dc(j,i)=dc_old(j,i)+d_t_new(j,i)*d_time_ss
+ enddo
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ inres=i+nres
+ do j=1,3
+ dc(j,inres)=dc_old(j,inres)+d_t_new(j,inres)*d_time_ss
+ enddo
+ endif
+ enddo
+
+ return
+ end
+c---------------------------------------------------------------------
+
+ subroutine tnp_respa_i_step2
+c Step 2 of the velocity Verlet algorithm: update velocities
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+
+ double precision d_time_s
+
+ EK=EK*(s_np/s12_np)**2
+ HNose1=Hnose(EK,s12_np,potE,pistar,Q_np,t_bath,dimen3)
+ pi_np=pistar+0.5*d_time*(2*EK-dimen3*Rb*t_bath
+ & -HNose1+Csplit)
+
+cr print '(a,5f)','i_step2',EK,potE,HNose1,pi_np,E_long
+ d_time_s=d_time*0.5*s12_np
+c d_time_s=d_time*0.5*s_np
+
+ do j=1,3
+ d_t(j,0)=d_t_new(j,0)+d_a(j,0)*d_time_s
+ enddo
+ do i=nnt,nct-1
+ do j=1,3
+ d_t(j,i)=d_t_new(j,i)+d_a(j,i)*d_time_s
+ enddo
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ inres=i+nres
+ do j=1,3
+ d_t(j,inres)=d_t_new(j,inres)+d_a(j,inres)*d_time_s
+ enddo
+ endif
+ enddo
+
+ s_np=s12_np
+
+ return
+ end
+c-----------------------------------------------------------------
+ subroutine tnp_respa_step1
+c Applying Nose-Poincare algorithm - step 1 to vel for RESPA
+c J.Comput.Phys. 151 114 (1999) S.D.Bond B.J.Leimkuhler B.B.Laird
+c
+c d_t is not updated here, it is destroyed
+c
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ double precision C_np,d_time_s,tmp,d_time_ss
+ double precision energia(0:n_ene)
+
+ d_time_s=d_time*0.5*s_np
+
+ do j=1,3
+ d_t_old(j,0)=d_t_old(j,0)+d_a(j,0)*d_time_s
+ enddo
+ do i=nnt,nct-1
+ do j=1,3
+ d_t_old(j,i)=d_t_old(j,i)+d_a(j,i)*d_time_s
+ enddo
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ inres=i+nres
+ do j=1,3
+ d_t_old(j,inres)=d_t_old(j,inres)+d_a(j,inres)*d_time_s
+ enddo
+ endif
+ enddo
+
+
+c C_np=0.5*d_time*(dimen3*Rb*t_bath*(1.0+log(s_np))-EK+potE-H0)
+c & -pi_np
+c
+c pistar=-2.0*C_np/(1.0+sqrt(1.0-C_np*d_time/Q_np))
+c tmp=0.5*d_time*pistar/Q_np
+c s12_np=s_np*(1.0+tmp)/(1.0-tmp)
+c write(iout,*) 'tnp_respa_step1',s_np,s12_np,EK,potE,C_np,pistar,tmp
+
+ct1 pi_np=pistar
+c sold_np=s_np
+c s_np=s12_np
+
+c-------------------------------------
+c test of reviewer's comment
+ pi_np=pi_np-0.5*d_time*(E_long+Csplit-H0)
+cr print '(a,3f)','1 pi_np,s_np',pi_np,s_np,E_long
+c-------------------------------------
+
+ return
+ end
+c---------------------------------------------------------------------
+ subroutine tnp_respa_step2
+c Step 2 of the velocity Verlet algorithm: update velocities for RESPA
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+
+ double precision d_time_s
+
+ct1 s12_np=s_np
+ct2 pistar=pi_np
+
+ct call kinetic(EK)
+ct HNose1=Hnose(EK,s12_np,potE,pistar,Q_np,t_bath,dimen3)
+ct pi_np=pistar+0.5*d_time*(2*EK-dimen3*Rb*t_bath)
+ct & -0.5*d_time*(HNose1-H0)
+
+c-------------------------------------
+c test of reviewer's comment
+ pi_np=pi_np-0.5*d_time*(E_long+Csplit-H0)
+cr print '(a,3f)','2 pi_np,s_np',pi_np,s_np,E_long
+c-------------------------------------
+ d_time_s=d_time*0.5*s_np
+
+ do j=1,3
+ d_t_old(j,0)=d_t_old(j,0)+d_a(j,0)*d_time_s
+ enddo
+ do i=nnt,nct-1
+ do j=1,3
+ d_t_old(j,i)=d_t_old(j,i)+d_a(j,i)*d_time_s
+ enddo
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ inres=i+nres
+ do j=1,3
+ d_t_old(j,inres)=d_t_old(j,inres)+d_a(j,inres)*d_time_s
+ enddo
+ endif
+ enddo
+
+cd s_np=s12_np
+
+ return
+ end
+c---------------------------------------------------------------------
+ subroutine tnp_step1
+c Applying Nose-Poincare algorithm - step 1 to coordinates
+c J.Comput.Phys. 151 114 (1999) S.D.Bond B.J.Leimkuhler B.B.Laird
+c
+c d_t is not updated here, it is destroyed
+c
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ double precision C_np,d_time_s,tmp,d_time_ss
+
+ d_time_s=d_time*0.5*s_np
+
+ do j=1,3
+ d_t_new(j,0)=d_t_old(j,0)+d_a_old(j,0)*d_time_s
+ enddo
+ do i=nnt,nct-1
+ do j=1,3
+ d_t_new(j,i)=d_t_old(j,i)+d_a_old(j,i)*d_time_s
+ enddo
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ inres=i+nres
+ do j=1,3
+ d_t_new(j,inres)=d_t_old(j,inres)+d_a_old(j,inres)*d_time_s
+ enddo
+ endif
+ enddo
+
+ do i=0,2*nres
+ do j=1,3
+ d_t(j,i)=d_t_new(j,i)
+ enddo
+ enddo
+
+ call kinetic(EK)
+ EK=EK/s_np**2
+
+ C_np=0.5*d_time*(dimen3*Rb*t_bath*(1.0+log(s_np))-EK+potE-H0)
+ & -pi_np
+
+ pistar=-2.0*C_np/(1.0+sqrt(1.0-C_np*d_time/Q_np))
+ tmp=0.5*d_time*pistar/Q_np
+ s12_np=s_np*(1.0+tmp)/(1.0-tmp)
+c write(iout,*) 'tnp_step1',s_np,s12_np,EK,potE,C_np,pistar,tmp
+
+ d_time_ss=0.5*d_time*(1.0/s12_np+1.0/s_np)
+
+ do j=1,3
+ dc(j,0)=dc_old(j,0)+d_t_new(j,0)*d_time_ss
+ enddo
+ do i=nnt,nct-1
+ do j=1,3
+ dc(j,i)=dc_old(j,i)+d_t_new(j,i)*d_time_ss
+ enddo
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ inres=i+nres
+ do j=1,3
+ dc(j,inres)=dc_old(j,inres)+d_t_new(j,inres)*d_time_ss
+ enddo
+ endif
+ enddo
+
+ return
+ end
+c-----------------------------------------------------------------
+ subroutine tnp_step2
+c Step 2 of the velocity Verlet algorithm: update velocities
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+
+ double precision d_time_s
+
+ EK=EK*(s_np/s12_np)**2
+ HNose1=Hnose(EK,s12_np,potE,pistar,Q_np,t_bath,dimen3)
+ pi_np=pistar+0.5*d_time*(2*EK-dimen3*Rb*t_bath)
+ & -0.5*d_time*(HNose1-H0)
+
+cd write(iout,'(a,4f)') 'mmm',EK,potE,HNose1,pi_np
+ d_time_s=d_time*0.5*s12_np
+
+ do j=1,3
+ d_t(j,0)=d_t_new(j,0)+d_a(j,0)*d_time_s
+ enddo
+ do i=nnt,nct-1
+ do j=1,3
+ d_t(j,i)=d_t_new(j,i)+d_a(j,i)*d_time_s
+ enddo
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ inres=i+nres
+ do j=1,3
+ d_t(j,inres)=d_t_new(j,inres)+d_a(j,inres)*d_time_s
+ enddo
+ endif
+ enddo
+
+ s_np=s12_np
+
+ return
+ end
+
+ subroutine hmc_test(itime)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.MD'
+ include 'COMMON.CHAIN'
+
+ hmc_acc=hmc_acc+1
+ delta=-(potE+EK-hmc_etot)/(Rb*t_bath)
+ if (delta .lt. -50.0d0) then
+ delta=0.0d0
+ else
+ delta=dexp(delta)
+ endif
+ xxx=ran_number(0.0d0,1.0d0)
+
+ if (me.eq.king .or. .not. out1file)
+ & write(iout,'(a8,i5,6f10.4)')
+ & 'HMC',itime,potE+EK,potE,EK,hmc_etot,delta,xxx
+
+ if (delta .le. xxx) then
+ do i=1,2*nres
+ do j=1,3
+ dc(j,i)=dc_hmc(j,i)
+ enddo
+ enddo
+ itime=itime-hmc
+ totT=totThmc
+ else
+ if (me.eq.king .or. .not. out1file)
+ & write(iout,*) 'HMC accepting new'
+ totThmc=totT
+ do i=1,2*nres
+ do j=1,3
+ dc_hmc(j,i)=dc(j,i)
+ enddo
+ enddo
+ endif
+
+ call chainbuild_cart
+ call random_vel
+ do i=0,2*nres
+ do j=1,3
+ d_t_old(j,i)=d_t(j,i)
+ enddo
+ enddo
+ call kinetic(EK)
+ kinetic_T=2.0d0/(dimen3*Rb)*EK
+ call etotal(potEcomp)
+ potE=potEcomp(0)
+ hmc_etot=potE+EK
+ if (me.eq.king .or. .not. out1file)
+ & write(iout,'(a8,i5,3f10.4)')'HMC new',itime,potE+EK,potE,EK
+
+
+ return
+ end
--- /dev/null
+#ifdef MPI
+ subroutine init_task
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'mpif.h'
+ include 'COMMON.SETUP'
+ include 'COMMON.CONTROL'
+ include 'COMMON.IOUNITS'
+ logical lprn /.false./
+c real*8 text1 /'group_i '/,text2/'group_f '/,
+c & text3/'initialb'/,text4/'initiale'/,
+c & text5/'openb'/,text6/'opene'/
+ integer cgtasks(0:max_cg_procs)
+ character*3 cfgprocs
+ integer cg_size,fg_size,fg_size1
+c start parallel processing
+c print *,'Initializing MPI'
+ call mpi_init(ierr)
+ if (ierr.ne.0) then
+ print *, ' cannot initialize MPI'
+ stop
+ endif
+c determine # of nodes and current node
+ call MPI_Comm_rank( MPI_COMM_WORLD, me, ierr )
+ if (ierr.ne.0) then
+ print *, ' cannot determine rank of all processes'
+ call MPI_Finalize( MPI_COMM_WORLD, IERR )
+ stop
+ endif
+ call MPI_Comm_size( MPI_Comm_world, nodes, ierr )
+ if (ierr.ne.0) then
+ print *, ' cannot determine number of processes'
+ stop
+ endif
+ Nprocs=nodes
+ MyRank=me
+C Determine the number of "fine-grain" tasks
+ call getenv_loc("FGPROCS",cfgprocs)
+ read (cfgprocs,'(i3)') nfgtasks
+ if (nfgtasks.eq.0) nfgtasks=1
+ call getenv_loc("MAXGSPROCS",cfgprocs)
+ read (cfgprocs,'(i3)') max_gs_size
+ if (max_gs_size.eq.0) max_gs_size=2
+ if (lprn)
+ & print *,"Processor",me," nfgtasks",nfgtasks,
+ & " max_gs_size",max_gs_size
+ if (nfgtasks.eq.1) then
+ CG_COMM = MPI_COMM_WORLD
+ fg_size=1
+ fg_rank=0
+ nfgtasks1=1
+ fg_rank1=0
+ else
+ nodes=nprocs/nfgtasks
+ if (nfgtasks*nodes.ne.nprocs) then
+ write (*,'(a)') 'ERROR: Number of processors assigned',
+ & ' to coarse-grained tasks must be divisor',
+ & ' of the total number of processors.'
+ call MPI_Finalize( MPI_COMM_WORLD, IERR )
+ stop
+ endif
+C Put the ranks of coarse-grain processes in one table and create
+C the respective communicator. The processes with ranks "in between"
+C the ranks of CG processes will perform fine graining for the CG
+C process with the next lower rank.
+ do i=0,nprocs-1,nfgtasks
+ cgtasks(i/nfgtasks)=i
+ enddo
+ if (lprn) then
+ print*,"Processor",me," cgtasks",(cgtasks(i),i=0,nodes-1)
+c print "(a,i5,a)","Processor",myrank," Before MPI_Comm_group"
+ endif
+c call memmon_print_usage()
+ call MPI_Comm_group(MPI_COMM_WORLD,world_group,IERR)
+ call MPI_Group_incl(world_group,nodes,cgtasks,cg_group,IERR)
+ call MPI_Comm_create(MPI_COMM_WORLD,cg_group,CG_COMM,IERR)
+ call MPI_Group_rank(cg_group,me,ierr)
+ call MPI_Group_free(world_group,ierr)
+ call MPI_Group_free(cg_group,ierr)
+c print "(a,i5,a)","Processor",myrank," After MPI_Comm_group"
+c call memmon_print_usage()
+ if (me.ne.MPI_UNDEFINED) call MPI_Comm_Rank(CG_COMM,me,ierr)
+ if (lprn) print *," Processor",myrank," CG rank",me
+C Create communicators containig processes doing "fine grain" tasks.
+C The processes within each FG_COMM should have fast communication.
+ kolor=MyRank/nfgtasks
+ key=mod(MyRank,nfgtasks)
+ call MPI_Comm_split(MPI_COMM_WORLD,kolor,key,FG_COMM,ierr)
+ call MPI_Comm_size(FG_COMM,fg_size,ierr)
+ if (fg_size.ne.nfgtasks) then
+ write (*,*) "OOOOps... the number of fg tasks is",fg_size,
+ & " but",nfgtasks," was requested. MyRank=",MyRank
+ endif
+ call MPI_Comm_rank(FG_COMM,fg_rank,ierr)
+ if (fg_size.gt.max_gs_size) then
+ kolor1=fg_rank/max_gs_size
+ key1=mod(fg_rank,max_gs_size)
+ call MPI_Comm_split(FG_COMM,kolor1,key1,FG_COMM1,ierr)
+ call MPI_Comm_size(FG_COMM1,nfgtasks1,ierr)
+ call MPI_Comm_rank(FG_COMM1,fg_rank1,ierr)
+ else
+ FG_COMM1=FG_COMM
+ nfgtasks1=nfgtasks
+ fg_rank1=fg_rank
+ endif
+ endif
+ if (fg_rank.eq.0) then
+ write (*,*) "Processor",MyRank," out of",nprocs,
+ & " rank in CG_COMM",me," size of CG_COMM",nodes,
+ & " size of FG_COMM",fg_size,
+ & " rank in FG_COMM1",fg_rank1," size of FG_COMM1",nfgtasks1
+ else
+ write (*,*) "Processor",MyRank," out of",nprocs,
+ & " rank in FG_COMM",fg_rank," size of FG_COMM",fg_size,
+ & " rank in FG_COMM1",fg_rank1," size of FG_COMM1",nfgtasks1
+ endif
+C Initialize other variables.
+c print '(a)','Before initialize'
+c call memmon_print_usage()
+ call initialize
+c print '(a,i5,a)','Processor',myrank,' After initialize'
+c call memmon_print_usage()
+C Open task-dependent files.
+c print '(a,i5,a)','Processor',myrank,' Before openunits'
+c call memmon_print_usage()
+ call openunits
+c print '(a,i5,a)','Processor',myrank,' After openunits'
+c call memmon_print_usage()
+ if (me.eq.king .or. fg_rank.eq.0 .and. .not. out1file)
+ & write (iout,'(80(1h*)/a/80(1h*))')
+ & 'United-residue force field calculation - parallel job.'
+c print *,"Processor",myrank," exited OPENUNITS"
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine finish_task
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'mpif.h'
+ include 'COMMON.SETUP'
+ include 'COMMON.CONTROL'
+ include 'COMMON.REMD'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.FFIELD'
+ include 'COMMON.TIME1'
+ include 'COMMON.MD'
+ integer ilen
+ external ilen
+c
+ call MPI_Barrier(CG_COMM,ierr)
+ if (nfgtasks.gt.1)
+ & call MPI_Bcast(-1,1,MPI_INTEGER,king,FG_COMM,IERROR)
+ time1=MPI_WTIME()
+ if (me.eq.king .or. .not. out1file) then
+ write (iout,'(a,i4,a)') 'CG processor',me,' is finishing work.'
+ write (iout,*) 'Total wall clock time',time1-walltime,' sec'
+ if (nfgtasks.gt.1) then
+ write (iout,'(80(1h=)/a/(80(1h=)))')
+ & "Details of FG communication time"
+ write (iout,'(7(a40,1pe15.5/),40(1h-)/a40,1pe15.5/80(1h=))')
+ & "BROADCAST:",time_bcast,"REDUCE:",time_reduce,
+ & "GATHER:",time_gather,
+ & "SCATTER:",time_scatter,"SENDRECV:",time_sendrecv,
+ & "BARRIER ene",time_barrier_e,
+ & "BARRIER grad",time_barrier_g,"TOTAL:",
+ & time_bcast+time_reduce+time_gather+time_scatter+time_sendrecv
+ & +time_barrier_e+time_barrier_g
+ write (*,*) 'Total wall clock time',time1-walltime,' sec'
+ write (*,*) "Processor",me," BROADCAST time",time_bcast,
+ & " REDUCE time",
+ & time_reduce," GATHER time",time_gather," SCATTER time",
+ & time_scatter," SENDRECV",time_sendrecv,
+ & " BARRIER ene",time_barrier_e," BARRIER grad",time_barrier_g
+ endif
+ endif
+ write (*,'(a,i4,a)') 'CG processor',me,' is finishing work.'
+ if (ilen(tmpdir).gt.0) then
+ write (*,*) "Processor",me,
+ & ": moving output files to the parent directory..."
+ close(inp)
+ close(istat,status='keep')
+ if (ntwe.gt.0) call move_from_tmp(statname)
+ close(irest2,status='keep')
+ if (modecalc.eq.12.or.
+ & (modecalc.eq.14 .and. .not.restart1file)) then
+ call move_from_tmp(rest2name)
+ else if (modecalc.eq.14.and. me.eq.king) then
+ call move_from_tmp(mremd_rst_name)
+ endif
+ if (mdpdb) then
+ close(ipdb,status='keep')
+ call move_from_tmp(pdbname)
+ else if (me.eq.king .or. .not.traj1file) then
+ close(icart,status='keep')
+ call move_from_tmp(cartname)
+ endif
+ if (me.eq.king .or. .not. out1file) then
+ close (iout,status='keep')
+ call move_from_tmp(outname)
+ endif
+ endif
+ return
+ end
+c-------------------------------------------------------------------------
+ subroutine pattern_receive
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'mpif.h'
+ include 'COMMON.SETUP'
+ include 'COMMON.THREAD'
+ include 'COMMON.IOUNITS'
+ integer tag,status(MPI_STATUS_SIZE)
+ integer source,ThreadType
+ logical flag
+ ThreadType=45
+ source=mpi_any_source
+ call mpi_iprobe(source,ThreadType,
+ & CG_COMM,flag,status,ierr)
+ do while (flag)
+ write (iout,*) 'Processor ',Me,' is receiving threading',
+ & ' pattern from processor',status(mpi_source)
+ write (*,*) 'Processor ',Me,' is receiving threading',
+ & ' pattern from processor',status(mpi_source)
+ nexcl=nexcl+1
+ call mpi_irecv(iexam(1,nexcl),2,mpi_integer,status(mpi_source),
+ & ThreadType, CG_COMM,ireq,ierr)
+ write (iout,*) 'Received pattern:',nexcl,iexam(1,nexcl),
+ & iexam(2,nexcl)
+ source=mpi_any_source
+ call mpi_iprobe(source,ThreadType,
+ & CG_COMM,flag,status,ierr)
+ enddo
+ return
+ end
+c----------------------------------------------------------------------------
+ subroutine pattern_send
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'mpif.h'
+ include 'COMMON.INFO'
+ include 'COMMON.THREAD'
+ include 'COMMON.IOUNITS'
+ integer source,ThreadType,ireq
+ ThreadType=45
+ do iproc=0,nprocs-1
+ if (iproc.ne.me .and. .not.Koniec(iproc) ) then
+ call mpi_isend(iexam(1,nexcl),2,mpi_integer,iproc,
+ & ThreadType, CG_COMM, ireq, ierr)
+ write (iout,*) 'CG processor ',me,' has sent pattern ',
+ & 'to processor',iproc
+ write (*,*) 'CG processor ',me,' has sent pattern ',
+ & 'to processor',iproc
+ write (iout,*) 'Pattern:',nexcl,iexam(1,nexcl),iexam(2,nexcl)
+ endif
+ enddo
+ return
+ end
+c-----------------------------------------------------------------------------
+ subroutine send_stop_sig(Kwita)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'mpif.h'
+ include 'COMMON.INFO'
+ include 'COMMON.IOUNITS'
+ integer StopType,StopId,iproc,Kwita,NBytes
+ StopType=66
+c Kwita=-1
+C print *,'CG processor',me,' StopType=',StopType
+ Koniec(me)=.true.
+ if (me.eq.king) then
+C Master sends the STOP signal to everybody.
+ write (iout,'(a,a)')
+ & 'Master is sending STOP signal to other processors.'
+ do iproc=1,nprocs-1
+ print *,'Koniec(',iproc,')=',Koniec(iproc)
+ if (.not. Koniec(iproc)) then
+ call mpi_send(Kwita,1,mpi_integer,iproc,StopType,
+ & mpi_comm_world,ierr)
+ write (iout,*) 'Iproc=',iproc,' StopID=',StopID
+ write (*,*) 'Iproc=',iproc,' StopID=',StopID
+ endif
+ enddo
+ else
+C Else send the STOP signal to Master.
+ call mpi_send(Kwita,1,mpi_integer,MasterID,StopType,
+ & mpi_comm_world,ierr)
+ write (iout,*) 'CG processor=',me,' StopID=',StopID
+ write (*,*) 'CG processor=',me,' StopID=',StopID
+ endif
+ return
+ end
+c-----------------------------------------------------------------------------
+ subroutine recv_stop_sig(Kwita)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'mpif.h'
+ include 'COMMON.INFO'
+ include 'COMMON.IOUNITS'
+ integer source,StopType,StopId,iproc,Kwita
+ logical flag
+ StopType=66
+ Kwita=0
+ source=mpi_any_source
+c print *,'CG processor:',me,' StopType=',StopType
+ call mpi_iprobe(source,StopType,
+ & mpi_comm_world,flag,status,ierr)
+ do while (flag)
+ Koniec(status(mpi_source))=.true.
+ write (iout,*) 'CG processor ',me,' is receiving STOP signal',
+ & ' from processor',status(mpi_source)
+ write (*,*) 'CG processor ',me,' is receiving STOP signal',
+ & ' from processor',status(mpi_source)
+ call mpi_irecv(Kwita,1,mpi_integer,status(mpi_source),StopType,
+ & mpi_comm_world,ireq,ierr)
+ call mpi_iprobe(source,StopType,
+ & mpi_comm_world,flag,status,ierr)
+ enddo
+ return
+ end
+c-----------------------------------------------------------------------------
+ subroutine send_MCM_info(ione)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'mpif.h'
+ include 'COMMON.SETUP'
+ include 'COMMON.MCM'
+ include 'COMMON.IOUNITS'
+ integer tag,status(MPI_STATUS_SIZE)
+ integer MCM_info_Type,MCM_info_ID,iproc,one,NBytes
+ common /aaaa/ isend,irecv
+ integer nsend
+ save nsend
+ nsend=nsend+1
+ MCM_info_Type=77
+cd write (iout,'(a,i4,a)') 'CG Processor',me,
+cd & ' is sending MCM info to Master.'
+ write (*,'(a,i4,a,i8)') 'CG processor',me,
+ & ' is sending MCM info to Master, MCM_info_ID=',MCM_info_ID
+ call mpi_isend(ione,1,mpi_integer,MasterID,
+ & MCM_info_Type,mpi_comm_world, MCM_info_ID, ierr)
+cd write (iout,*) 'CG processor',me,' has sent info to the master;',
+cd & ' MCM_info_ID=',MCM_info_ID
+ write (*,*) 'CG processor',me,' has sent info to the master;',
+ & ' MCM_info_ID=',MCM_info_ID,' ierr ',ierr
+ isend=0
+ irecv=0
+ return
+ end
+c----------------------------------------------------------------------------
+ subroutine receive_MCM_info
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'mpif.h'
+ include 'COMMON.SETUP'
+ include 'COMMON.MCM'
+ include 'COMMON.IOUNITS'
+ integer tag,status(MPI_STATUS_SIZE)
+ integer source,MCM_info_Type,MCM_info_ID,iproc,ione
+ logical flag
+ MCM_info_Type=77
+ source=mpi_any_source
+c print *,'source=',source,' dontcare=',dontcare
+ call mpi_iprobe(source,MCM_info_Type,
+ & mpi_comm_world,flag,status,ierr)
+ do while (flag)
+ source=status(mpi_source)
+ itask=source/fgProcs+1
+cd write (iout,*) 'Master is receiving MCM info from processor ',
+cd & source,' itask',itask
+ write (*,*) 'Master is receiving MCM info from processor ',
+ & source,' itask',itask
+ call mpi_irecv(ione,1,mpi_integer,source,MCM_info_type,
+ & mpi_comm_world,MCM_info_ID,ierr)
+cd write (iout,*) 'Received from processor',source,' IONE=',ione
+ write (*,*) 'Received from processor',source,' IONE=',ione
+ nacc_tot=nacc_tot+1
+ if (ione.eq.2) nsave_part(itask)=nsave_part(itask)+1
+cd print *,'nsave_part(',itask,')=',nsave_part(itask)
+cd write (iout,*) 'Nacc_tot=',Nacc_tot
+cd write (*,*) 'Nacc_tot=',Nacc_tot
+ source=mpi_any_source
+ call mpi_iprobe(source,MCM_info_Type,
+ & mpi_comm_world,flag,status,ierr)
+ enddo
+ return
+ end
+c---------------------------------------------------------------------------
+ subroutine send_thread_results
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'mpif.h'
+ include 'COMMON.SETUP'
+ include 'COMMON.THREAD'
+ include 'COMMON.IOUNITS'
+ integer tag,status(MPI_STATUS_SIZE)
+ integer ibuffer(2*maxthread+2),ThreadType,ThreadID,EnerType,
+ & EnerID,msglen,nbytes
+ double precision buffer(20*maxthread+2)
+ ThreadType=444
+ EnerType=555
+ ipatt(1,nthread+1)=nthread
+ ipatt(2,nthread+1)=nexcl
+ do i=1,nthread
+ do j=1,n_ene
+ ener(j,i+nthread)=ener0(j,i)
+ enddo
+ enddo
+ ener(1,2*nthread+1)=max_time_for_thread
+ ener(2,2*nthread+1)=ave_time_for_thread
+C Send the IPATT array
+ write (iout,*) 'CG processor',me,
+ & ' is sending IPATT array to master: NTHREAD=',nthread
+ write (*,*) 'CG processor',me,
+ & ' is sending IPATT array to master: NTHREAD=',nthread
+ msglen=2*nthread+2
+ call mpi_send(ipatt(1,1),msglen,MPI_INTEGER,MasterID,
+ & ThreadType,mpi_comm_world,ierror)
+ write (iout,*) 'CG processor',me,
+ & ' has sent IPATT array to master MSGLEN',msglen
+ write (*,*) 'CG processor',me,
+ & ' has sent IPATT array to master MSGLEN',msglen
+C Send the energies.
+ msglen=n_ene2*nthread+2
+ write (iout,*) 'CG processor',me,' is sending energies to master.'
+ write (*,*) 'CG processor',me,' is sending energies to master.'
+ call mpi_send(ener(1,1),msglen,MPI_DOUBLE_PRECISION,MasterID,
+ & EnerType,mpi_comm_world,ierror)
+ write (iout,*) 'CG processor',me,' has sent energies to master.'
+ write (*,*) 'CG processor',me,' has sent energies to master.'
+ return
+ end
+c----------------------------------------------------------------------------
+ subroutine receive_thread_results(iproc)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'mpif.h'
+ include 'COMMON.INFO'
+ include 'COMMON.THREAD'
+ include 'COMMON.IOUNITS'
+ integer ibuffer(2*maxthread+2),ThreadType,ThreadID,EnerType,
+ & EnerID,ReadyType,ReadyID,Ready,msglen,nbytes,nthread_temp
+ double precision buffer(20*maxthread+2),max_time_for_thread_t,
+ & ave_time_for_thread_t
+ logical flag
+ ThreadType=444
+ EnerType=555
+C Receive the IPATT array
+ call mpi_probe(iproc,ThreadType,
+ & mpi_comm_world,status,ierr)
+ call MPI_GET_COUNT(STATUS, MPI_INTEGER, MSGLEN, IERROR)
+ write (iout,*) 'Master is receiving IPATT array from processor:',
+ & iproc,' MSGLEN',msglen
+ write (*,*) 'Master is receiving IPATT array from processor:',
+ & iproc,' MSGLEN',msglen
+ call mpi_recv(ipatt(1,nthread+1),msglen,mpi_integer,iproc,
+ & ThreadType,
+ & mpi_comm_world,status,ierror)
+ write (iout,*) 'Master has received IPATT array from processor:',
+ & iproc,' MSGLEN=',msglen
+ write (*,*) 'Master has received IPATT array from processor:',
+ & iproc,' MSGLEN=',msglen
+ nthread_temp=ipatt(1,nthread+msglen/2)
+ nexcl_temp=ipatt(2,nthread+msglen/2)
+C Receive the energies.
+ call mpi_probe(iproc,EnerType,
+ & mpi_comm_world,status,ierr)
+ call MPI_GET_COUNT(STATUS, MPI_DOUBLE_PRECISION, MSGLEN, IERROR)
+ write (iout,*) 'Master is receiving energies from processor:',
+ & iproc,' MSGLEN=',MSGLEN
+ write (*,*) 'Master is receiving energies from processor:',
+ & iproc,' MSGLEN=',MSGLEN
+ call mpi_recv(ener(1,nthread+1),msglen,
+ & MPI_DOUBLE_PRECISION,iproc,
+ & EnerType,MPI_COMM_WORLD,status,ierror)
+ write (iout,*) 'Msglen=',Msglen
+ write (*,*) 'Msglen=',Msglen
+ write (iout,*) 'Master has received energies from processor',iproc
+ write (*,*) 'Master has received energies from processor',iproc
+ write (iout,*) 'NTHREAD_TEMP=',nthread_temp,' NEXCL=',nexcl_temp
+ write (*,*) 'NTHREAD_TEMP=',nthread_temp,' NEXCL=',nexcl_temp
+ do i=1,nthread_temp
+ do j=1,n_ene
+ ener0(j,nthread+i)=ener(j,nthread+nthread_temp+i)
+ enddo
+ enddo
+ max_time_for_thread_t=ener(1,nthread+2*nthread_temp+1)
+ ave_time_for_thread_t=ener(2,nthread+2*nthread_temp+1)
+ write (iout,*) 'MAX_TIME_FOR_THREAD:',max_time_for_thread_t
+ write (iout,*) 'AVE_TIME_FOR_THREAD:',ave_time_for_thread_t
+ write (*,*) 'MAX_TIME_FOR_THREAD:',max_time_for_thread_t
+ write (*,*) 'AVE_TIME_FOR_THREAD:',ave_time_for_thread_t
+ if (max_time_for_thread_t.gt.max_time_for_thread)
+ & max_time_for_thread=max_time_for_thread_t
+ ave_time_for_thread=(nthread*ave_time_for_thread+
+ & nthread_temp*ave_time_for_thread_t)/(nthread+nthread_temp)
+ nthread=nthread+nthread_temp
+ return
+ end
+#else
+ subroutine init_task
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.SETUP'
+ me=0
+ myrank=0
+ fg_rank=0
+ fg_size=1
+ nodes=1
+ nprocs=1
+ call initialize
+ call openunits
+ write (iout,'(80(1h*)/a/80(1h*))')
+ & 'United-residue force field calculation - serial job.'
+ return
+ end
+#endif
--- /dev/null
+#ifdef MPI
+ subroutine MREMD
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'mpif.h'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+#ifndef LANG0
+ include 'COMMON.LANGEVIN'
+#else
+ include 'COMMON.LANGEVIN.lang0'
+#endif
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ include 'COMMON.TIME1'
+ include 'COMMON.REMD'
+ include 'COMMON.SETUP'
+ include 'COMMON.MUCA'
+ integer ERRCODE
+ double precision cm(3),L(3),vcm(3)
+ double precision energia(0:n_ene)
+ double precision remd_t_bath(maxprocs)
+ integer iremd_iset(maxprocs)
+ integer*2 i_index
+ & (maxprocs/4,maxprocs/20,maxprocs/200,maxprocs/200)
+ double precision remd_ene(0:n_ene+4,maxprocs),t_bath_old
+ integer iremd_acc(maxprocs),iremd_tot(maxprocs)
+ integer iremd_acc_usa(maxprocs),iremd_tot_usa(maxprocs)
+ integer ilen,rstcount
+ external ilen
+ character*50 tytul
+ common /gucio/ cm
+ integer itime
+cold integer nup(0:maxprocs),ndown(0:maxprocs)
+ integer rep2i(0:maxprocs),ireqi(maxprocs)
+ integer icache_all(maxprocs)
+ integer status(MPI_STATUS_SIZE),statusi(MPI_STATUS_SIZE,maxprocs)
+ logical synflag,end_of_run,file_exist /.false./,ovrtim
+ real ene_tol /1.0e-5/
+
+cdeb imin_itime_old=0
+ ntwx_cache=0
+ time00=MPI_WTIME()
+ time01=time00
+ if(me.eq.king.or..not.out1file) then
+ write (iout,*) 'MREMD',nodes,'time before',time00-walltime
+ write (iout,*) "NREP=",nrep
+ endif
+
+ synflag=.false.
+ if (ilen(tmpdir).gt.0 .and. (me.eq.king)) then
+ call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_mremd.rst")
+ endif
+ mremd_rst_name=prefix(:ilen(prefix))//"_mremd.rst"
+
+cd print *,'MREMD',nodes
+cd print *,'mmm',me,remd_mlist,(remd_m(i),i=1,nrep)
+cde write (iout,*) "Start MREMD: me",me," t_bath",t_bath
+
+ if(hremd.gt.0) then
+ nset=hremd
+ do i=1,nset
+ mset(i)=1
+ enddo
+ endif
+
+ k=0
+ rep2i(k)=-1
+ do il=1,max0(nset,1)
+ do il1=1,max0(mset(il),1)
+ do i=1,nrep
+ iremd_acc(i)=0
+ iremd_acc_usa(i)=0
+ iremd_tot(i)=0
+ do j=1,remd_m(i)
+ i2rep(k)=i
+ i2set(k)=il
+ rep2i(i)=k
+ k=k+1
+ i_index(i,j,il,il1)=k
+ enddo
+ enddo
+ enddo
+ enddo
+
+ if(me.eq.king.or..not.out1file) then
+ write(iout,*) "i2rep",(i2rep(i),i=0,nodes-1)
+ write(iout,*) "i2set",(i2set(i),i=0,nodes-1)
+ write(iout,*) "i,j,il,il1,i_index(i,j,il,il1)"
+ do il=1,nset
+ do il1=1,mset(il)
+ do i=1,nrep
+ do j=1,remd_m(i)
+ write(iout,*) i,j,il,il1,i_index(i,j,il,il1)
+ enddo
+ enddo
+ enddo
+ enddo
+ endif
+
+c print *,'i2rep',me,i2rep(me)
+c print *,'rep2i',(rep2i(i),i=0,nrep)
+
+cold if (i2rep(me).eq.nrep) then
+cold nup(0)=0
+cold else
+cold nup(0)=remd_m(i2rep(me)+1)
+cold k=rep2i(int(i2rep(me)))+1
+cold do i=1,nup(0)
+cold nup(i)=k
+cold k=k+1
+cold enddo
+cold endif
+
+cd print '(i4,a4,100i4)',me,' nup',(nup(i),i=0,nup(0))
+
+cold if (i2rep(me).eq.1) then
+cold ndown(0)=0
+cold else
+cold ndown(0)=remd_m(i2rep(me)-1)
+cold k=rep2i(i2rep(me)-2)+1
+cold do i=1,ndown(0)
+cold ndown(i)=k
+cold k=k+1
+cold enddo
+cold endif
+
+cd print '(i4,a6,100i4)',me,' ndown',(ndown(i),i=0,ndown(0))
+
+
+ write (*,*) "Processor",me," rest",rest,"
+ & restart1fie",restart1file
+ if(rest.and.restart1file) then
+ if (me.eq.king)
+ & inquire(file=mremd_rst_name,exist=file_exist)
+cd write (*,*) me," Before broadcast: file_exist",file_exist
+ call MPI_Bcast(file_exist,1,MPI_LOGICAL,king,CG_COMM,
+ & IERR)
+cd write (*,*) me," After broadcast: file_exist",file_exist
+ if(file_exist) then
+ if(me.eq.king.or..not.out1file)
+ & write (iout,*) 'Master is reading restart1file'
+ call read1restart(i_index)
+ else
+ if(me.eq.king.or..not.out1file)
+ & write (iout,*) 'WARNING : no restart1file'
+ endif
+
+ if(me.eq.king.or..not.out1file) then
+ write(iout,*) "i2set",(i2set(i),i=0,nodes-1)
+ write(iout,*) "i_index"
+ do il=1,nset
+ do il1=1,mset(il)
+ do i=1,nrep
+ do j=1,remd_m(i)
+ write(iout,*) i,j,il,il1,i_index(i,j,il,il1)
+ enddo
+ enddo
+ enddo
+ enddo
+ endif
+ endif
+
+ if(me.eq.king) then
+ if (rest.and..not.restart1file)
+ & inquire(file=mremd_rst_name,exist=file_exist)
+ if(.not.file_exist.and.rest.and..not.restart1file)
+ & write(iout,*) 'WARNING : no restart file',mremd_rst_name
+ IF (rest.and.file_exist.and..not.restart1file) THEN
+ write (iout,*) 'Master is reading restart file',
+ & mremd_rst_name
+ open(irest2,file=mremd_rst_name,status='unknown')
+ read (irest2,*)
+ read (irest2,*) (i2rep(i),i=0,nodes-1)
+ read (irest2,*)
+ read (irest2,*) (ifirst(i),i=1,remd_m(1))
+ do il=1,nodes
+ read (irest2,*)
+ read (irest2,*) nupa(0,il),(nupa(i,il),i=1,nupa(0,il))
+ read (irest2,*)
+ read (irest2,*) ndowna(0,il),
+ & (ndowna(i,il),i=1,ndowna(0,il))
+ enddo
+ if(usampl.or.hremd.gt.0) then
+ read (irest2,*)
+ read (irest2,*) nset
+ read (irest2,*)
+ read (irest2,*) (mset(i),i=1,nset)
+ read (irest2,*)
+ read (irest2,*) (i2set(i),i=0,nodes-1)
+ read (irest2,*)
+ do il=1,nset
+ do il1=1,mset(il)
+ do i=1,nrep
+ read(irest2,*) (i_index(i,j,il,il1),j=1,remd_m(i))
+ enddo
+ enddo
+ enddo
+
+ write(iout,*) "i2set",(i2set(i),i=0,nodes-1)
+ write(iout,*) "i_index"
+ do il=1,nset
+ do il1=1,mset(il)
+ do i=1,nrep
+ do j=1,remd_m(i)
+ write(iout,*) i,j,il,il1,i_index(i,j,il,il1)
+ enddo
+ enddo
+ enddo
+ enddo
+ endif
+
+ close(irest2)
+
+ write (iout,'(a6,1000i5)') "i2rep",(i2rep(i),i=0,nodes-1)
+ write (iout,'(a6,1000i5)') "ifirst",
+ & (ifirst(i),i=1,remd_m(1))
+ do il=1,nodes
+ write (iout,'(a6,i4,a1,100i4)') "nupa",il,":",
+ & (nupa(i,il),i=1,nupa(0,il))
+ write (iout,'(a6,i4,a1,100i4)') "ndowna",il,":",
+ & (ndowna(i,il),i=1,ndowna(0,il))
+ enddo
+ ELSE IF (.not.(rest.and.file_exist)) THEN
+ do il=1,remd_m(1)
+ ifirst(il)=il
+ enddo
+
+ do il=1,nodes
+ if (i2rep(il-1).eq.nrep) then
+ nupa(0,il)=0
+ else
+ nupa(0,il)=remd_m(i2rep(il-1)+1)
+ k=rep2i(int(i2rep(il-1)))+1
+ do i=1,nupa(0,il)
+ nupa(i,il)=k+1
+ k=k+1
+ enddo
+ endif
+ if (i2rep(il-1).eq.1) then
+ ndowna(0,il)=0
+ else
+ ndowna(0,il)=remd_m(i2rep(il-1)-1)
+ k=rep2i(i2rep(il-1)-2)+1
+ do i=1,ndowna(0,il)
+ ndowna(i,il)=k+1
+ k=k+1
+ enddo
+ endif
+ enddo
+
+ write (iout,'(a6,100i4)') "ifirst",
+ & (ifirst(i),i=1,remd_m(1))
+ do il=1,nodes
+ write (iout,'(a6,i4,a1,100i4)') "nupa",il,":",
+ & (nupa(i,il),i=1,nupa(0,il))
+ write (iout,'(a6,i4,a1,100i4)') "ndowna",il,":",
+ & (ndowna(i,il),i=1,ndowna(0,il))
+ enddo
+
+ ENDIF
+ endif
+c
+c t_bath=retmin+(retmax-retmin)*me/(nodes-1)
+ if(.not.(rest.and.file_exist.and.restart1file)) then
+ if (me .eq. king) then
+ t_bath=retmin
+ else
+ t_bath=retmin+(retmax-retmin)*exp(float(i2rep(me)-nrep))
+ endif
+cd print *,'ttt',me,remd_tlist,(remd_t(i),i=1,nrep)
+ if (remd_tlist) t_bath=remd_t(int(i2rep(me)))
+
+ endif
+ if(usampl.or.hremd.gt.0) then
+ iset=i2set(me)
+ if (hremd.gt.0) call set_hweights(iset)
+ if(me.eq.king.or..not.out1file)
+ & write(iout,*) me,"iset=",iset,"t_bath=",t_bath
+ endif
+c
+ stdfp=dsqrt(2*Rb*t_bath/d_time)
+ do i=1,ntyp
+ stdfsc(i)=dsqrt(2*Rb*t_bath/d_time)
+ enddo
+
+c print *,'irep',me,t_bath
+ if (.not.rest) then
+ if (me.eq.king .or. .not. out1file)
+ & write (iout,'(a60,f10.5)') "REMD Temperature:",t_bath
+ call rescale_weights(t_bath)
+ endif
+
+
+c------copy MD--------------
+c The driver for molecular dynamics subroutines
+c------------------------------------------------
+ t_MDsetup=0.0d0
+ t_langsetup=0.0d0
+ t_MD=0.0d0
+ t_enegrad=0.0d0
+ t_sdsetup=0.0d0
+ if(me.eq.king.or..not.out1file)
+ & write (iout,'(20(1h=),a20,20(1h=))') "MD calculation started"
+#ifdef MPI
+ tt0 = MPI_Wtime()
+#else
+ tt0 = tcpu()
+#endif
+c Determine the inverse of the inertia matrix.
+ call setup_MD_matrices
+c Initialize MD
+ call init_MD
+ if (rest) then
+ if (me.eq.king .or. .not. out1file)
+ & write (iout,'(a60,f10.5)') "REMD restart Temperature:",t_bath
+ stdfp=dsqrt(2*Rb*t_bath/d_time)
+ do i=1,ntyp
+ stdfsc(i)=dsqrt(2*Rb*t_bath/d_time)
+ enddo
+ if (lang.gt.0 .and. .not.surfarea) then
+ do i=nnt,nct-1
+ stdforcp(i)=stdfp*dsqrt(gamp)
+ enddo
+ do i=nnt,nct
+ stdforcsc(i)=stdfsc(itype(i))*dsqrt(gamsc(itype(i)))
+ enddo
+ elseif (lang.gt.0 .and. surfarea ) then
+ call setup_fricmat
+ endif
+ call rescale_weights(t_bath)
+ endif
+
+#ifdef MPI
+ t_MDsetup = MPI_Wtime()-tt0
+#else
+ t_MDsetup = tcpu()-tt0
+#endif
+ rstcount=0
+c Entering the MD loop
+#ifdef MPI
+ tt0 = MPI_Wtime()
+#else
+ tt0 = tcpu()
+#endif
+ if (lang.eq.2 .or. lang.eq.3) then
+#ifndef LANG0
+ call setup_fricmat
+ if (lang.eq.2) then
+ call sd_verlet_p_setup
+ else
+ call sd_verlet_ciccotti_setup
+ endif
+ do i=1,dimen
+ do j=1,dimen
+ pfric0_mat(i,j,0)=pfric_mat(i,j)
+ afric0_mat(i,j,0)=afric_mat(i,j)
+ vfric0_mat(i,j,0)=vfric_mat(i,j)
+ prand0_mat(i,j,0)=prand_mat(i,j)
+ vrand0_mat1(i,j,0)=vrand_mat1(i,j)
+ vrand0_mat2(i,j,0)=vrand_mat2(i,j)
+ enddo
+ enddo
+ flag_stoch(0)=.true.
+ do i=1,maxflag_stoch
+ flag_stoch(i)=.false.
+ enddo
+#else
+ write (iout,*)
+ & "LANG=2 or 3 NOT SUPPORTED. Recompile without -DLANG0"
+#ifdef MPI
+ call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE)
+#endif
+ stop
+#endif
+ else if (lang.eq.1 .or. lang.eq.4) then
+ call setup_fricmat
+ endif
+ time00=MPI_WTIME()
+ if (me.eq.king .or. .not. out1file)
+ & write(iout,*) 'Setup time',time00-walltime
+ctime call flush(iout)
+#ifdef MPI
+ t_langsetup=MPI_Wtime()-tt0
+ tt0=MPI_Wtime()
+#else
+ t_langsetup=tcpu()-tt0
+ tt0=tcpu()
+#endif
+ itime=0
+ end_of_run=.false.
+ do while(.not.end_of_run)
+ itime=itime+1
+ if(itime.eq.n_timestep.and.me.eq.king) end_of_run=.true.
+ if(mremdsync.and.itime.eq.n_timestep) end_of_run=.true.
+ rstcount=rstcount+1
+ if (lang.gt.0 .and. surfarea .and.
+ & mod(itime,reset_fricmat).eq.0) then
+ if (lang.eq.2 .or. lang.eq.3) then
+#ifndef LANG0
+ call setup_fricmat
+ if (lang.eq.2) then
+ call sd_verlet_p_setup
+ else
+ call sd_verlet_ciccotti_setup
+ endif
+ do i=1,dimen
+ do j=1,dimen
+ pfric0_mat(i,j,0)=pfric_mat(i,j)
+ afric0_mat(i,j,0)=afric_mat(i,j)
+ vfric0_mat(i,j,0)=vfric_mat(i,j)
+ prand0_mat(i,j,0)=prand_mat(i,j)
+ vrand0_mat1(i,j,0)=vrand_mat1(i,j)
+ vrand0_mat2(i,j,0)=vrand_mat2(i,j)
+ enddo
+ enddo
+ flag_stoch(0)=.true.
+ do i=1,maxflag_stoch
+ flag_stoch(i)=.false.
+ enddo
+#endif
+ else if (lang.eq.1 .or. lang.eq.4) then
+ call setup_fricmat
+ endif
+ write (iout,'(a,i10)')
+ & "Friction matrix reset based on surface area, itime",itime
+ endif
+ if (reset_vel .and. tbf .and. lang.eq.0
+ & .and. mod(itime,count_reset_vel).eq.0) then
+ call random_vel
+ if (me.eq.king .or. .not. out1file)
+ & write(iout,'(a,f20.2)')
+ & "Velocities reset to random values, time",totT
+ do i=0,2*nres
+ do j=1,3
+ d_t_old(j,i)=d_t(j,i)
+ enddo
+ enddo
+ endif
+ if (reset_moment .and. mod(itime,count_reset_moment).eq.0) then
+ call inertia_tensor
+ call vcm_vel(vcm)
+ do j=1,3
+ d_t(j,0)=d_t(j,0)-vcm(j)
+ enddo
+ call kinetic(EK)
+ kinetic_T=2.0d0/(dimen3*Rb)*EK
+ scalfac=dsqrt(T_bath/kinetic_T)
+cd write(iout,'(a,f20.2)') "Momenta zeroed out, time",totT
+ do i=0,2*nres
+ do j=1,3
+ d_t_old(j,i)=scalfac*d_t(j,i)
+ enddo
+ enddo
+ endif
+ if (lang.ne.4) then
+ if (RESPA) then
+c Time-reversible RESPA algorithm
+c (Tuckerman et al., J. Chem. Phys., 97, 1990, 1992)
+ call RESPA_step(itime)
+ else
+c Variable time step algorithm.
+ call velverlet_step(itime)
+ endif
+ else
+#ifdef BROWN
+ call brown_step(itime)
+#else
+ print *,"Brown dynamics not here!"
+#ifdef MPI
+ call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE)
+#endif
+ stop
+#endif
+ endif
+ if(hmc.gt.0 .and. mod(itime,hmc).eq.0) then
+ call statout(itime)
+ call hmc_test(itime)
+ endif
+ if(ntwe.ne.0) then
+ if (mod(itime,ntwe).eq.0) call statout(itime)
+ endif
+ if (mod(itime,ntwx).eq.0.and..not.traj1file) then
+ write (tytul,'("time",f8.2," temp",f8.1)') totT,t_bath
+ if(mdpdb) then
+ call pdbout(potE,tytul,ipdb)
+ else
+ call cartout(totT)
+ endif
+ endif
+ if (mod(itime,ntwx).eq.0.and.traj1file) then
+ if(ntwx_cache.lt.max_cache_traj_use) then
+ ntwx_cache=ntwx_cache+1
+ else
+ if (max_cache_traj_use.ne.1)
+ & print *,itime,"processor ",me," over cache ",ntwx_cache
+ do i=1,ntwx_cache-1
+
+ totT_cache(i)=totT_cache(i+1)
+ EK_cache(i)=EK_cache(i+1)
+ potE_cache(i)=potE_cache(i+1)
+ t_bath_cache(i)=t_bath_cache(i+1)
+ Uconst_cache(i)=Uconst_cache(i+1)
+ iset_cache(i)=iset_cache(i+1)
+
+ do ii=1,nfrag
+ qfrag_cache(ii,i)=qfrag_cache(ii,i+1)
+ enddo
+ do ii=1,npair
+ qpair_cache(ii,i)=qpair_cache(ii,i+1)
+ enddo
+ do ii=1,nfrag_back
+ utheta_cache(ii,i)=utheta_cache(ii,i+1)
+ ugamma_cache(ii,i)=ugamma_cache(ii,i+1)
+ uscdiff_cache(ii,i)=uscdiff_cache(ii,i+1)
+ enddo
+
+
+ do ii=1,nres*2
+ do j=1,3
+ c_cache(j,ii,i)=c_cache(j,ii,i+1)
+ enddo
+ enddo
+ enddo
+ endif
+
+ totT_cache(ntwx_cache)=totT
+ EK_cache(ntwx_cache)=EK
+ potE_cache(ntwx_cache)=potE
+ t_bath_cache(ntwx_cache)=t_bath
+ Uconst_cache(ntwx_cache)=Uconst
+ iset_cache(ntwx_cache)=iset
+
+ do i=1,nfrag
+ qfrag_cache(i,ntwx_cache)=qfrag(i)
+ enddo
+ do i=1,npair
+ qpair_cache(i,ntwx_cache)=qpair(i)
+ enddo
+ do i=1,nfrag_back
+ utheta_cache(i,ntwx_cache)=utheta(i)
+ ugamma_cache(i,ntwx_cache)=ugamma(i)
+ uscdiff_cache(i,ntwx_cache)=uscdiff(i)
+ enddo
+
+ do i=1,nres*2
+ do j=1,3
+ c_cache(j,i,ntwx_cache)=c(j,i)
+ enddo
+ enddo
+
+ endif
+ if ((rstcount.eq.1000.or.itime.eq.n_timestep)
+ & .and..not.restart1file) then
+
+ if(me.eq.king) then
+ open(irest1,file=mremd_rst_name,status='unknown')
+ write (irest1,*) "i2rep"
+ write (irest1,*) (i2rep(i),i=0,nodes-1)
+ write (irest1,*) "ifirst"
+ write (irest1,*) (ifirst(i),i=1,remd_m(1))
+ do il=1,nodes
+ write (irest1,*) "nupa",il
+ write (irest1,*) nupa(0,il),(nupa(i,il),i=1,nupa(0,il))
+ write (irest1,*) "ndowna",il
+ write (irest1,*) ndowna(0,il),
+ & (ndowna(i,il),i=1,ndowna(0,il))
+ enddo
+ if(usampl.or.hremd.gt.0) then
+ write (irest1,*) "nset"
+ write (irest1,*) nset
+ write (irest1,*) "mset"
+ write (irest1,*) (mset(i),i=1,nset)
+ write (irest1,*) "i2set"
+ write (irest1,*) (i2set(i),i=0,nodes-1)
+ write (irest1,*) "i_index"
+ do il=1,nset
+ do il1=1,mset(il)
+ do i=1,nrep
+ write(irest1,*) (i_index(i,j,il,il1),j=1,remd_m(i))
+ enddo
+ enddo
+ enddo
+
+ endif
+ close(irest1)
+ endif
+ open(irest2,file=rest2name,status='unknown')
+ write(irest2,*) totT,EK,potE,totE,t_bath
+ do i=1,2*nres
+ write (irest2,'(3e15.5)') (d_t(j,i),j=1,3)
+ enddo
+ do i=1,2*nres
+ write (irest2,'(3e15.5)') (dc(j,i),j=1,3)
+ enddo
+ if(usampl.or.hremd.gt.0) then
+ write (irest2,*) iset
+ endif
+ close(irest2)
+ rstcount=0
+ endif
+
+c REMD - exchange
+c forced synchronization
+ if (mod(itime,i_sync_step).eq.0 .and. me.ne.king
+ & .and. .not. mremdsync) then
+ synflag=.false.
+ call mpi_iprobe(0,101,CG_COMM,synflag,status,ierr)
+ if (synflag) then
+ call mpi_recv(itime_master, 1, MPI_INTEGER,
+ & 0,101,CG_COMM, status, ierr)
+ call mpi_barrier(CG_COMM, ierr)
+cdeb if (out1file.or.traj1file) then
+cdeb call mpi_gather(itime,1,mpi_integer,
+cdeb & icache_all,1,mpi_integer,king,
+cdeb & CG_COMM,ierr)
+ if(traj1file)
+ & call mpi_gather(ntwx_cache,1,mpi_integer,
+ & icache_all,1,mpi_integer,king,
+ & CG_COMM,ierr)
+ if (.not.out1file)
+ & write(iout,*) 'REMD synchro at',itime_master,itime
+ if (itime_master.ge.n_timestep .or. ovrtim())
+ & end_of_run=.true.
+ctime call flush(iout)
+ endif
+ endif
+
+c REMD - exchange
+ if ((mod(itime,nstex).eq.0.and.me.eq.king
+ & .or.end_of_run.and.me.eq.king )
+ & .and. .not. mremdsync ) then
+ synflag=.true.
+ time01_=MPI_WTIME()
+ do i=1,nodes-1
+ call mpi_isend(itime,1,MPI_INTEGER,i,101,
+ & CG_COMM, ireqi(i), ierr)
+cd write(iout,*) 'REMD synchro with',i
+cd call flush(iout)
+ enddo
+ call mpi_waitall(nodes-1,ireqi,statusi,ierr)
+ call mpi_barrier(CG_COMM, ierr)
+ time01=MPI_WTIME()
+ write(iout,*) 'REMD synchro at',itime,'time=',time01-time01_
+ if (out1file.or.traj1file) then
+cdeb call mpi_gather(itime,1,mpi_integer,
+cdeb & itime_all,1,mpi_integer,king,
+cdeb & CG_COMM,ierr)
+cdeb write(iout,'(a19,8000i8)') ' REMD synchro itime',
+cdeb & (itime_all(i),i=1,nodes)
+ if(traj1file) then
+cdeb imin_itime=itime_all(1)
+cdeb do i=2,nodes
+cdeb if(itime_all(i).lt.imin_itime) imin_itime=itime_all(i)
+cdeb enddo
+cdeb ii_write=(imin_itime-imin_itime_old)/ntwx
+cdeb imin_itime_old=int(imin_itime/ntwx)*ntwx
+cdeb write(iout,*) imin_itime,imin_itime_old,ii_write
+ call mpi_gather(ntwx_cache,1,mpi_integer,
+ & icache_all,1,mpi_integer,king,
+ & CG_COMM,ierr)
+c write(iout,'(a19,8000i8)') ' ntwx_cache',
+c & (icache_all(i),i=1,nodes)
+ ii_write=icache_all(1)
+ do i=2,nodes
+ if(icache_all(i).lt.ii_write) ii_write=icache_all(i)
+ enddo
+c write(iout,*) "MIN ii_write=",ii_write
+ endif
+ endif
+ctime call flush(iout)
+ endif
+ if(mremdsync .and. mod(itime,nstex).eq.0) then
+ synflag=.true.
+ if (me.eq.king .or. .not. out1file)
+ & write(iout,*) 'REMD synchro at',itime
+
+ if(traj1file) then
+ call mpi_gather(ntwx_cache,1,mpi_integer,
+ & icache_all,1,mpi_integer,king,
+ & CG_COMM,ierr)
+ if (me.eq.king) then
+ write(iout,'(a19,8000i8)') ' ntwx_cache',
+ & (icache_all(i),i=1,nodes)
+ ii_write=icache_all(1)
+ do i=2,nodes
+ if(icache_all(i).lt.ii_write) ii_write=icache_all(i)
+ enddo
+ write(iout,*) "MIN ii_write=",ii_write
+ endif
+ endif
+ctest call flush(iout)
+ endif
+ if (synflag) then
+c Update the time safety limiy
+ if (time001-time00.gt.safety) then
+ safety=time001-time00+600
+ if (me.eq.king .or. .not. out1file)
+ & write (iout,*) "****** SAFETY increased to",safety," s"
+ endif
+ if (ovrtim()) end_of_run=.true.
+ endif
+ if(synflag.and..not.end_of_run) then
+ time02=MPI_WTIME()
+ synflag=.false.
+
+c write(iout,*) 'REMD before',me,t_bath
+
+c call mpi_gather(t_bath,1,mpi_double_precision,
+c & remd_t_bath,1,mpi_double_precision,king,
+c & CG_COMM,ierr)
+ potEcomp(n_ene+1)=t_bath
+ t_bath_old=t_bath
+ if (usampl) then
+ potEcomp(n_ene+2)=iset
+ if (iset.lt.nset) then
+ i_set_temp=iset
+ iset=iset+1
+ call EconstrQ
+ potEcomp(n_ene+3)=Uconst
+ iset=i_set_temp
+ endif
+ if (iset.gt.1) then
+ i_set_temp=iset
+ iset=iset-1
+ call EconstrQ
+ potEcomp(n_ene+4)=Uconst
+ iset=i_set_temp
+ endif
+ endif
+ if(hremd.gt.0) potEcomp(n_ene+2)=iset
+ call mpi_gather(potEcomp(0),n_ene+5,mpi_double_precision,
+ & remd_ene(0,1),n_ene+5,mpi_double_precision,king,
+ & CG_COMM,ierr)
+ if(lmuca) then
+ call mpi_gather(elow,1,mpi_double_precision,
+ & elowi,1,mpi_double_precision,king,
+ & CG_COMM,ierr)
+ call mpi_gather(ehigh,1,mpi_double_precision,
+ & ehighi,1,mpi_double_precision,king,
+ & CG_COMM,ierr)
+ endif
+
+ time03=MPI_WTIME()
+ if (me.eq.king .or. .not. out1file) then
+ write(iout,*) 'REMD gather times=',time03-time01
+ & ,time03-time02
+ endif
+
+ if (restart1file) call write1rst(i_index)
+
+ time04=MPI_WTIME()
+ if (me.eq.king .or. .not. out1file) then
+ write(iout,*) 'REMD writing rst time=',time04-time03
+ endif
+
+ if (traj1file) call write1traj
+cd debugging
+cdeb call mpi_gather(ntwx_cache,1,mpi_integer,
+cdeb & icache_all,1,mpi_integer,king,
+cdeb & CG_COMM,ierr)
+cdeb write(iout,'(a19,8000i8)') ' ntwx_cache after traj1file',
+cdeb & (icache_all(i),i=1,nodes)
+cd end
+
+
+ time05=MPI_WTIME()
+ if (me.eq.king .or. .not. out1file) then
+ write(iout,*) 'REMD writing traj time=',time05-time04
+ctime call flush(iout)
+ endif
+
+
+ if (me.eq.king) then
+ do i=1,nodes
+ remd_t_bath(i)=remd_ene(n_ene+1,i)
+ iremd_iset(i)=remd_ene(n_ene+2,i)
+ enddo
+#ifdef DEBUG
+ if(lmuca) then
+co write(iout,*) 'REMD exchange temp,ene,elow,ehigh'
+ do i=1,nodes
+ write(iout,'(i4,4f12.5)') i,remd_t_bath(i),remd_ene(0,i),
+ & elowi(i),ehighi(i)
+ enddo
+ else
+ write(iout,*) 'REMD exchange temp,ene'
+ do i=1,nodes
+ write(iout,'(i4,2f12.5)') i,remd_t_bath(i),remd_ene(0,i)
+ write(iout,'(6f12.5)') (remd_ene(j,i),j=1,n_ene)
+ enddo
+ endif
+#endif
+c-------------------------------------
+ IF(.not.usampl.and.hremd.eq.0) THEN
+#ifdef DEBUG
+ write (iout,*) "Enter exchnge, remd_m",remd_m(1),
+ & " nodes",nodes
+ctime call flush(iout)
+ write (iout,*) "remd_m(1)",remd_m(1)
+#endif
+ do irr=1,remd_m(1)
+ i=ifirst(iran_num(1,remd_m(1)))
+#ifdef DEBUG
+ write (iout,*) "i",i
+#endif
+ctime call flush(iout)
+
+ do ii=1,nodes-1
+
+#ifdef DEBUG
+ write (iout,*) "i",i," nupa(0,i)",int(nupa(0,i))
+#endif
+ if(i.gt.0.and.nupa(0,i).gt.0) then
+ iex=i
+c if (i.eq.1 .and. int(nupa(0,i)).eq.1) then
+c write (iout,*)
+c & "CHUJ ABSOLUTNY!!! No way to sample a distinct replica in MREMD"
+c call flush(iout)
+c call MPI_Abort(MPI_COMM_WORLD,ERRCODE,ierr)
+c endif
+c do while (iex.eq.i)
+c write (iout,*) "upper",nupa(int(nupa(0,i)),i)
+ iex=nupa(iran_num(1,int(nupa(0,i))),i)
+c enddo
+c write (iout,*) "nupa(0,i)",nupa(0,i)," iex",iex
+ if (lmuca) then
+ call muca_delta(remd_t_bath,remd_ene,i,iex,delta)
+ else
+c Swap temperatures between conformations i and iex with recalculating the free energies
+c following temperature changes.
+ ene_iex_iex=remd_ene(0,iex)
+ ene_i_i=remd_ene(0,i)
+c write (iout,*) "i",i," ene_i_i",ene_i_i,
+c & " iex",iex," ene_iex_iex",ene_iex_iex
+c write (iout,*) "rescaling weights with temperature",
+c & remd_t_bath(i)
+c call flush(iout)
+ call rescale_weights(remd_t_bath(i))
+
+c write (iout,*) "0,iex",remd_t_bath(i)
+c call enerprint(remd_ene(0,iex))
+
+ call sum_energy(remd_ene(0,iex),.false.)
+ ene_iex_i=remd_ene(0,iex)
+c write (iout,*) "ene_iex_i",remd_ene(0,iex)
+
+c write (iout,*) "0,i",remd_t_bath(i)
+c call enerprint(remd_ene(0,i))
+
+ call sum_energy(remd_ene(0,i),.false.)
+c write (iout,*) "ene_i_i",remd_ene(0,i)
+c call flush(iout)
+c write (iout,*) "rescaling weights with temperature",
+c & remd_t_bath(iex)
+ if (abs(ene_i_i-remd_ene(0,i)).gt.ene_tol) then
+ write (iout,*) "ERROR: inconsistent energies:",i,
+ & ene_i_i,remd_ene(0,i)
+ endif
+ call rescale_weights(remd_t_bath(iex))
+
+c write (iout,*) "0,i",remd_t_bath(iex)
+c call enerprint(remd_ene(0,i))
+
+ call sum_energy(remd_ene(0,i),.false.)
+c write (iout,*) "ene_i_iex",remd_ene(0,i)
+c call flush(iout)
+ ene_i_iex=remd_ene(0,i)
+
+c write (iout,*) "0,iex",remd_t_bath(iex)
+c call enerprint(remd_ene(0,iex))
+
+ call sum_energy(remd_ene(0,iex),.false.)
+ if (abs(ene_iex_iex-remd_ene(0,iex)).gt.ene_tol) then
+ write (iout,*) "ERROR: inconsistent energies:",iex,
+ & ene_iex_iex,remd_ene(0,iex)
+ endif
+c write (iout,*) "ene_iex_iex",remd_ene(0,iex)
+c write (iout,*) "i",i," iex",iex
+c write (iout,'(4(a,e15.5))') "ene_i_i",ene_i_i,
+c & " ene_i_iex",ene_i_iex,
+c & " ene_iex_i",ene_iex_i," ene_iex_iex",ene_iex_iex
+c call flush(iout)
+ delta=(ene_iex_iex-ene_i_iex)/(Rb*remd_t_bath(iex))-
+ & (ene_iex_i-ene_i_i)/(Rb*remd_t_bath(i))
+ delta=-delta
+c write(iout,*) 'delta',delta
+c delta=(remd_t_bath(i)-remd_t_bath(iex))*
+c & (remd_ene(i)-remd_ene(iex))/Rb/
+c & (remd_t_bath(i)*remd_t_bath(iex))
+ endif
+ if (delta .gt. 50.0d0) then
+ delta=0.0d0
+ else
+#ifdef OSF
+ if(isnan(delta))then
+ delta=0.0d0
+ else if (delta.lt.-50.0d0) then
+ delta=dexp(50.0d0)
+ else
+ delta=dexp(-delta)
+ endif
+#else
+ delta=dexp(-delta)
+#endif
+ endif
+ iremd_tot(int(i2rep(i-1)))=iremd_tot(int(i2rep(i-1)))+1
+ xxx=ran_number(0.0d0,1.0d0)
+c write(iout,'(2i4,a6,2f12.5)') i,iex,' delta',delta,xxx
+c call flush(iout)
+ if (delta .gt. xxx) then
+ tmp=remd_t_bath(i)
+ remd_t_bath(i)=remd_t_bath(iex)
+ remd_t_bath(iex)=tmp
+ remd_ene(0,i)=ene_i_iex
+ remd_ene(0,iex)=ene_iex_i
+ if(lmuca) then
+ tmp=elowi(i)
+ elowi(i)=elowi(iex)
+ elowi(iex)=tmp
+ tmp=ehighi(i)
+ ehighi(i)=ehighi(iex)
+ ehighi(iex)=tmp
+ endif
+
+
+ do k=0,nodes
+ itmp=nupa(k,i)
+ nupa(k,i)=nupa(k,iex)
+ nupa(k,iex)=itmp
+ itmp=ndowna(k,i)
+ ndowna(k,i)=ndowna(k,iex)
+ ndowna(k,iex)=itmp
+ enddo
+ do il=1,nodes
+ if (ifirst(il).eq.i) ifirst(il)=iex
+ do k=1,nupa(0,il)
+ if (nupa(k,il).eq.i) then
+ nupa(k,il)=iex
+ elseif (nupa(k,il).eq.iex) then
+ nupa(k,il)=i
+ endif
+ enddo
+ do k=1,ndowna(0,il)
+ if (ndowna(k,il).eq.i) then
+ ndowna(k,il)=iex
+ elseif (ndowna(k,il).eq.iex) then
+ ndowna(k,il)=i
+ endif
+ enddo
+ enddo
+
+ iremd_acc(int(i2rep(i-1)))=iremd_acc(int(i2rep(i-1)))+1
+ itmp=i2rep(i-1)
+ i2rep(i-1)=i2rep(iex-1)
+ i2rep(iex-1)=itmp
+
+c write(iout,*) 'exchange',i,iex
+c write (iout,'(a8,100i4)') "@ ifirst",
+c & (ifirst(k),k=1,remd_m(1))
+c do il=1,nodes
+c write (iout,'(a8,i4,a1,100i4)') "@ nupa",il,":",
+c & (nupa(k,il),k=1,nupa(0,il))
+c write (iout,'(a8,i4,a1,100i4)') "@ ndowna",il,":",
+c & (ndowna(k,il),k=1,ndowna(0,il))
+c enddo
+c call flush(iout)
+
+ else
+ remd_ene(0,iex)=ene_iex_iex
+ remd_ene(0,i)=ene_i_i
+ i=iex
+ endif
+ endif
+ enddo
+ enddo
+cd write (iout,*) "exchange completed"
+cd call flush(iout)
+ ELSEIF (usampl) THEN
+ do ii=1,nodes
+cd write(iout,*) "########",ii
+
+ i_temp=iran_num(1,nrep)
+ i_mult=iran_num(1,remd_m(i_temp))
+ i_iset=iran_num(1,nset)
+ i_mset=iran_num(1,mset(i_iset))
+ i=i_index(i_temp,i_mult,i_iset,i_mset)
+
+cd write(iout,*) "i=",i,i_temp,i_mult,i_iset,i_mset
+
+ if(t_exchange_only)then
+ i_dir=1
+ else
+ i_dir=iran_num(1,3)
+ endif
+cd write(iout,*) "i_dir=",i_dir
+
+ if(i_dir.eq.1 .and. remd_m(i_temp+1).gt.0 )then
+
+ i_temp1=i_temp+1
+ i_mult1=iran_num(1,remd_m(i_temp1))
+ i_iset1=i_iset
+ i_mset1=iran_num(1,mset(i_iset1))
+ iex=i_index(i_temp1,i_mult1,i_iset1,i_mset1)
+
+ elseif(i_dir.eq.2 .and. mset(i_iset+1).gt.0)then
+
+ i_temp1=i_temp
+ i_mult1=iran_num(1,remd_m(i_temp1))
+ i_iset1=i_iset+1
+ i_mset1=iran_num(1,mset(i_iset1))
+ iex=i_index(i_temp1,i_mult1,i_iset1,i_mset1)
+ econstr_temp_i=remd_ene(20,i)
+ econstr_temp_iex=remd_ene(20,iex)
+ remd_ene(20,i)=remd_ene(n_ene+3,i)
+ remd_ene(20,iex)=remd_ene(n_ene+4,iex)
+
+ elseif(remd_m(i_temp+1).gt.0.and.mset(i_iset+1).gt.0)then
+
+ i_temp1=i_temp+1
+ i_mult1=iran_num(1,remd_m(i_temp1))
+ i_iset1=i_iset+1
+ i_mset1=iran_num(1,mset(i_iset1))
+ iex=i_index(i_temp1,i_mult1,i_iset1,i_mset1)
+ econstr_temp_i=remd_ene(20,i)
+ econstr_temp_iex=remd_ene(20,iex)
+ remd_ene(20,i)=remd_ene(n_ene+3,i)
+ remd_ene(20,iex)=remd_ene(n_ene+4,iex)
+
+ else
+ goto 444
+ endif
+
+cd write(iout,*) "iex=",iex,i_temp1,i_mult1,i_iset1,i_mset1
+ctime call flush(iout)
+
+c Swap temperatures between conformations i and iex with recalculating the free energies
+c following temperature changes.
+ ene_iex_iex=remd_ene(0,iex)
+ ene_i_i=remd_ene(0,i)
+co write (iout,*) "rescaling weights with temperature",
+co & remd_t_bath(i)
+ call rescale_weights(remd_t_bath(i))
+
+ call sum_energy(remd_ene(0,iex),.false.)
+ ene_iex_i=remd_ene(0,iex)
+cd write (iout,*) "ene_iex_i",remd_ene(0,iex)
+c call sum_energy(remd_ene(0,i),.false.)
+cd write (iout,*) "ene_i_i",remd_ene(0,i)
+c write (iout,*) "rescaling weights with temperature",
+c & remd_t_bath(iex)
+c if (real(ene_i_i).ne.real(remd_ene(0,i))) then
+c write (iout,*) "ERROR: inconsistent energies:",i,
+c & ene_i_i,remd_ene(0,i)
+c endif
+ call rescale_weights(remd_t_bath(iex))
+ call sum_energy(remd_ene(0,i),.false.)
+cd write (iout,*) "ene_i_iex",remd_ene(0,i)
+ ene_i_iex=remd_ene(0,i)
+c call sum_energy(remd_ene(0,iex),.false.)
+c if (real(ene_iex_iex).ne.real(remd_ene(0,iex))) then
+c write (iout,*) "ERROR: inconsistent energies:",iex,
+c & ene_iex_iex,remd_ene(0,iex)
+c endif
+cd write (iout,*) "ene_iex_iex",remd_ene(0,iex)
+c write (iout,*) "i",i," iex",iex
+cd write (iout,'(4(a,e15.5))') "ene_i_i",ene_i_i,
+cd & " ene_i_iex",ene_i_iex,
+cd & " ene_iex_i",ene_iex_i," ene_iex_iex",ene_iex_iex
+ delta=(ene_iex_iex-ene_i_iex)/(Rb*remd_t_bath(iex))-
+ & (ene_iex_i-ene_i_i)/(Rb*remd_t_bath(i))
+ delta=-delta
+cd write(iout,*) 'delta',delta
+c delta=(remd_t_bath(i)-remd_t_bath(iex))*
+c & (remd_ene(i)-remd_ene(iex))/Rb/
+c & (remd_t_bath(i)*remd_t_bath(iex))
+ if (delta .gt. 50.0d0) then
+ delta=0.0d0
+ else
+ delta=dexp(-delta)
+ endif
+ if (i_dir.eq.1.or.i_dir.eq.3)
+ & iremd_tot(int(i2rep(i-1)))=iremd_tot(int(i2rep(i-1)))+1
+ if (i_dir.eq.2.or.i_dir.eq.3)
+ & iremd_tot_usa(int(i2set(i-1)))=
+ & iremd_tot_usa(int(i2set(i-1)))+1
+ xxx=ran_number(0.0d0,1.0d0)
+cd write(iout,'(2i4,a6,2f12.5)') i,iex,' delta',delta,xxx
+ if (delta .gt. xxx) then
+ tmp=remd_t_bath(i)
+ remd_t_bath(i)=remd_t_bath(iex)
+ remd_t_bath(iex)=tmp
+
+ itmp=iremd_iset(i)
+ iremd_iset(i)=iremd_iset(iex)
+ iremd_iset(iex)=itmp
+
+ remd_ene(0,i)=ene_i_iex
+ remd_ene(0,iex)=ene_iex_i
+
+ if (i_dir.eq.1.or.i_dir.eq.3)
+ & iremd_acc(int(i2rep(i-1)))=iremd_acc(int(i2rep(i-1)))+1
+
+ itmp=i2rep(i-1)
+ i2rep(i-1)=i2rep(iex-1)
+ i2rep(iex-1)=itmp
+
+ if (i_dir.eq.2.or.i_dir.eq.3)
+ & iremd_acc_usa(int(i2set(i-1)))=
+ & iremd_acc_usa(int(i2set(i-1)))+1
+
+ itmp=i2set(i-1)
+ i2set(i-1)=i2set(iex-1)
+ i2set(iex-1)=itmp
+
+ itmp=i_index(i_temp,i_mult,i_iset,i_mset)
+ i_index(i_temp,i_mult,i_iset,i_mset)=
+ & i_index(i_temp1,i_mult1,i_iset1,i_mset1)
+ i_index(i_temp1,i_mult1,i_iset1,i_mset1)=itmp
+
+ else
+ remd_ene(0,iex)=ene_iex_iex
+ remd_ene(0,i)=ene_i_i
+ remd_ene(20,iex)=econstr_temp_iex
+ remd_ene(20,i)=econstr_temp_i
+ endif
+
+cd do il=1,nset
+cd do il1=1,mset(il)
+cd do i=1,nrep
+cd do j=1,remd_m(i)
+cd write(iout,*) i,j,il,il1,i_index(i,j,il,il1)
+cd enddo
+cd enddo
+cd enddo
+cd enddo
+
+ 444 continue
+
+ enddo
+
+ ELSEIF (hremd.gt.0) THEN
+ do ii=1,nodes
+cd write(iout,*) "########",ii
+
+ i_temp=iran_num(1,nrep)
+ i_mult=iran_num(1,remd_m(i_temp))
+ i_iset=iran_num(1,nset)
+ i_mset=1
+ i=i_index(i_temp,i_mult,i_iset,i_mset)
+
+cd write(iout,*) "i=",i,i_temp,i_mult,i_iset,i_mset
+
+ if(t_exchange_only)then
+ i_dir=1
+ else
+ i_dir=iran_num(1,3)
+ endif
+
+cd write(iout,*) "i_dir=",i_dir
+
+ if(i_dir.eq.1 .and. remd_m(i_temp+1).gt.0 )then
+
+ i_temp1=i_temp+1
+ i_mult1=iran_num(1,remd_m(i_temp1))
+ i_iset1=i_iset
+ i_mset1=1
+ iex=i_index(i_temp1,i_mult1,i_iset1,i_mset1)
+
+ elseif(i_dir.eq.2)then
+
+ i_temp1=i_temp
+ i_mult1=iran_num(1,remd_m(i_temp1))
+ i_iset1=iran_num(1,hremd)
+ do while(i_iset1.eq.i_iset)
+ i_iset1=iran_num(1,hremd)
+ enddo
+ i_mset1=1
+ iex=i_index(i_temp1,i_mult1,i_iset1,i_mset1)
+
+ elseif(remd_m(i_temp+1).gt.0)then
+
+ i_temp1=i_temp+1
+ i_mult1=iran_num(1,remd_m(i_temp1))
+ i_iset1=iran_num(1,hremd)
+ do while(i_iset1.eq.i_iset)
+ i_iset1=iran_num(1,hremd)
+ enddo
+ i_mset1=1
+ iex=i_index(i_temp1,i_mult1,i_iset1,i_mset1)
+
+ else
+ goto 445
+ endif
+
+cd write(iout,*) "iex=",iex,i_temp1,i_mult1,i_iset1,i_mset1
+ctime call flush(iout)
+
+c Swap temperatures between conformations i and iex with recalculating the free energies
+c following temperature changes.
+ ene_iex_iex=remd_ene(0,iex)
+ ene_i_i=remd_ene(0,i)
+
+ call set_hweights(i_iset)
+ call rescale_weights(remd_t_bath(i))
+ call sum_energy(remd_ene(0,iex),.false.)
+ ene_iex_i=remd_ene(0,iex)
+
+ call set_hweights(i_iset1)
+ call rescale_weights(remd_t_bath(iex))
+ call sum_energy(remd_ene(0,i),.false.)
+ ene_i_iex=remd_ene(0,i)
+
+cd write(iout,*) ene_iex_iex,ene_i_i,ene_iex_i,ene_i_iex
+
+ delta=(ene_iex_iex-ene_i_iex)/(Rb*remd_t_bath(iex))-
+ & (ene_iex_i-ene_i_i)/(Rb*remd_t_bath(i))
+ delta=-delta
+
+ if (delta .gt. 50.0d0) then
+ delta=0.0d0
+ else
+ delta=dexp(-delta)
+ endif
+
+ if (i_dir.eq.1.or.i_dir.eq.3)
+ & iremd_tot(int(i2rep(i-1)))=iremd_tot(int(i2rep(i-1)))+1
+ if (i_dir.eq.2.or.i_dir.eq.3)
+ & iremd_tot_usa(int(i2set(i-1)))=
+ & iremd_tot_usa(int(i2set(i-1)))+1
+ xxx=ran_number(0.0d0,1.0d0)
+cd write(iout,'(2i4,a6,2f12.5)') i,iex,' delta',delta,xxx
+ if (delta .gt. xxx) then
+
+cd write (iout,*) "exchange"
+ tmp=remd_t_bath(i)
+ remd_t_bath(i)=remd_t_bath(iex)
+ remd_t_bath(iex)=tmp
+
+ itmp=iremd_iset(i)
+ iremd_iset(i)=iremd_iset(iex)
+ iremd_iset(iex)=itmp
+
+ remd_ene(0,i)=ene_i_iex
+ remd_ene(0,iex)=ene_iex_i
+
+ if (i_dir.eq.1.or.i_dir.eq.3)
+ & iremd_acc(int(i2rep(i-1)))=iremd_acc(int(i2rep(i-1)))+1
+
+ itmp=i2rep(i-1)
+ i2rep(i-1)=i2rep(iex-1)
+ i2rep(iex-1)=itmp
+
+ if (i_dir.eq.2.or.i_dir.eq.3)
+ & iremd_acc_usa(int(i2set(i-1)))=
+ & iremd_acc_usa(int(i2set(i-1)))+1
+
+ itmp=i2set(i-1)
+ i2set(i-1)=i2set(iex-1)
+ i2set(iex-1)=itmp
+
+ itmp=i_index(i_temp,i_mult,i_iset,i_mset)
+ i_index(i_temp,i_mult,i_iset,i_mset)=
+ & i_index(i_temp1,i_mult1,i_iset1,i_mset1)
+ i_index(i_temp1,i_mult1,i_iset1,i_mset1)=itmp
+
+cd do il=1,nset
+cd do il1=1,mset(il)
+cd do i=1,nrep
+cd do j=1,remd_m(i)
+cd write(iout,*) i,j,il,il1,i_index(i,j,il,il1)
+cd enddo
+cd enddo
+cd enddo
+cd enddo
+
+ else
+ remd_ene(0,iex)=ene_iex_iex
+ remd_ene(0,i)=ene_i_i
+ endif
+
+
+
+ 445 continue
+
+ enddo
+
+ ENDIF
+
+c-------------------------------------
+ write (iout,*) "NREP",nrep
+ do i=1,nrep
+ if(iremd_tot(i).ne.0)
+ & write(iout,'(a3,i4,2f12.5,i5)') 'ACC',i,remd_t(i)
+ & ,iremd_acc(i)/(1.0*iremd_tot(i)),iremd_tot(i)
+ enddo
+
+ if(usampl) then
+ do i=1,nset
+ if(iremd_tot_usa(i).ne.0)
+ & write(iout,'(a10,i4,f12.5,i8)') 'ACC_usampl',i,
+ & iremd_acc_usa(i)/(1.0*iremd_tot_usa(i)),iremd_tot_usa(i)
+ enddo
+ endif
+
+ if(hremd.gt.0) then
+ do i=1,nset
+ if(iremd_tot_usa(i).ne.0)
+ & write(iout,'(a10,i4,f12.5,i8)') 'ACC_hremd',i,
+ & iremd_acc_usa(i)/(1.0*iremd_tot_usa(i)),iremd_tot_usa(i)
+ enddo
+ endif
+
+
+ctime call flush(iout)
+
+cd write (iout,'(a6,100i4)') "ifirst",
+cd & (ifirst(i),i=1,remd_m(1))
+cd do il=1,nodes
+cd write (iout,'(a5,i4,a1,100i4)') "nup",il,":",
+cd & (nupa(i,il),i=1,nupa(0,il))
+cd write (iout,'(a5,i4,a1,100i4)') "ndown",il,":",
+cd & (ndowna(i,il),i=1,ndowna(0,il))
+cd enddo
+ endif
+
+ time06=MPI_WTIME()
+cd write (iout,*) "Before scatter"
+cd call flush(iout)
+ call mpi_scatter(remd_t_bath,1,mpi_double_precision,
+ & t_bath,1,mpi_double_precision,king,
+ & CG_COMM,ierr)
+cd write (iout,*) "After scatter"
+cd call flush(iout)
+ if(usampl.or.hremd.gt.0)
+ & call mpi_scatter(iremd_iset,1,mpi_integer,
+ & iset,1,mpi_integer,king,
+ & CG_COMM,ierr)
+
+ time07=MPI_WTIME()
+ if (me.eq.king .or. .not. out1file) then
+ write(iout,*) 'REMD scatter time=',time07-time06
+ endif
+
+ if(lmuca) then
+ call mpi_scatter(elowi,1,mpi_double_precision,
+ & elow,1,mpi_double_precision,king,
+ & CG_COMM,ierr)
+ call mpi_scatter(ehighi,1,mpi_double_precision,
+ & ehigh,1,mpi_double_precision,king,
+ & CG_COMM,ierr)
+ endif
+
+ if(hremd.gt.0) call set_hweights(iset)
+ call rescale_weights(t_bath)
+co write (iout,*) "Processor",me,
+co & " rescaling weights with temperature",t_bath
+
+ stdfp=dsqrt(2*Rb*t_bath/d_time)
+ do i=1,ntyp
+ stdfsc(i)=dsqrt(2*Rb*t_bath/d_time)
+ enddo
+ if (lang.gt.0) then
+ do i=nnt,nct-1
+ stdforcp(i)=stdforcp(i)*sqrt(t_bath/t_bath_old)
+ enddo
+ do i=nnt,nct
+ stdforcsc(i)=stdforcsc(i)*sqrt(t_bath/t_bath_old)
+ enddo
+ endif
+cde write(iout,*) 'REMD after',me,t_bath
+ time08=MPI_WTIME()
+ if (me.eq.king .or. .not. out1file) then
+ write(iout,*) 'REMD exchange time=',time08-time02
+ctime call flush(iout)
+ endif
+ endif
+ enddo
+
+ if (restart1file) then
+ if (me.eq.king .or. .not. out1file)
+ & write(iout,*) 'writing restart at the end of run'
+ call write1rst(i_index)
+ endif
+
+ if (traj1file) call write1traj
+cd debugging
+cdeb call mpi_gather(ntwx_cache,1,mpi_integer,
+cdeb & icache_all,1,mpi_integer,king,
+cdeb & CG_COMM,ierr)
+cdeb write(iout,'(a40,8000i8)')
+cdeb & ' ntwx_cache after traj1file at the end',
+cdeb & (icache_all(i),i=1,nodes)
+cd end
+
+
+#ifdef MPI
+ t_MD=MPI_Wtime()-tt0
+#else
+ t_MD=tcpu()-tt0
+#endif
+ if (me.eq.king .or. .not. out1file) then
+ write (iout,'(//35(1h=),a10,35(1h=)/10(/a40,1pe15.5))')
+ & ' Timing ',
+ & 'MD calculations setup:',t_MDsetup,
+ & 'Energy & gradient evaluation:',t_enegrad,
+ & 'Stochastic MD setup:',t_langsetup,
+ & 'Stochastic MD step setup:',t_sdsetup,
+ & 'MD steps:',t_MD
+ write (iout,'(/28(1h=),a25,27(1h=))')
+ & ' End of MD calculation '
+ if(hmc.gt.0) write (iout,*) 'HMC acceptance ratio',
+ & n_timestep*1.0d0/hmc/hmc_acc
+ endif
+ return
+ end
+
+c-----------------------------------------------------------------------
+ subroutine write1rst(i_index)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'mpif.h'
+ include 'COMMON.MD'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.REMD'
+ include 'COMMON.SETUP'
+ include 'COMMON.CHAIN'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.INTERACT'
+
+ real d_restart1(3,2*maxres*maxprocs),r_d(3,2*maxres),
+ & d_restart2(3,2*maxres*maxprocs)
+ real t5_restart1(5)
+ integer iret,itmp
+ integer*2 i_index
+ & (maxprocs/4,maxprocs/20,maxprocs/200,maxprocs/200)
+ common /przechowalnia/ d_restart1,d_restart2
+
+ t5_restart1(1)=totT
+ t5_restart1(2)=EK
+ t5_restart1(3)=potE
+ t5_restart1(4)=t_bath
+ t5_restart1(5)=Uconst
+
+ call mpi_gather(t5_restart1,5,mpi_real,
+ & t_restart1,5,mpi_real,king,CG_COMM,ierr)
+
+
+ do i=1,2*nres
+ do j=1,3
+ r_d(j,i)=d_t(j,i)
+ enddo
+ enddo
+ call mpi_gather(r_d,3*2*nres,mpi_real,
+ & d_restart1,3*2*nres,mpi_real,king,
+ & CG_COMM,ierr)
+
+
+ do i=1,2*nres
+ do j=1,3
+ r_d(j,i)=dc(j,i)
+ enddo
+ enddo
+ call mpi_gather(r_d,3*2*nres,mpi_real,
+ & d_restart2,3*2*nres,mpi_real,king,
+ & CG_COMM,ierr)
+
+ if(me.eq.king) then
+#ifdef AIX
+ call xdrfopen_(ixdrf,mremd_rst_name, "w", iret)
+ do i=0,nodes-1
+ call xdrfint_(ixdrf, i2rep(i), iret)
+ enddo
+ do i=1,remd_m(1)
+ call xdrfint_(ixdrf, ifirst(i), iret)
+ enddo
+ do il=1,nodes
+ do i=0,nupa(0,il)
+ call xdrfint_(ixdrf, nupa(i,il), iret)
+ enddo
+
+ do i=0,ndowna(0,il)
+ call xdrfint_(ixdrf, ndowna(i,il), iret)
+ enddo
+ enddo
+
+ do il=1,nodes
+ do j=1,4
+ call xdrffloat_(ixdrf, t_restart1(j,il), iret)
+ enddo
+ enddo
+
+ do il=0,nodes-1
+ do i=1,2*nres
+ do j=1,3
+ call xdrffloat_(ixdrf, d_restart1(j,i+2*nres*il), iret)
+ enddo
+ enddo
+ enddo
+ do il=0,nodes-1
+ do i=1,2*nres
+ do j=1,3
+ call xdrffloat_(ixdrf, d_restart2(j,i+2*nres*il), iret)
+ enddo
+ enddo
+ enddo
+
+ if(usampl) then
+ call xdrfint_(ixdrf, nset, iret)
+ do i=1,nset
+ call xdrfint_(ixdrf,mset(i), iret)
+ enddo
+ do i=0,nodes-1
+ call xdrfint_(ixdrf,i2set(i), iret)
+ enddo
+ do il=1,nset
+ do il1=1,mset(il)
+ do i=1,nrep
+ do j=1,remd_m(i)
+ itmp=i_index(i,j,il,il1)
+ call xdrfint_(ixdrf,itmp, iret)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ endif
+ call xdrfclose_(ixdrf, iret)
+#else
+ call xdrfopen(ixdrf,mremd_rst_name, "w", iret)
+ do i=0,nodes-1
+ call xdrfint(ixdrf, i2rep(i), iret)
+ enddo
+ do i=1,remd_m(1)
+ call xdrfint(ixdrf, ifirst(i), iret)
+ enddo
+ do il=1,nodes
+ do i=0,nupa(0,il)
+ call xdrfint(ixdrf, nupa(i,il), iret)
+ enddo
+
+ do i=0,ndowna(0,il)
+ call xdrfint(ixdrf, ndowna(i,il), iret)
+ enddo
+ enddo
+
+ do il=1,nodes
+ do j=1,4
+ call xdrffloat(ixdrf, t_restart1(j,il), iret)
+ enddo
+ enddo
+
+ do il=0,nodes-1
+ do i=1,2*nres
+ do j=1,3
+ call xdrffloat(ixdrf, d_restart1(j,i+2*nres*il), iret)
+ enddo
+ enddo
+ enddo
+ do il=0,nodes-1
+ do i=1,2*nres
+ do j=1,3
+ call xdrffloat(ixdrf, d_restart2(j,i+2*nres*il), iret)
+ enddo
+ enddo
+ enddo
+
+
+ if(usampl) then
+ call xdrfint(ixdrf, nset, iret)
+ do i=1,nset
+ call xdrfint(ixdrf,mset(i), iret)
+ enddo
+ do i=0,nodes-1
+ call xdrfint(ixdrf,i2set(i), iret)
+ enddo
+ do il=1,nset
+ do il1=1,mset(il)
+ do i=1,nrep
+ do j=1,remd_m(i)
+ itmp=i_index(i,j,il,il1)
+ call xdrfint(ixdrf,itmp, iret)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ endif
+ call xdrfclose(ixdrf, iret)
+#endif
+ endif
+ return
+ end
+
+
+ subroutine write1traj
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'mpif.h'
+ include 'COMMON.MD'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.REMD'
+ include 'COMMON.SETUP'
+ include 'COMMON.CHAIN'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.INTERACT'
+
+ real t5_restart1(5)
+ integer iret,itmp
+ real xcoord(3,maxres2+2),prec
+ real r_qfrag(50),r_qpair(100)
+ real r_utheta(50),r_ugamma(100),r_uscdiff(100)
+ real p_qfrag(50*maxprocs),p_qpair(100*maxprocs)
+ real p_utheta(50*maxprocs),p_ugamma(100*maxprocs),
+ & p_uscdiff(100*maxprocs)
+ real p_c(3,(maxres2+2)*maxprocs),r_c(3,maxres2+2)
+ common /przechowalnia/ p_c
+
+ call mpi_bcast(ii_write,1,mpi_integer,
+ & king,CG_COMM,ierr)
+
+c debugging
+ print *,'traj1file',me,ii_write,ntwx_cache
+c end debugging
+
+#ifdef AIX
+ if(me.eq.king) call xdrfopen_(ixdrf,cartname, "a", iret)
+#else
+ if(me.eq.king) call xdrfopen(ixdrf,cartname, "a", iret)
+#endif
+ do ii=1,ii_write
+ t5_restart1(1)=totT_cache(ii)
+ t5_restart1(2)=EK_cache(ii)
+ t5_restart1(3)=potE_cache(ii)
+ t5_restart1(4)=t_bath_cache(ii)
+ t5_restart1(5)=Uconst_cache(ii)
+ call mpi_gather(t5_restart1,5,mpi_real,
+ & t_restart1,5,mpi_real,king,CG_COMM,ierr)
+
+ call mpi_gather(iset_cache(ii),1,mpi_integer,
+ & iset_restart1,1,mpi_integer,king,CG_COMM,ierr)
+
+ do i=1,nfrag
+ r_qfrag(i)=qfrag_cache(i,ii)
+ enddo
+ do i=1,npair
+ r_qpair(i)=qpair_cache(i,ii)
+ enddo
+ do i=1,nfrag_back
+ r_utheta(i)=utheta_cache(i,ii)
+ r_ugamma(i)=ugamma_cache(i,ii)
+ r_uscdiff(i)=uscdiff_cache(i,ii)
+ enddo
+
+ call mpi_gather(r_qfrag,nfrag,mpi_real,
+ & p_qfrag,nfrag,mpi_real,king,
+ & CG_COMM,ierr)
+ call mpi_gather(r_qpair,npair,mpi_real,
+ & p_qpair,npair,mpi_real,king,
+ & CG_COMM,ierr)
+ call mpi_gather(r_utheta,nfrag_back,mpi_real,
+ & p_utheta,nfrag_back,mpi_real,king,
+ & CG_COMM,ierr)
+ call mpi_gather(r_ugamma,nfrag_back,mpi_real,
+ & p_ugamma,nfrag_back,mpi_real,king,
+ & CG_COMM,ierr)
+ call mpi_gather(r_uscdiff,nfrag_back,mpi_real,
+ & p_uscdiff,nfrag_back,mpi_real,king,
+ & CG_COMM,ierr)
+
+#ifdef DEBUG
+ write (iout,*) "p_qfrag"
+ do i=1,nodes
+ write (iout,*) i,(p_qfrag((i-1)*nfrag+j),j=1,nfrag)
+ enddo
+ write (iout,*) "p_qpair"
+ do i=1,nodes
+ write (iout,*) i,(p_qpair((i-1)*npair+j),j=1,npair)
+ enddo
+ctime call flush(iout)
+#endif
+ do i=1,nres*2
+ do j=1,3
+ r_c(j,i)=c_cache(j,i,ii)
+ enddo
+ enddo
+
+ call mpi_gather(r_c,3*2*nres,mpi_real,
+ & p_c,3*2*nres,mpi_real,king,
+ & CG_COMM,ierr)
+
+ if(me.eq.king) then
+#ifdef AIX
+ do il=1,nodes
+ call xdrffloat_(ixdrf, real(t_restart1(1,il)), iret)
+ call xdrffloat_(ixdrf, real(t_restart1(3,il)), iret)
+ call xdrffloat_(ixdrf, real(t_restart1(5,il)), iret)
+ call xdrffloat_(ixdrf, real(t_restart1(4,il)), iret)
+ call xdrfint_(ixdrf, nss, iret)
+ do j=1,nss
+ call xdrfint_(ixdrf, ihpb(j), iret)
+ call xdrfint_(ixdrf, jhpb(j), iret)
+ enddo
+ call xdrfint_(ixdrf, nfrag+npair+3*nfrag_back, iret)
+ call xdrfint_(ixdrf, iset_restart1(il), iret)
+ do i=1,nfrag
+ call xdrffloat_(ixdrf, p_qfrag(i+(il-1)*nfrag), iret)
+ enddo
+ do i=1,npair
+ call xdrffloat_(ixdrf, p_qpair(i+(il-1)*npair), iret)
+ enddo
+ do i=1,nfrag_back
+ call xdrffloat_(ixdrf, p_utheta(i+(il-1)*nfrag_back), iret)
+ call xdrffloat_(ixdrf, p_ugamma(i+(il-1)*nfrag_back), iret)
+ call xdrffloat_(ixdrf, p_uscdiff(i+(il-1)*nfrag_back), iret)
+ enddo
+ prec=10000.0
+ do i=1,nres
+ do j=1,3
+ xcoord(j,i)=p_c(j,i+(il-1)*nres*2)
+ enddo
+ enddo
+ do i=nnt,nct
+ do j=1,3
+ xcoord(j,nres+i-nnt+1)=p_c(j,i+nres+(il-1)*nres*2)
+ enddo
+ enddo
+ itmp=nres+nct-nnt+1
+ call xdrf3dfcoord_(ixdrf, xcoord, itmp, prec, iret)
+ enddo
+#else
+ do il=1,nodes
+ call xdrffloat(ixdrf, real(t_restart1(1,il)), iret)
+ call xdrffloat(ixdrf, real(t_restart1(3,il)), iret)
+ call xdrffloat(ixdrf, real(t_restart1(5,il)), iret)
+ call xdrffloat(ixdrf, real(t_restart1(4,il)), iret)
+ call xdrfint(ixdrf, nss, iret)
+ do j=1,nss
+ call xdrfint(ixdrf, ihpb(j), iret)
+ call xdrfint(ixdrf, jhpb(j), iret)
+ enddo
+ call xdrfint(ixdrf, nfrag+npair+3*nfrag_back, iret)
+ call xdrfint(ixdrf, iset_restart1(il), iret)
+ do i=1,nfrag
+ call xdrffloat(ixdrf, p_qfrag(i+(il-1)*nfrag), iret)
+ enddo
+ do i=1,npair
+ call xdrffloat(ixdrf, p_qpair(i+(il-1)*npair), iret)
+ enddo
+ do i=1,nfrag_back
+ call xdrffloat(ixdrf, p_utheta(i+(il-1)*nfrag_back), iret)
+ call xdrffloat(ixdrf, p_ugamma(i+(il-1)*nfrag_back), iret)
+ call xdrffloat(ixdrf, p_uscdiff(i+(il-1)*nfrag_back), iret)
+ enddo
+ prec=10000.0
+ do i=1,nres
+ do j=1,3
+ xcoord(j,i)=p_c(j,i+(il-1)*nres*2)
+ enddo
+ enddo
+ do i=nnt,nct
+ do j=1,3
+ xcoord(j,nres+i-nnt+1)=p_c(j,i+nres+(il-1)*nres*2)
+ enddo
+ enddo
+ itmp=nres+nct-nnt+1
+ call xdrf3dfcoord(ixdrf, xcoord, itmp, prec, iret)
+ enddo
+#endif
+ endif
+ enddo
+#ifdef AIX
+ if(me.eq.king) call xdrfclose_(ixdrf, iret)
+#else
+ if(me.eq.king) call xdrfclose(ixdrf, iret)
+#endif
+ do i=1,ntwx_cache-ii_write
+
+ totT_cache(i)=totT_cache(ii_write+i)
+ EK_cache(i)=EK_cache(ii_write+i)
+ potE_cache(i)=potE_cache(ii_write+i)
+ t_bath_cache(i)=t_bath_cache(ii_write+i)
+ Uconst_cache(i)=Uconst_cache(ii_write+i)
+ iset_cache(i)=iset_cache(ii_write+i)
+
+ do ii=1,nfrag
+ qfrag_cache(ii,i)=qfrag_cache(ii,ii_write+i)
+ enddo
+ do ii=1,npair
+ qpair_cache(ii,i)=qpair_cache(ii,ii_write+i)
+ enddo
+ do ii=1,nfrag_back
+ utheta_cache(ii,i)=utheta_cache(ii,ii_write+i)
+ ugamma_cache(ii,i)=ugamma_cache(ii,ii_write+i)
+ uscdiff_cache(ii,i)=uscdiff_cache(ii,ii_write+i)
+ enddo
+
+ do ii=1,nres*2
+ do j=1,3
+ c_cache(j,ii,i)=c_cache(j,ii,ii_write+i)
+ enddo
+ enddo
+ enddo
+ ntwx_cache=ntwx_cache-ii_write
+ return
+ end
+
+
+ subroutine read1restart(i_index)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'mpif.h'
+ include 'COMMON.MD'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.REMD'
+ include 'COMMON.SETUP'
+ include 'COMMON.CHAIN'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.INTERACT'
+ real d_restart1(3,2*maxres*maxprocs),r_d(3,2*maxres),
+ & t5_restart1(5)
+ integer*2 i_index
+ & (maxprocs/4,maxprocs/20,maxprocs/200,maxprocs/200)
+ common /przechowalnia/ d_restart1
+ write (*,*) "Processor",me," called read1restart"
+
+ if(me.eq.king)then
+ open(irest2,file=mremd_rst_name,status='unknown')
+ read(irest2,*,err=334) i
+ write(iout,*) "Reading old rst in ASCI format"
+ close(irest2)
+ call read1restart_old
+ return
+ 334 continue
+#ifdef AIX
+ call xdrfopen_(ixdrf,mremd_rst_name, "r", iret)
+
+ do i=0,nodes-1
+ call xdrfint_(ixdrf, i2rep(i), iret)
+ enddo
+ do i=1,remd_m(1)
+ call xdrfint_(ixdrf, ifirst(i), iret)
+ enddo
+ do il=1,nodes
+ call xdrfint_(ixdrf, nupa(0,il), iret)
+ do i=1,nupa(0,il)
+ call xdrfint_(ixdrf, nupa(i,il), iret)
+ enddo
+
+ call xdrfint_(ixdrf, ndowna(0,il), iret)
+ do i=1,ndowna(0,il)
+ call xdrfint_(ixdrf, ndowna(i,il), iret)
+ enddo
+ enddo
+ do il=1,nodes
+ do j=1,4
+ call xdrffloat_(ixdrf, t_restart1(j,il), iret)
+ enddo
+ enddo
+#else
+ call xdrfopen(ixdrf,mremd_rst_name, "r", iret)
+
+ do i=0,nodes-1
+ call xdrfint(ixdrf, i2rep(i), iret)
+ enddo
+ do i=1,remd_m(1)
+ call xdrfint(ixdrf, ifirst(i), iret)
+ enddo
+ do il=1,nodes
+ call xdrfint(ixdrf, nupa(0,il), iret)
+ do i=1,nupa(0,il)
+ call xdrfint(ixdrf, nupa(i,il), iret)
+ enddo
+
+ call xdrfint(ixdrf, ndowna(0,il), iret)
+ do i=1,ndowna(0,il)
+ call xdrfint(ixdrf, ndowna(i,il), iret)
+ enddo
+ enddo
+ do il=1,nodes
+ do j=1,4
+ call xdrffloat(ixdrf, t_restart1(j,il), iret)
+ enddo
+ enddo
+#endif
+ endif
+ call mpi_scatter(t_restart1,5,mpi_real,
+ & t5_restart1,5,mpi_real,king,CG_COMM,ierr)
+ totT=t5_restart1(1)
+ EK=t5_restart1(2)
+ potE=t5_restart1(3)
+ t_bath=t5_restart1(4)
+
+ if(me.eq.king)then
+ do il=0,nodes-1
+ do i=1,2*nres
+c read(irest2,'(3e15.5)')
+c & (d_restart1(j,i+2*nres*il),j=1,3)
+ do j=1,3
+#ifdef AIX
+ call xdrffloat_(ixdrf, d_restart1(j,i+2*nres*il), iret)
+#else
+ call xdrffloat(ixdrf, d_restart1(j,i+2*nres*il), iret)
+#endif
+ enddo
+ enddo
+ enddo
+ endif
+ call mpi_scatter(d_restart1,3*2*nres,mpi_real,
+ & r_d,3*2*nres,mpi_real,king,CG_COMM,ierr)
+
+ do i=1,2*nres
+ do j=1,3
+ d_t(j,i)=r_d(j,i)
+ enddo
+ enddo
+ if(me.eq.king)then
+ do il=0,nodes-1
+ do i=1,2*nres
+c read(irest2,'(3e15.5)')
+c & (d_restart1(j,i+2*nres*il),j=1,3)
+ do j=1,3
+#ifdef AIX
+ call xdrffloat_(ixdrf, d_restart1(j,i+2*nres*il), iret)
+#else
+ call xdrffloat(ixdrf, d_restart1(j,i+2*nres*il), iret)
+#endif
+ enddo
+ enddo
+ enddo
+ endif
+ call mpi_scatter(d_restart1,3*2*nres,mpi_real,
+ & r_d,3*2*nres,mpi_real,king,CG_COMM,ierr)
+ do i=1,2*nres
+ do j=1,3
+ dc(j,i)=r_d(j,i)
+ enddo
+ enddo
+
+
+ if(usampl) then
+#ifdef AIX
+ if(me.eq.king)then
+ call xdrfint_(ixdrf, nset, iret)
+ do i=1,nset
+ call xdrfint_(ixdrf,mset(i), iret)
+ enddo
+ do i=0,nodes-1
+ call xdrfint_(ixdrf,i2set(i), iret)
+ enddo
+ do il=1,nset
+ do il1=1,mset(il)
+ do i=1,nrep
+ do j=1,remd_m(i)
+ call xdrfint_(ixdrf,itmp, iret)
+ i_index(i,j,il,il1)=itmp
+ enddo
+ enddo
+ enddo
+ enddo
+ endif
+#else
+ if(me.eq.king)then
+ call xdrfint(ixdrf, nset, iret)
+ do i=1,nset
+ call xdrfint(ixdrf,mset(i), iret)
+ enddo
+ do i=0,nodes-1
+ call xdrfint(ixdrf,i2set(i), iret)
+ enddo
+ do il=1,nset
+ do il1=1,mset(il)
+ do i=1,nrep
+ do j=1,remd_m(i)
+ call xdrfint(ixdrf,itmp, iret)
+ i_index(i,j,il,il1)=itmp
+ enddo
+ enddo
+ enddo
+ enddo
+ endif
+#endif
+ call mpi_scatter(i2set,1,mpi_integer,
+ & iset,1,mpi_integer,king,
+ & CG_COMM,ierr)
+
+ endif
+
+
+ if(me.eq.king) close(irest2)
+ return
+ end
+
+ subroutine read1restart_old
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'mpif.h'
+ include 'COMMON.MD'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.REMD'
+ include 'COMMON.SETUP'
+ include 'COMMON.CHAIN'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.INTERACT'
+ real d_restart1(3,2*maxres*maxprocs),r_d(3,2*maxres),
+ & t5_restart1(5)
+ common /przechowalnia/ d_restart1
+ if(me.eq.king)then
+ open(irest2,file=mremd_rst_name,status='unknown')
+ read (irest2,*) (i2rep(i),i=0,nodes-1)
+ read (irest2,*) (ifirst(i),i=1,remd_m(1))
+ do il=1,nodes
+ read (irest2,*) nupa(0,il),(nupa(i,il),i=1,nupa(0,il))
+ read (irest2,*) ndowna(0,il),
+ & (ndowna(i,il),i=1,ndowna(0,il))
+ enddo
+ do il=1,nodes
+ read(irest2,*) (t_restart1(j,il),j=1,4)
+ enddo
+ endif
+ call mpi_scatter(t_restart1,5,mpi_real,
+ & t5_restart1,5,mpi_real,king,CG_COMM,ierr)
+ totT=t5_restart1(1)
+ EK=t5_restart1(2)
+ potE=t5_restart1(3)
+ t_bath=t5_restart1(4)
+
+ if(me.eq.king)then
+ do il=0,nodes-1
+ do i=1,2*nres
+ read(irest2,'(3e15.5)')
+ & (d_restart1(j,i+2*nres*il),j=1,3)
+ enddo
+ enddo
+ endif
+ call mpi_scatter(d_restart1,3*2*nres,mpi_real,
+ & r_d,3*2*nres,mpi_real,king,CG_COMM,ierr)
+
+ do i=1,2*nres
+ do j=1,3
+ d_t(j,i)=r_d(j,i)
+ enddo
+ enddo
+ if(me.eq.king)then
+ do il=0,nodes-1
+ do i=1,2*nres
+ read(irest2,'(3e15.5)')
+ & (d_restart1(j,i+2*nres*il),j=1,3)
+ enddo
+ enddo
+ endif
+ call mpi_scatter(d_restart1,3*2*nres,mpi_real,
+ & r_d,3*2*nres,mpi_real,king,CG_COMM,ierr)
+ do i=1,2*nres
+ do j=1,3
+ dc(j,i)=r_d(j,i)
+ enddo
+ enddo
+ if(me.eq.king) close(irest2)
+ return
+ end
+c-------------------------------------------------------------------
+ subroutine set_hweights(iiset)
+ implicit real*8 (a-h,o-z)
+ integer i
+ include 'DIMENSIONS'
+ include 'COMMON.FFIELD'
+ include 'COMMON.REMD'
+
+ do i=1,n_ene
+ weights(i)=hweights(iiset,i)
+ enddo
+
+ wsc =weights(1)
+ wscp =weights(2)
+ welec =weights(3)
+ wcorr =weights(4)
+ wcorr5 =weights(5)
+ wcorr6 =weights(6)
+ wel_loc=weights(7)
+ wturn3 =weights(8)
+ wturn4 =weights(9)
+ wturn6 =weights(10)
+ wang =weights(11)
+ wscloc =weights(12)
+ wtor =weights(13)
+ wtor_d =weights(14)
+ wstrain=weights(15)
+ wvdwpp =weights(16)
+ wbond =weights(17)
+ scal14 =weights(18)
+ wsccor =weights(21)
+
+ return
+ end
+#endif
--- /dev/null
+#
+FC1=/bgsys/drivers/ppcfloor/comm/bin/mpixlf77
+FC=tau_f90.sh
+OPT = -O3 -qarch=450 -qtune=450 -qfixed
+#OPT = -O3 -qarch=450 -qtune=450 -qdebug=function_trace -qfixed
+#OPT = -O -qarch=450 -qtune=450 -qfixed
+#-Minline=name:scalar2,scalar,transpose2,matvec2,prodmat3 \
+#-Mprefetch=distance:8,nta
+
+#OPT = -O0 -C -g -qarch=450 -qtune=450 -qfixed
+OPT1 = -O0 -g -qarch=450 -qtune=450 -qfixed
+OPT2 = -O2 -qarch=450 -qtune=450 -qfixed
+#OPT2 = -O2 -qarch=450 -qtune=450 -qdebug=function_trace -qfixed
+#OPT2 = ${OPT}
+OPTE = -O4 -qarch=450 -qtune=450 -qfixed
+#OPTE = -O4 -qarch=450 -qtune=450 -qdebug=function_trace -qfixed
+#OPTE=${OPT}
+
+FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include
+FFLAGS1 = -c ${OPT1} -I$(INSTALL_DIR)/include
+FFLAGS2 = -c ${OPT2} -I$(INSTALL_DIR)/include
+FFLAGSE = -c ${OPTE} -I$(INSTALL_DIR)/include
+
+BIN = ../bin/unres_MD_Tc_procor-newparm-gnivpar-O4-test.exe
+#LIBS = xdrf/libxdrf.a /home/liwo/UNRES/LIB/libmemmon.a
+LIBS = xdrf/libxdrf.a
+
+CPPFLAGS = -WF,-DAIX -WF,-DISNAN -WF,-DUNRES -WF,-DMP -WF,-DMPI -WF,-DPGI \
+ -WF,-DSPLITELE -WF,-DPROCOR -WF,-DAMD64 -WF,-DLANG0
+
+ARCH = LINUX
+PP = /lib/cpp -P
+
+
+all: unres
+
+.SUFFIXES: .F
+.F.o:
+ ${FC} ${FFLAGS} ${CPPFLAGS} $*.F
+
+
+object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \
+ matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \
+ pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \
+ cartder.o checkder_p.o econstr_local.o energy_p_new.o \
+ energy_p_new-sep.o gradient_p.o minimize_p.o sumsld.o \
+ cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \
+ mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \
+ eigen.o blas.o add.o entmcm.o minim_mcmf.o \
+ together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \
+ indexx.o MP.o compare_s1.o prng.o \
+ test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \
+ sc_move.o local_move.o \
+ intcartderiv.o lagrangian_lesyng.o\
+ stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \
+ surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \
+ q_measure.o gnmr1.o
+
+unres: ${object}
+ ${CC} -o compinfo compinfo.c
+ ./compinfo | true
+ ${FC} ${FFLAGS} cinfo.f
+ ${FC} ${OPT} --print-map ${object} cinfo.o ${LIBS} -o ${BIN}
+
+
+clean:
+ /bin/rm *.o; /bin/rm *.pp.*
+
+newconf.o: newconf.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f
+
+bank.o: bank.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} bank.F
+
+diff12.o: diff12.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f
+
+csa.o: csa.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} csa.f
+
+shift.o: shift.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} shift.F
+
+ran.o: ran.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} ran.f
+
+together.o: together.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} together.F
+
+test.o: test.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} test.F
+
+chainbuild.o: chainbuild.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F
+
+matmult.o: matmult.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f
+
+parmread.o : parmread.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F
+
+intcor.o : intcor.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f
+
+cartder.o : cartder.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F
+
+readpdb.o : readpdb.f
+ ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.f
+
+sumsld.o : sumsld.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f
+
+cored.o : cored.f
+ ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f
+
+rmdd.o : rmdd.f
+ ${FC} ${FFLAGS1} ${CPPFLAGS} rmdd.f
+
+eigen.o : eigen.f
+ ${FC} ${FFLAGS1} ${CPPFLAGS} eigen.f
+
+blas.o : blas.f
+ ${FC} ${FFLAGS1} ${CPPFLAGS} blas.f
+
+add.o : add.f
+ ${FC} ${FFLAGS1} ${CPPFLAGS} add.f
+
+energy_p_new.o : energy_p_new.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F
+
+energy_p_new-sep.o : energy_p_new-sep.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep.F
+
+lagrangian_lesyng.o : lagrangian_lesyng.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F
+
+compinfo: compinfo.o
+ ${CC} ${CFLAGS} compfinfo.c
+
+proc_proc.o: proc_proc.c
+ ${CC} ${CFLAGS} proc_proc.c
+
+prng_32.o: prng_32.F
+ ${FC} -qfixed -O0 prng_32.F
+
+prng.o: prng.f
+ ${FC1} ${FFLAGS} prng.f
+
+readrtns_CSA.o: readrtns_CSA.F
+ ${FC1} ${FFLAGS} ${CPPFLAGS} readrtns_CSA.F
+
+gen_rand_conf.o: gen_rand_conf.F
+ ${FC1} ${FFLAGS} ${CPPFLAGS} gen_rand_conf.F
--- /dev/null
+#****************************************************************************
+#* TAU Portable Profiling Package **
+#* http://www.cs.uoregon.edu/research/tau **
+#****************************************************************************
+#* Copyright 1997-2002 **
+#* Department of Computer and Information Science, University of Oregon **
+#* Advanced Computing Laboratory, Los Alamos National Laboratory **
+#****************************************************************************
+#######################################################################
+## pC++/Sage++ Copyright (C) 1993,1995 ##
+## Indiana University University of Oregon University of Rennes ##
+#######################################################################
+
+#######################################################################
+# This is a sample Makefile that contains the Profiling and Tracing
+# options. Makefiles of other applications and libraries (not included
+# in this distribution) should include this Makefile.
+# It defines the following variables that should be added to CFLAGS
+# TAU_INCLUDE - Include path for tau headers
+# TAU_DEFS - Defines that are needed for tracing and profiling only.
+# And for linking add to LIBS
+# TAU_LIBS - TAU Tracing and Profiling library libprof.a
+#
+# When the user needs to turn off tracing and profiling and run the
+# application without any runtime overhead of instrumentation, simply
+# remove TAUDEFS and TAULIBS from CFLAGS and LIBS respectively but keep
+# TAUINC.
+#######################################################################
+
+########### Automatically modified by the configure script ############
+CONFIG_ARCH=bgp
+TAU_ARCH=bgp
+CONFIG_CC=bgxlc_r
+CONFIG_CXX=bgxlC_r
+TAU_CC_FE=$(CONFIG_CC)
+TAU_CXX_FE=$(CONFIG_CXX)
+
+# Front end C/C++ Compilers
+#BGL#TAU_CC_FE=xlc #ENDIF#
+#BGL#TAU_CXX_FE=xlC #ENDIF#
+TAU_CC_FE=xlc #ENDIF##BGP#
+TAU_CXX_FE=xlC #ENDIF##BGP#
+#CATAMOUNT#TAU_CC_FE=gcc #ENDIF#
+#CATAMOUNT#TAU_CXX_FE=g++ #ENDIF#
+#SC_GFORTRAN#TAU_CC_FE=gcc #ENDIF#
+#SC_GFORTRAN#TAU_CXX_FE=g++ #ENDIF#
+#SC_PATHSCALE#TAU_CC_FE=gcc #ENDIF#
+#SC_PATHSCALE#TAU_CXX_FE=g++ #ENDIF#
+
+PCXX_OPT=-g
+USER_OPT=
+EXTRADIR=/opt/ibmcmp/xlf/bg/11.1/bin/..
+EXTRADIRCXX=/opt/ibmcmp/vacpp/bg/9.0/bin/..
+TAUROOT=/soft/apps/tau/tau_latest
+TULIPDIR=
+TAUEXTRASHLIBOPTS=
+TAUGCCLIBOPTS=
+TAUGCCLIBDIR=
+TAUGFORTRANLIBDIR=
+PCLDIR=
+PAPIDIR=
+PAPISUBDIR=
+CHARMDIR=
+PDTDIR=/soft/apps/tau/pdtoolkit-3.12
+PDTCOMPDIR=
+DYNINSTDIR=
+JDKDIR=
+SLOG2DIR=
+OPARIDIR=
+TAU_OPARI_TOOL=
+EPILOGDIR=
+EPILOGBINDIR=
+EPILOGINCDIR=
+EPILOGLIBDIR=
+EPILOGEXTRALINKCMD=
+VAMPIRTRACEDIR=
+KTAU_INCDIR=
+KTAU_INCUSERDIR=
+KTAU_LIB=
+KTAU_KALLSYMS_PATH=
+PYTHON_INCDIR=
+PYTHON_LIBDIR=
+PERFINCDIR=
+PERFLIBDIR=
+PERFLIBRARY=
+TAU_SHMEM_INC=
+TAU_SHMEM_LIB=
+TAU_CONFIG=-mpi-pdt
+TAU_MPI_INC=-I/bgsys/drivers/ppcfloor/comm/include
+TAU_MPI_LIB=-L/soft/apps/tau/tau_latest/bgp/lib -lTauMpi$(TAU_CONFIG) -L/bgsys/drivers/ppcfloor/comm/lib
+TAU_MPI_FLIB=-lfmpich.cnk -L/soft/apps/tau/tau_latest/bgp/lib -lTauMpi$(TAU_CONFIG) -L/bgsys/drivers/ppcfloor/comm/lib
+TAU_MPILIB_DIR=/bgsys/drivers/ppcfloor/comm/lib
+TAU_MPI_NOWRAP_LIB= -L/bgsys/drivers/ppcfloor/comm/lib
+TAU_MPI_NOWRAP_FLIB=-lfmpich.cnk -L/bgsys/drivers/ppcfloor/comm/lib
+FULL_CXX=mpixlcxx_r
+FULL_CC=mpixlc_r
+TAU_PREFIX_INSTALL_DIR=/soft/apps/tau/tau_latest
+
+TAU_BIN_DIR=$(TAU_PREFIX_INSTALL_DIR)/$(CONFIG_ARCH)/bin
+TAU_INC_DIR=$(TAU_PREFIX_INSTALL_DIR)/include
+TAU_LIB_DIR=$(TAU_PREFIX_INSTALL_DIR)/$(CONFIG_ARCH)/lib
+
+#######################################################################
+
+#OPARI#TAU_OPARI_TOOL=$(TAU_BIN_DIR)/opari #ENDIF#
+#ENABLE64BIT#ABI = -64 #ENDIF#
+#ENABLEN32BIT#ABI = -n32 #ENDIF#
+#ENABLE32BIT#ABI = -32 #ENDIF#
+
+#######################################################################
+#SP1#IBM_XLC_ABI = -q32 #ENDIF#
+#SP1#IBM_GNU_ABI = -maix32 #ENDIF#
+#IBM64#IBM_XLC_ABI = -q64 #ENDIF#
+#IBM64#IBM_GNU_ABI = -maix64 #ENDIF#
+#IBM64LINUX#IBM_XLC_ABI = -q64 #ENDIF#
+#IBM64LINUX#IBM_GNU_ABI = -m64 #ENDIF#
+#SUNX86_64#SUN_GNU_ABI = -m64 #ENDIF#
+#SUNX86_64#SUN_CC_ABI = -xarch=amd64 #ENDIF#
+#MIPS32LINUX#SC_GNU_ABI = -mabi=n32 #ENDIF#
+#MIPS32LINUX#SC_PATH_ABI = -n32 #ENDIF#
+#MIPS64LINUX#SC_GNU_ABI = -mabi=64 #ENDIF#
+#MIPS64LINUX#SC_PATH_ABI = -64 #ENDIF#
+#GNU#SC_ABI = $(SC_GNU_ABI) #ENDIF#
+#USE_PATHCC#SC_ABI = $(SC_PATH_ABI) #ENDIF#
+#MIPS32#ABI = $(SC_ABI) #ENDIF#
+#MIPS64#ABI = $(SC_ABI) #ENDIF#
+
+IBM_ABI = $(IBM_XLC_ABI) #ENDIF##USE_IBMXLC#
+#GNU#IBM_ABI = $(IBM_GNU_ABI) #ENDIF#
+#SP1# ABI = $(IBM_ABI) #ENDIF#
+#PPC64# ABI = $(IBM_ABI) #ENDIF#
+#SOLARIS64#SUN_GNU_ABI = -mcpu=v9 -m64 #ENDIF#
+#SOLARIS64#SUN_CC_ABI = -xarch=v9 -xcode=pic32 #ENDIF#
+#SOL2CC#SUN_ABI = $(SUN_CC_ABI) #ENDIF#
+#GNU#SUN_ABI = $(SUN_GNU_ABI) #ENDIF#
+#SOL2#ABI = $(SUN_ABI) #ENDIF#
+#SUNX86_64#ABI = $(SUN_ABI) #ENDIF#
+#FORCEIA32#ABI = -m32#ENDIF#
+#######################################################################
+F90_ABI = $(ABI)
+#IBM64_FORTRAN#F90_ABI = -q64 #ENDIF#
+#######################################################################
+
+############# Standard Defines ##############
+TAU_CC = $(CONFIG_CC) $(ABI) $(ISA)
+TAU_CXX = $(CONFIG_CXX) $(ABI) $(ISA) $(USER_OPT)
+TAU_RUN_CC = $(FULL_CC) $(ABI) $(ISA)
+TAU_RUN_CXX = $(FULL_CXX) $(ABI) $(ISA)
+TAU_INSTALL = /bin/cp
+TAU_SHELL = /bin/sh
+LSX = .a
+#############################################
+# JAVA DEFAULT ARCH
+#############################################
+JDKARCH = linux
+#COMPAQ_ALPHA#JDKARCH = alpha #ENDIF#
+#SOL2#JDKARCH = solaris #ENDIF#
+#SGIMP#JDKARCH = irix #ENDIF#
+#SP1#JDKARCH = aix #ENDIF#
+#T3E#JDKARCH = cray #ENDIF#
+#############################################
+# JAVA OBJECTS
+#############################################
+#JAVA#TAU_JAVA_O = TauJava.o TauJAPI.o #ENDIF#
+#JAVA#TAUJAPI = Profile.class #ENDIF#
+
+
+#############################################
+# OpenMP OBJECTS
+#############################################
+#OPENMP#OPENMP_O = OpenMPLayer.o #ENDIF#
+
+#############################################
+# Opari OBJECTS
+#############################################
+#OPARI#OPARI_O = TauOpari.o #ENDIF#
+#KOJAKOPARI#OPARI_O = TauKojakOpari.o #ENDIF#
+#EPILOG#OPARI_O = #ENDIF#
+#VAMPIRTRACE#OPARI_O = #ENDIF#
+#GNU#OPARI_O = #ENDIF#
+
+#############################################
+# CallPath OBJECTS
+#############################################
+#PROFILECALLPATH#CALLPATH_O = TauCallPath.o #ENDIF#
+#PROFILEPARAM#PARAM_O = ProfileParam.o #ENDIF#
+
+#############################################
+# Python Binding OBJECTS
+#############################################
+#PYTHON#PYTHON_O = PyGroups.o PyExceptions.o PyDatabase.o PyBindings.o PyTimer.o PyTau.o #ENDIF#
+
+#############################################
+# DYNINST DEFAULT ARCH
+#############################################
+DYNINST_PLATFORM = $(PLATFORM)
+
+
+#PCL##include $(TAU_INC_DIR)/makefiles/PCLMakefile.stub #ENDIF#
+
+############# OpenMP Fortran Option ########
+#OPENMP#TAU_F90_OPT = -mp #ENDIF#
+#SOL2CC_OPENMP#TAU_F90_OPT = -xopenmp #ENDIF#
+#SUNCC_OPENMP#TAU_F90_OPT = -xopenmp=parallel #ENDIF#
+#COMPAQCXX_OPENMP#TAU_F90_OPT = -omp #ENDIF#
+#IBMXLC_OPENMP#TAU_F90_OPT = -qsmp=omp #ENDIF#
+#GUIDE#TAU_F90_OPT = #ENDIF#
+#PGIOPENMP#TAU_F90_OPT = -mp #ENDIF#
+#INTELOPENMP#TAU_F90_OPT = -openmp #ENDIF#
+#HITACHI_OPENMP#TAU_F90_OPT = #ENDIF#
+
+TAU_R =_r #ENDIF##THREADSAFE_COMPILERS#
+
+############# Fortran Compiler #############
+#GNU_FORTRAN#TAU_F90 = g77 $(F90_ABI) $(TAU_F90_OPT) #ENDIF#
+#GNU_GFORTRAN#TAU_F90 = gfortran $(F90_ABI) $(TAU_F90_OPT) #ENDIF#
+#G95_FORTRAN#TAU_F90 = g95 $(F90_ABI) $(TAU_F90_OPT) #ENDIF#
+#SC_GFORTRAN#TAU_F90 = scgfortran $(F90_ABI) $(TAU_F90_OPT) #ENDIF#
+#SGI_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF#
+TAU_F90 = xlf77$(TAU_R) $(F90_ABI) $(TAU_F90_OPT) #ENDIF##IBM_FORTRAN#
+TAU_F90 = mpixlf77$(TAU_R) $(F90_ABI) $(TAU_F90_OPT) #ENDIF##BGP#
+#BGL#TAU_F90 = blrts_xlf90$(TAU_R) $(F90_ABI) $(TAU_F90_OPT) #ENDIF#
+#IBM64_FORTRAN#TAU_F90 = xlf90$(TAU_R) $(F90_ABI) $(TAU_F90_OPT) #ENDIF#
+#IBMXLFAPPLE#TAU_F90 = xlf90$(TAU_R) $(F90_ABI) $(TAU_F90_OPT) #ENDIF#
+#CRAY_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF#
+#CRAY_X1_FORTRAN#TAU_F90 = ftn $(F90_ABI) $(TAU_F90_OPT) #ENDIF#
+#PGI_FORTRAN#TAU_F90 = pgf90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF#
+#CRAYCNL#TAU_F90 = ftn $(F90_ABI) $(TAU_F90_OPT) #ENDIF#
+#PGI_CATAMOUNT#TAU_F90 = qk-pgf90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF#
+#ABSOFT_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF#
+#LAHEY_FORTRAN#TAU_F90 = lf95 $(F90_ABI) $(TAU_F90_OPT) #ENDIF#
+#LAHEY64_FORTRAN#TAU_F90 = lf95 $(F90_ABI) $(TAU_F90_OPT) #ENDIF#
+#NAGWARE_FORTRAN#TAU_F90 = f95 $(F90_ABI) $(TAU_F90_OPT) #ENDIF#
+#FUJITSU_FORTRAN#TAU_F90 = F90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF#
+#FUJITSU_SOLARIS#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF#
+#SUN_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF#
+#COMPAQ_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF#
+#KAI_FORTRAN#TAU_F90 = guidef90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF#
+#HP_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF#
+#HITACHI_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF#
+#INTEL_FORTRAN#TAU_F90 = efc $(F90_ABI) $(TAU_F90_OPT) #ENDIF#
+#INTEL32_FORTRAN#TAU_F90 = ifc $(F90_ABI) $(TAU_F90_OPT) #ENDIF#
+#INTELIFORT#TAU_F90 = ifort $(F90_ABI) $(TAU_F90_OPT) #ENDIF#
+#PATHSCALE_FORTRAN#TAU_F90 = pathf90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF#
+#SC_PATHSCALE#TAU_F90 = scpathf95 $(F90_ABI) $(TAU_F90_OPT) #ENDIF#
+#OPEN64ORC_FORTRAN#TAU_F90 = orf90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF#
+#NEC_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF#
+
+
+############# Portable F90 Options #############
+#IBM64_FORTRAN#TAU_F90_FIXED = -qfixed #ENDIF#
+TAU_F90_FIXED = -qfixed #ENDIF##IBM_FORTRAN#
+TAU_F90_SUFFIX = -qsuffix=f=f90 #ENDIF##IBM_FORTRAN#
+#IBMXLFAPPLE#TAU_F90_FIXED = -qfixed #ENDIF#
+#IBMXLFAPPLE#TAU_F90_SUFFIX = -qsuffix=f=f90 #ENDIF#
+#IBM64_FORTRAN#TAU_F90_SUFFIX = -qsuffix=f=f90 #ENDIF#
+
+############# Profiling Options #############
+PROFILEOPT1 = -DPROFILING_ON #ENDIF##PROFILE#
+#PCL#PROFILEOPT3 = -DTAU_PCL -I$(PCLDIR)/include #ENDIF#
+#PAPI#PROFILEOPT3 = -DTAU_PAPI -I$(PAPIDIR)/src -I$(PAPIDIR)/include #ENDIF#
+#PCL#PCL_O = PclLayer.o #ENDIF#
+#PAPI#PAPI_O = PapiLayer.o #ENDIF#
+#MULTIPLECOUNTERS#MULT_O = MultipleCounters.o #ENDIF#
+#PROFILECALLS#PROFILEOPT4 = -DPROFILE_CALLS #ENDIF#
+#PROFILESTATS#PROFILEOPT5 = -DPROFILE_STATS #ENDIF#
+#DEBUGPROF#PROFILEOPT6 = -DDEBUG_PROF #ENDIF#
+PROFILEOPT7 = -DTAU_STDCXXLIB #ENDIF##STDCXXLIB#
+#CRAYX1CC#PROFILEOPT7 = #ENDIF#
+#CRAYCC#PROFILEOPT7 = #ENDIF#
+#INTELTFLOP#PROFILEOPT8 = -DPOOMA_TFLOP #ENDIF#
+#NORTTI#PROFILEOPT9 = -DNO_RTTI #ENDIF#
+#RTTI#PROFILEOPT9 = -DRTTI #ENDIF#
+#GNU#PROFILEOPT10 = -DTAU_GNU -DTAU_DOT_H_LESS_HEADERS -fPIC #ENDIF#
+#APPLECXX#PROFILEOPT10 = -DTAU_GNU -DTAU_DOT_H_LESS_HEADERS -fPIC #ENDIF#
+#SOL2CC#PROFILEOPT10 = -DTAU_SOL2CC -DTAU_DOT_H_LESS_HEADERS #ENDIF#
+#SUNCC#PROFILEOPT10 = -DTAU_SOL2CC -DTAU_DOT_H_LESS_HEADERS #ENDIF#
+#USE_PATHCC#PROFILEOPT10 = -DTAU_DOT_H_LESS_HEADERS -fPIC -DTAU_PATHSCALE #ENDIF#
+#OPEN64ORC#PROFILEOPT10 = -DTAU_DOT_H_LESS_HEADERS -DTAU_OPEN64ORC -fpic #ENDIF#
+#CALLSTACK#PROFILEOPT11 = -DPROFILE_CALLSTACK #ENDIF#
+#PGI1.7#PROFILEOPT12 = -DPGI #ENDIF#
+#CRAYKAI#PROFILEOPT12 = -DCRAYKAI #ENDIF#
+#HP_FORTRAN#PROFILEOPT12 = -DHP_FORTRAN #ENDIF#
+#CRAYCC#PROFILEOPT13 = -h instantiate=used -DCRAYCC -DTAU_DOT_H_LESS_HEADERS #ENDIF#
+#CRAYX1CC#PROFILEOPT13 = -DTAU_DOT_H_LESS_HEADERS #ENDIF#
+#SGICC#TAU_CXX = $(CONFIG_CXX) $(ABI) $(ISA) $(USER_OPT) -LANG:std #ENDIF#
+#INTELCXXLIBICC#TAU_CXX = $(CONFIG_CXX) $(ABI) $(ISA) $(USER_OPT) -cxxlib-icc #ENDIF#
+#PTHREAD_AVAILABLE#PROFILEOPT15 = -DPTHREADS #ENDIF#
+#COMPAQCXX_PTHREAD#PROFILEOPT15 = -DPTHREADS -pthread #ENDIF#
+#TAU_SPROC#PROFILEOPT15 = -DTAU_SPROC #ENDIF#
+#TAU_PAPI_THREADS#PROFILEOPT15 = -DTAU_PAPI_THREADS #ENDIF#
+#TULIPTHREADS#PROFILEOPT16 = -DTULIPTHREADS #ENDIF#
+#TRACE#TRACEOPT = -DTRACING_ON #ENDIF#
+#TRACE#EVENTS_O = Tracer.o #ENDIF#
+#KTAU#KTAU_O = TauKtau.o KtauProfiler.o KtauSymbols.o #ENDIF#
+#KTAU_MERGE#KTAU_MERGE_O = KtauFuncInfo.o KtauMergeInfo.o ktau_syscall.o #ENDIF#
+#KTAU_SHCTR#KTAU_SHCTR_O = KtauCounters.o #ENDIF#
+#MPITRACE#TRACEOPT = -DTAU_MPITRACE -DTRACING_ON #ENDIF#
+#MPITRACE#EVENTS_O = Tracer.o #ENDIF#
+#MUSE#MUSE_O = TauMuse.o TauMuseFilters.o TauMuseHandlers.o TauMusePackages.o #ENDIF#
+#MUSE_EVENT#MUSE_O = TauMuse.o TauMuseFilters.o TauMuseHandlers.o TauMusePackages.o #ENDIF#
+#MUSE_MULTIPLE#MUSE_O = TauMuse.o TauMuseFilters.o TauMuseHandlers.o TauMusePackages.o #ENDIF#
+#COMPENSATE#COMPENSATE_O = TauCompensate.o #ENDIF#
+#PTHREAD_AVAILABLE#THR_O = PthreadLayer.o #ENDIF#
+#TAU_PAPI_THREADS#THR_O = PapiThreadLayer.o #ENDIF#
+#TAU_SPROC#THR_O = SprocLayer.o #ENDIF#
+#JAVA#THR_O = JavaThreadLayer.o #ENDIF#
+#TULIPTHREADS#THR_O = TulipThreadLayer.o #ENDIF#
+#LINUXTIMERS#PLATFORM_O = TauLinuxTimers.o #ENDIF#
+#TULIPTHREADS#PROFILEOPT17 = -I$(TULIPDIR)/include -I$(TULIPDIR)/Tuliplib #ENDIF#
+#SMARTS#PROFILEOPT17 = -I$(TULIPDIR)/include -I$(TULIPDIR)/lib -I$(TULIPDIR)/machine-specific/$(HOSTTYPE) #ENDIF#
+#SMARTS#PROFILEOPT18 = -DSMARTS #ENDIF#
+#KAI#PROFILEOPT19 = -DKAI -DTAU_DOT_H_LESS_HEADERS #ENDIF#
+#USE_DECCXX#PROFILEOPT19 = -DTAU_DOT_H_LESS_HEADERS #ENDIF#
+#SGICC#PROFILEOPT19 = -DTAU_DOT_H_LESS_HEADERS #ENDIF#
+#USE_INTELCXX#PROFILEOPT19 = -DTAU_DOT_H_LESS_HEADERS -fPIC #ENDIF#
+#USE_NECCXX#PROFILEOPT19 = -DTAU_DOT_H_LESS_HEADERS #ENDIF#
+#PGI#PROFILEOPT19 = -DTAU_DOT_H_LESS_HEADERS -fPIC #ENDIF#
+#ACC#PROFILEOPT19 = -AA +z -DTAU_DOT_H_LESS_HEADERS -DTAU_HPUX #ENDIF#
+#FUJITSU#PROFILEOPT19 = -DFUJITSU -DTAU_DOT_H_LESS_HEADERS #ENDIF#
+#KAINOEX#PROFILEOPT20 = --no_exceptions #ENDIF#
+#SGICCNOEX#PROFILEOPT20 = -LANG:exceptions=off #ENDIF#
+#HPGNU#PROFILEOPT21 = -fPIC #ENDIF#
+#HITACHI#PROFILEOPT21 = -DTAU_HITACHI #ENDIF#
+#SP1#PROFILEOPT21 = -D_POSIX_SOURCE -DTAU_AIX #ENDIF#
+#PPC64#TAU_PIC_PROFILEOPT21 = -qpic=large #ENDIF#
+#BGL#TAU_PIC_PROFILEOPT21 = #ENDIF#
+PROFILEOPT21 = -DTAU_DOT_H_LESS_HEADERS -DTAU_XLC $(TAU_PIC_PROFILEOPT21) #ENDIF##USE_IBMXLC#
+#IBMXLCAPPLE#PROFILEOPT21 = -DTAU_DOT_H_LESS_HEADERS -DTAU_XLC -DTAU_APPLE_XLC #ENDIF#
+#PCLPTHREAD#PROFILEOPT22 = -DPCL_MUTEX_LOCK #ENDIF#
+#JAVA#PROFILEOPT23 = -DJAVA #ENDIF#
+#MONITOR#PROFILEOPT24 = -DMONITORING_ON #ENDIF#
+#JAVA#PROFILEOPT25 = -I$(JDKDIR)/include -I$(JDKDIR)/include/$(JDKARCH) #ENDIF#
+PROFILEOPT26 = -DTAU_MPI #ENDIF##MPI#
+PROFILEOPT26 = -DTAU_MPI -DTAU_MPI_THREADED #ENDIF##MPI_THREADED#
+#OPENMP#PROFILEOPT27 = -mp -DTAU_OPENMP#ENDIF#
+#GNU#PROFILEOPT27 = #ENDIF#
+#SOL2CC_OPENMP#PROFILEOPT27 = -xopenmp -DTAU_OPENMP#ENDIF#
+#SUNCC_OPENMP#PROFILEOPT27 = -xopenmp=parallel -DTAU_OPENMP#ENDIF#
+#SUNCC_OPENMP#PROFILEOPT27 = -xopenmp=parallel -DTAU_OPENMP#ENDIF#
+#HITACHI_OPENMP#PROFILEOPT27 = -DTAU_OPENMP#ENDIF#
+#COMPAQCXX_OPENMP#PROFILEOPT27 = -omp -DTAU_OPENMP#ENDIF#
+#IBMXLC_OPENMP#PROFILEOPT27 = -qsmp=omp -DTAU_OPENMP #ENDIF#
+#OPEN64_OPENMP#PROFILEOPT27 = -mp -DTAU_OPENMP #ENDIF#
+#GUIDE#PROFILEOPT27 = -DTAU_OPENMP #ENDIF#
+#PGIOPENMP#PROFILEOPT27 = -mp -D_OPENMP -DTAU_OPENMP -U_RWSTD_MULTI_THREAD -U_REENTRANT #ENDIF#
+#INTELOPENMP#PROFILEOPT27 = -openmp -DTAU_OPENMP #ENDIF#
+#GNUOPENMP#PROFILEOPT27 = -fopenmp -DTAU_OPENMP #ENDIF#
+#OPARI#PROFILEOPT28 = -I$(OPARIDIR)/lib -I$(OPARIDIR)/include #ENDIF#
+#OPARI_REGION#PROFILEOPT28 = -DTAU_OPARI_REGION -I$(OPARIDIR)/lib -I$(OPARIDIR)/include #ENDIF#
+#OPARI_CONSTRUCT#PROFILEOPT28 = -DTAU_OPARI_CONSTRUCT -I$(OPARIDIR)/lib -I$(OPARIDIR)/include #ENDIF#
+#MULTIPLECOUNTERS#PROFILEOPT29 = -DTAU_MULTIPLE_COUNTERS #ENDIF#
+#SGITIMERS#PROFILEOPT30 = -DSGI_TIMERS #ENDIF#
+#BGLTIMERS#PROFILEOPT30 = -DBGL_TIMERS -I/bgl/BlueLight/ppcfloor/bglsys/include #ENDIF#
+#BGPTIMERS#PROFILEOPT30 = -DBGP_TIMERS -I/bgsys/drivers/ppcfloor/arch/include/common -I/bgsys/drivers/ppcfloor/arch/include -I/bgsys/drivers/ppcfloor/arch/include/spi #ENDIF#
+#CRAYTIMERS#PROFILEOPT30 = -DCRAY_TIMERS #ENDIF#
+#LINUXTIMERS#PROFILEOPT31 = -DTAU_LINUX_TIMERS #ENDIF#
+#ALPHATIMERS#PROFILEOPT31 = -DTAU_ALPHA_TIMERS #ENDIF#
+#CPUTIME#PROFILEOPT32 = -DCPU_TIME #ENDIF#
+#PAPIWALLCLOCK#PROFILEOPT33 = -DTAU_PAPI_WALLCLOCKTIME #ENDIF#
+#PAPIVIRTUAL#PROFILEOPT34 = -DTAU_PAPI_VIRTUAL #ENDIF#
+#SGICOUNTERS#PROFILEOPT35 = -DSGI_HW_COUNTERS #ENDIF#
+#EPILOG#PROFILEOPT36 = -DTAU_EPILOG -I$(EPILOGINCDIR) #ENDIF#
+#SCALASCA#PROFILEOPT36 = -DTAU_SCALASCA -DTAU_EPILOG -I$(EPILOGINCDIR) #ENDIF#
+#VAMPIRTRACEINTS#TAU_VAMPIRTRACEOPTS = -DTAU_64BITTYPES_NEEDED -DHAVE_INTTYPES_H #ENDIF#
+#VAMPIRTRACE#PROFILEOPT36 = -DTAU_VAMPIRTRACE -I$(VAMPIRTRACEDIR)/vtlib -I$(VAMPIRTRACEDIR)/include $(TAU_VAMPIRTRACEOPTS)#ENDIF#
+#PROFILECALLPATH#PROFILEOPT36 = -DTAU_CALLPATH #ENDIF#
+#PROFILEPHASE#PROFILEOPT36 = -DTAU_CALLPATH -DTAU_PROFILEPHASE#ENDIF#
+#PYTHON#PROFILEOPT37 = -I$(PYTHON_INCDIR) #ENDIF#
+#NOCOMM#PROFILEOPT38 = -DTAU_NOCOMM #ENDIF#
+#MUSE#PROFILEOPT39 = -DTAU_MUSE #ENDIF#
+#SETNODE0#PROFILEOPT40 = -DTAU_SETNODE0 #ENDIF#
+#COMPENSATE#PROFILEOPT41 = -DTAU_COMPENSATE #ENDIF#
+#MUSE_EVENT#PROFILEOPT42 = -DTAU_MUSE_EVENT #ENDIF#
+#MUSE_MULTIPLE#PROFILEOPT43 = -DTAU_MUSE_MULTIPLE #ENDIF#
+#DYNINST41##PROFILEOPT44 = -DTAU_DYNINST41BUGFIX #ENDIF#
+# DyninstAPI v4.2.1 fixes the bug, so we don't need OPT44 anymore
+#PROFILEMEMORY#PROFILEOPT45 = -DTAU_PROFILEMEMORY #ENDIF#
+PROFILEOPT46 = -DTAU_MPIGREQUEST #ENDIF##MPIGREQUEST#
+#MPIOREQUEST#PROFILEOPT47 = -DTAU_MPIOREQUEST #ENDIF#
+PROFILEOPT48 = -DTAU_MPIDATAREP #ENDIF##MPIDATAREP#
+PROFILEOPT49 = -DTAU_MPIERRHANDLER #ENDIF##MPIERRHANDLER#
+#CATAMOUNT#PROFILEOPT50 = -DTAU_CATAMOUNT #ENDIF#
+#MPICONSTCHAR#PROFILEOPT51 = -DTAU_MPICONSTCHAR #ENDIF#
+PROFILEOPT52 = -DTAU_MPIATTRFUNCTION #ENDIF##MPIATTR#
+PROFILEOPT53 = -DTAU_MPITYPEEX #ENDIF##MPITYPEEX#
+PROFILEOPT54 = -DTAU_MPIADDERROR #ENDIF##MPIADDERROR#
+#MPINEEDSTATUSCONV#PROFILEOPT55 = -DTAU_MPI_NEEDS_STATUS #ENDIF#
+
+#DEPTHLIMIT#PROFILEOPT56 = -DTAU_DEPTH_LIMIT #ENDIF#
+#TAU_CHARM#PROFILEOPT57 = -DTAU_CHARM -I$(CHARMDIR)/include #ENDIF#
+#PROFILEHEADROOM#PROFILEOPT58 = -DTAU_PROFILEHEADROOM #ENDIF#
+#JAVACPUTIME#PROFILEOPT59 = -DJAVA_CPU_TIME #ENDIF#
+PROFILEOPT60 = -DTAU_LARGEFILE -D_LARGEFILE64_SOURCE #ENDIF##TAU_LARGEFILE#
+PROFILEOPT60 = -DTAU_LARGEFILE -D_LARGEFILE64_SOURCE -D__xlc__ #ENDIF##BGP#
+# Omit the -D_LARGETFILE64_SOURCE till we can check the IBM crash
+#SHMEM#PROFILEOPT61 = -DTAU_SHMEM #ENDIF#
+#KTAU#PROFILEOPT62 = -DTAUKTAU -DKTAU_USER_SRC_COMPILE -I$(KTAU_INCDIR) -I$(KTAU_INCUSERDIR) -DKTAU_INCUSERDIR=\"$(KTAU_INCUSERDIR)\" -DKTAU_KALLSYMS_PATH=\"$(KTAU_KALLSYMS_PATH)\" #ENDIF#
+#KTAU_MERGE#PROFILEOPT63 = -DTAUKTAU_MERGE -DKTAU_USER_SRC_COMPILE -I$(KTAU_INCDIR) -DKTAU_INCUSERDIR=\"$(KTAU_INCUSERDIR)\" -DKTAU_KALLSYMS_PATH=\"$(KTAU_KALLSYMS_PATH)\" #ENDIF#
+#FREEBSD#PROFILEOPT64 = -DTAU_FREEBSD #ENDIF#
+#PROFILEPARAM#PROFILEOPT65 = -DTAU_PROFILEPARAM #ENDIF#
+#IBMMPI#PROFILEOPT66 = -DTAU_IBM_MPI #ENDIF#
+#WEAKMPIINIT#PROFILEOPT67 = -DTAU_WEAK_MPI_INIT #ENDIF#
+#LAMPI#PROFILEOPT68 = -DTAU_LAMPI #ENDIF#
+#MPICH_IGNORE_CXX_SEEK#PROFILEOPT68 = -DMPICH_IGNORE_CXX_SEEK #ENDIF#
+PROFILEOPT68 = -DMPICH_IGNORE_CXX_SEEK #ENDIF##BGP#
+#MPICH2_MPI_INPLACE#PROFILEOPT73 = -DTAU_MPICH2_MPI_IN_PLACE #ENDIF#
+
+
+############# RENCI Scalable Trace Lib Options #############
+STFF_DIR=
+SDDF_DIR=
+#RENCI_STFF#PROFILEOPT69 = -DRENCI_STFF -I$(STFF_DIR)/include #ENDIF#
+#RENCI_STFF#TAU_LINKER_OPT11 = -L$(STFF_DIR)/lib -lstff -L$(SDDF_DIR)/lib -lPablo $(TAU_MPI_LIB) #ENDIF#
+#RENCI_STFF#RENCI_STFF_O = RenciSTFF.o #ENDIF#
+
+############# KTAU (again) #############
+#KTAU_SHCTR#PROFILEOPT70 = -DTAUKTAU_SHCTR -DKTAU_USER_SRC_COMPILE -I$(KTAU_INCDIR) -DKTAU_INCUSERDIR=\"$(KTAU_INCUSERDIR)\" -DKTAU_KALLSYMS_PATH=\"$(KTAU_KALLSYMS_PATH)\" #ENDIF#
+#KTAU#TAU_LINKER_OPT12 = -L$(KTAU_LIB) -lktau #ENDIF#
+
+#MIPS32LINUX#PROFILEOPT71 = -D_ABIN32=2 -D_MIPS_SIM=_ABIN32 #ENDIF#
+
+#BGL#PROFILEOPT72 = -DTAU_BGL -I/bgl/BlueLight/ppcfloor/bglsys/include #ENDIF#
+PROFILEOPT72 = -DTAU_BGP -I/bgsys/drivers/ppcfloor/arch/include/common -I/bgsys/drivers/ppcfloor/arch/include -I/bgsys/drivers/ppcfloor/arch/include/spi #ENDIF##BGP#
+
+#For F90 support for all platforms
+FWRAPPER = TauFMpi.o
+MPI2EXTENSIONS = TauMpiExtensions.o #ENDIF##MPI2#
+MPI2EXTENSIONS = #ENDIF##BGP#
+#CRAYX1CC#MPI2EXTENSIONS = #ENDIF#
+
+#SGICOUNTERS#LEXTRA = -lperfex #ENDIF#
+#ALPHATIMERS#LEXTRA = -lrt #ENDIF#
+#SOL2#PCL_EXTRA_LIBS = -lcpc #ENDIF#
+#PCL#LEXTRA = -L$(PCLDIR)/lib -lpcl $(PCL_EXTRA_LIBS) #ENDIF#
+#PAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a #ENDIF#
+#IA64PAPI#LEXTRA = -L$(PAPIDIR)/$(PAPISUBDIR) -lpapi #ENDIF#
+#Due to some problems with older versions of libpfm, we are using the static lib
+#IA64PAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a #ENDIF#
+#PAPIPFM##LEXTRA = -L$(PAPIDIR)/$(PAPISUBDIR) -lpfm -lpapi -lpfm #ENDIF#
+#X86_64PAPI#LEXTRA = -L$(PAPIDIR)/$(PAPISUBDIR)/ -L$(PAPIDIR)/lib64/ -lpapi -lperfctr #ENDIF#
+#SOL2PAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a -lcpc #ENDIF#
+#IBMPAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a -L/usr/lpp/pmtoolkit/lib -L/usr/pmapi/lib -lpmapi#ENDIF#
+#PPC64PAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a #ENDIF#
+#BGLPAPI_RTS#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.rts.a -L/bgl/BlueLight/ppcfloor/bglsys/lib -lbgl_perfctr.rts -lrts.rts -ldevices.rts #ENDIF#
+#BGLPAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a -L/bgl/BlueLight/ppcfloor/bglsys/lib -lbgl_perfctr.rts -lrts.rts -ldevices.rts #ENDIF#
+#BGPPAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a -L/bgsys/drivers/ppcfloor/runtime/SPI -lSPI.cna #ENDIF#
+#IBM64PAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi64.a -L/usr/lpp/pmtoolkit/lib -L/usr/pmapi/lib -lpmapi #ENDIF#
+#IBM64PAPILINUX#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a #ENDIF#
+#SGI64PAPI#LEXTRA = -L$(PAPIDIR)/$(PAPISUBDIR) -lpapi64 #ENDIF#
+#ALPHAPAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a /usr/lib/dcpi/dadd.a -lclu -lrt #ENDIF#
+
+TAU_PAPI_EXTRA_FLAGS = $(LEXTRA)
+#IA64PAPI#TAU_PAPI_EXTRA_FLAGS = -L$(PAPIDIR)/$(PAPISUBDIR) -lpapi #ENDIF#
+
+
+# By default make TAU_PAPI_RPATH null. Support it on a compiler by compiler basis.
+#PAPI###TAU_PAPI_RPATH = -rpath $(PAPIDIR)/$(PAPISUBDIR) #ENDIF#
+#PAPI##TAU_PAPI_RPATH = #ENDIF#
+#PPC64PAPI#TAU_PAPI_RPATH = #ENDIF#
+#BGLPAPI#TAU_PAPI_RPATH = #ENDIF#
+#BGPPAPI#TAU_PAPI_RPATH = #ENDIF#
+#USE_INTELCXX#TAU_PAPI_RPATH = #ENDIF#
+#CRAYX1CC#TAU_PAPI_RPATH = #ENDIF#
+#PGI#TAU_PAPI_RPATH = -R$(PAPIDIR)/$(PAPISUBDIR) #ENDIF#
+#GNU#TAU_PAPI_RPATH = -Wl,-rpath $(PAPIDIR)/$(PAPISUBDIR) #ENDIF#
+#USE_PATHCC#TAU_PAPI_RPATH = #ENDIF#
+
+# if the user has specified -cc=gcc -c++=g++ -fortran=intel, we shouldn't use -rpath
+# because they are likely going to link with ifort
+#INTEL32_FORTRAN#TAU_PAPI_RPATH = #ENDIF#
+#SOL2PAPI#TAU_PAPI_RPATH = #ENDIF#
+#IBMPAPI#TAU_PAPI_RPATH = #ENDIF#
+#IBM64PAPI#TAU_PAPI_RPATH = #ENDIF#
+#PAPI#TAU_LINKER_OPT1 = $(TAU_PAPI_RPATH) #ENDIF#
+
+#PTHREAD_AVAILABLE#LEXTRA1 = -lpthread #ENDIF#
+#TULIPTHREADS#LEXTRA1 = -L$(TULIPDIR)/Tuliplib -ltulip #ENDIF#
+#SMARTS##include $(TAU_INC_DIR)/makefiles/GNUmakefile-$(HOSTTYPE) #ENDIF#
+#SMARTS#LEXTRA1 = $(LSMARTS) #ENDIF#
+
+TAU_GCCLIB = -lgcc_s
+TAU_GCCLIB = #ENDIF##BGP#
+#INTEL32_ON_64#TAU_GCCLIB = -lgcc #ENDIF#
+#FREEBSD#TAU_GCCLIB = -lgcc #ENDIF#
+#BGL#TAU_GCCLIB = -lgcc #ENDIF#
+#GNU#TAU_FORTRANLIBS = -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lstdc++ $(TAU_GCCLIB) #ENDIF#
+#OPEN64ORC_FORTRAN#TAU_FORTRANLIBS = -lfortran -lffio #ENDIF#
+#PATHSCALE_FORTRAN#TAU_FORTRANLIBS = -lpathfstart -lpathfortran #ENDIF#
+#SC_PATHSCALE#TAU_FORTRANLIBS = -lpathfstart -lpathfortran #ENDIF#
+#NAGWARE_FORTRAN#TAU_FORTRANLIBS = $(EXTRADIR)/lib/quickfit.o -L$(EXTRADIR)/lib -lf96 #ENDIF#
+#G95_FORTRAN#TAU_FORTRANLIBS = -L$(EXTRADIR) -lf95 #ENDIF#
+#GNU_FORTRAN#TAU_FORTRANLIBS = -lg2c #ENDIF#
+#GNU_GFORTRAN#TAU_FORTRANLIBS = -L$(TAUGFORTRANLIBDIR) -lgfortran -lgfortranbegin #ENDIF#
+#SC_GFORTRAN#TAU_FORTRANLIBS = -lgfortran -lgfortranbegin #ENDIF#
+#SGI_FORTRAN#TAU_FORTRANLIBS = -lfortran -lftn #ENDIF#
+TAU_IBM_FORTRANLIBS = -bh:4 -bpT:0x10000000 -bpD:0x20000000 /lib/crt0.o -lxlf90 -lm -lc #ENDIF##USE_IBMXLC#
+#GNU#TAU_IBM_FORTRANLIBS = -Wl,-bh:4 -Wl,-bpT:0x10000000 -Wl,-bpD:0x20000000 /lib/crt0.o -lxlf90 -lm -lc #ENDIF#
+#KAI#TAU_IBM_FORTRANLIBS = --backend -bh:4 --backend -bpT:0x10000000 --backend -bpD:0x20000000 /lib/crt0.o -lxlf90 -lm -lc #ENDIF#
+TAU_FORTRANLIBS = $(TAU_IBM_FORTRANLIBS) #ENDIF##IBM_FORTRAN#
+
+TAU_IBM64_FORTRANLIBS = -bh:4 -bpT:0x10000000 -bpD:0x20000000 -b64 /lib/crt0_64.o -lxlf90 -lm -lc #ENDIF##USE_IBMXLC#
+#GNU#TAU_IBM64_FORTRANLIBS = -Wl,-bh:4 -Wl,-bpT:0x10000000 -Wl,-bpD:0x20000000 -Wl,-b64 /lib/crt0_64.o -lxlf90 -lm -lc #ENDIF#
+#KAI#TAU_IBM64_FORTRANLIBS = --backend -bh:4 --backend -bpT:0x10000000 --backend -bpD:0x20000000 --backend -b64 /lib/crt0_64.o -lxlf90 -lm -lc #ENDIF#
+#IBM64_FORTRAN#TAU_FORTRANLIBS = $(TAU_IBM64_FORTRANLIBS) #ENDIF#
+#IBM64_FORTRAN#TAU_FORLIBDIR=lib64 #ENDIF#
+TAU_FORLIBDIR=lib #ENDIF##IBM_FORTRAN#
+#BGL#TAU_FORLIBDIR=blrts_dev_lib #ENDIF#
+TAU_FORLIBDIR=bglib #ENDIF##BGP#
+#PPC64#TAU_FORTRANLIBS = -L$(EXTRADIR)/$(TAU_FORLIBDIR) -lxlf90 -lxlfmath -lxl #ENDIF#
+#BGL#TAU_FORTRANLIBS = -L$(EXTRADIR)/$(TAU_FORLIBDIR) -L$(EXTRADIR)/blrts_lib -lxlf90 -lxlfmath -lxl #ENDIF#
+
+TAU_BGL_OMP_SERIAL= -lxlomp_ser #ENDIF##BGP#
+#OPENMP#TAU_BGL_OMP_SERIAL= #ENDIF#
+TAU_OMP_SERIAL=$(TAU_BGL_OMP_SERIAL) #ENDIF##BGP#
+TAU_FORTRANLIBS = -L$(EXTRADIR)/$(TAU_FORLIBDIR) -lxlf90 -lxlfmath $(TAU_OMP_SERIAL) #ENDIF##BGP#
+
+#IBMXLFAPPLE#TAU_FORTRANLIBS = -L$(EXTRADIR)/lib -lxlf90 -lxlfmath -lxl #ENDIF#
+
+#CRAY_FORTRAN#TAU_FORTRANLIBS = #ENDIF#
+#CRAY_X1_FORTRAN#TAU_FORTRANLIBS = #ENDIF#
+#PGI_FORTRAN#TAU_FORTRANLIBS = $(EXTRADIR)/lib/f90main.o -lpgf90 -lpgf90rtl -lpgf90_rpm1 -lpgf902 -lpgftnrtl -lrt #ENDIF#
+#HP_FORTRAN#TAU_FORTRANLIBS = -L$(EXTRADIR)/lib/pa2.0 -lF90 -lcl #ENDIF#
+#INTEL_FORTRAN#TAU_FORTRANLIBS = -lcprts -lPEPCF90 #ENDIF#
+#INTEL32_FORTRAN#TAU_FORTRANLIBS = -lcprts -lCEPCF90 -lF90 #ENDIF#
+#INTELIFORT#TAU_FORTRANLIBS = -lcprts #ENDIF#
+#INTEL81FIX#TAU_FORTRANLIBS = -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lstdc++ $(TAU_GCCLIB) -lcxa -lunwind -L$(EXTRADIR)/lib -lifcore $(EXTRADIR)/lib/for_main.o #ENDIF#
+#INTEL10FIX#TAU_FORTRANLIBS = -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lstdc++ $(TAU_GCCLIB) -L$(EXTRADIR)/lib -lifcore $(EXTRADIR)/lib/for_main.o #ENDIF#
+#INTELCXXLIBICC#TAU_FORTRANLIBS = -lcprts -L$(EXTRADIR)/lib -lifcore $(EXTRADIR)/lib/for_main.o #ENDIF#
+#PGI1.7#LEXTRA = -lstd -lstrm#ENDIF#
+#PGI1.7#TAUHELPER = $(TAUROOT)/src/Profile/TauPGIHelper.cpp #ENDIF#
+# LINKER OPTIONS
+TAU_LINKER_OPT2 = $(LEXTRA)
+
+
+#ACC#TAUHELPER = -AA #ENDIF#
+#FUJITSU_FORTRAN#TAU_FORTRANLIBS = $(EXTRADIR)/lib/fj90rt0.o -L$(EXTRADIR)/lib -lfj9i6 -lfj9f6 -lfj9e6 #ENDIF#
+#FUJITSU_SOLARIS#TAU_FORTRANLIBS = $(EXTRADIR)/lib/fj90rt0.o -L$(EXTRADIR)/lib -lfj90l -lfj90f #ENDIF#
+#SUN_FORTRAN#TAU_FORTRANLIBS = -lfui -lfsumai -lfprodai -lfminlai -lfmaxlai -lfminvai -lfmaxvai -lfsu -lsunmath #ENDIF#
+#SUN_FORTRAN#TAU_FORTRANLIBS_SUN_OPTERON = -lfsu -lsunmath #ENDIF#
+#SUN_FORTRAN#TAU_FORTRANLIBS_SUNCC = -lfsu #ENDIF#
+#SUN386I#TAU_FORTRANLIBS = $(TAU_FORTRANLIBS_SUN_OPTERON) #ENDIF#
+#SUNX86_64#TAU_FORTRANLIBS = $(TAU_FORTRANLIBS_SUN_OPTERON) #ENDIF#
+#SUNCC#TAU_FORTRANLIBS = $(TAU_FORTRANLIBS_SUNCC) #ENDIF#
+#SOL2#EXTRALIBS = -lsocket -lnsl #ENDIF#
+#SUN386I#EXTRALIBS = -lsocket -lnsl -lrt #ENDIF#
+#SUNX86_64#EXTRALIBS = -lsocket -lnsl -lrt #ENDIF#
+#COMPAQ_FORTRAN#TAU_FORTRANLIBS = $(EXTRADIR)/lib/cmplrs/fort90/for_main.o -L$(EXTRADIR)/lib -L$(EXTRADIR)/lib/cmplrs/fort90 -L$(EXTRADIR)/lib/cmplrs/fort90 -lUfor -lfor -lFutil -lm -lmld -lexc -lc #ENDIF#
+#ABSOFT_FORTRAN#TAU_FORTRANLIBS = -L$(EXTRADIR)/lib -lfio -lf90math -lU77 -lf77math -lfio #ENDIF#
+#LAHEY_FORTRAN#TAU_FORTRANLIBS = $(EXTRADIR)/lib/fj90rt0.o -L$(EXTRADIR)/lib -lfj9i6 -lfj9f6 -lfj9e6 -lfccx86_6a #ENDIF#
+#LAHEY64_FORTRAN#TAU_FORTRANLIBS = $(EXTRADIR)/lib64/fj90rt0.o -L$(EXTRADIR)/lib64 -lfj90f -lfj90i -lelf #ENDIF#
+#HITACHI_FORTRAN#TAU_FORTRANLIBS = -lf90 -lhf90math #ENDIF#
+#NEC_FORTRAN#TAU_FORTRANLIBS = -f90lib #ENDIF#
+#COMPAQ_GUIDEF90#TAU_FORTRANLIBS = $(EXTRADIR)/lib/cmplrs/fort90/for_main.o -lfor #ENDIF#
+
+
+#HITACHI#TAU_HITACHI_EXTRA = -L/usr/local/lib -llrz32 #ENDIF#
+
+## To use the standard F90 linker instead of TAU_LINKER + TAU_FORTRANLIBS, add
+#GNU#TAU_CXXLIBS = -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lstdc++ $(TAU_GCCLIB) #ENDIF#
+#GNU#TAU_GNUCXXLIBS = -L$(TAUGCCLIBDIR) -lstdc++ $(TAU_GCCLIB) #ENDIF#
+#OPEN64ORC#TAU_CXXLIBS = -lstdc++ #ENDIF#
+#PATHSCALE_FORTRAN#TAU_CXXLIBS = -lstdc++ #ENDIF#
+#LAHEY_FORTRAN#TAU_CXXLIBS = $(TAU_GNUCXXLIBS) /usr/lib/libc.a #ENDIF#
+#NAGWARE_FORTRAN#TAU_CXXLIBS = $(TAU_GNUCXXLIBS) /usr/lib/libc.a #ENDIF#
+#PGI#TAU_CXXLIBS = -lstd -lC #ENDIF#
+#CRAYCNL#TAU_CXXLIBS = -L$(EXTRADIR)/lib -lstd -lC -lpgc #ENDIF#
+#CRAYX1CC#TAU_CXXLIBS = -L/opt/ctl/CC/CC/lib -lC #ENDIF#
+
+TAU_SGI_INIT = /usr/lib32/c++init.o
+#ENABLE64BIT#TAU_SGI_INIT = /usr/lib64/c++init.o #ENDIF#
+#ENABLEN32BIT#TAU_SGI_INIT = /usr/lib32/c++init.o #ENDIF#
+#ENABLE32BIT#TAU_SGI_INIT = /usr/lib/c++init.o #ENDIF#
+
+#SGICC#TAU_CXXLIBS = $(TAU_SGI_INIT) -lC #ENDIF#
+#APPLECXX#TAU_CXXLIBS = -lstd -lC #ENDIF#
+#SOL2#TAU_CXXLIBS = -lCstd -lCrun #ENDIF#
+#SOL2CC#TAU_CXXLIBS_SUN_OPTERON = -lCstd -lCrun -lm #ENDIF#
+#SUNCC#TAU_CXXLIBS_SUNCC = -lCstd -lCrun #ENDIF#
+#SUN386I#TAU_CXXLIBS = $(TAU_CXXLIBS_SUN_OPTERON) #ENDIF#
+#SUNCC#TAU_CXXLIBS = $(TAU_CXXLIBS_SUNCC) #ENDIF#
+#SUNX86_64#TAU_CXXLIBS = $(TAU_CXXLIBS_SUN_OPTERON) #ENDIF#
+#FUJITSU_SOLARIS#TAU_CXXLIBS = -lstd -lstdm #ENDIF#
+#PPC64#TAU_XLCLIBS = -L$(EXTRADIRCXX)/$(TAU_FORLIBDIR) -libmc++ -lstdc++ #ENDIF#
+#IBMXLCAPPLE#TAU_FORLIBDIR =lib #ENDIF#
+#IBMXLCAPPLE#TAU_XLCLIBS = -L$(EXTRADIRCXX)/$(TAU_FORLIBDIR) -libmc++ -lstdc++ #ENDIF#
+#BGL#TAU_XLCLIBS = -L$(EXTRADIRCXX)/blrts_dev_lib -L$(EXTRADIRCXX)/blrts_lib -libmc++ -L/bgl/BlueLight/ppcfloor/blrts-gnu/powerpc-bgl-blrts-gnu/lib -lstdc++ #ENDIF#
+TAU_XLCLIBS = -L$(EXTRADIRCXX)/bglib -libmc++ -lstdc++ #ENDIF##BGP#
+#SP1#TAU_XLCLIBS = -lC #ENDIF#
+TAU_CXXLIBS = $(TAU_XLCLIBS) #ENDIF##USE_IBMXLC#
+#USE_DECCXX#TAU_CXXLIBS = -lcxxstd -lcxx #ENDIF#
+#USE_INTELCXX#TAU_CXXLIBS_INTEL = -lcprts -lPEPCF90 #ENDIF#
+#USE_INTELCXX#TAU_CXXLIBS_INTEL = -lcprts #ENDIF#
+#INTELIFORT#TAU_CXXLIBS_INTEL = -lcprts #ENDIF#
+#INTEL81FIX#TAU_CXXLIBS_INTEL = -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lstdc++ $(TAU_GCCLIB) -lcxa -lunwind#ENDIF#
+#INTEL10FIX#TAU_CXXLIBS_INTEL = -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lstdc++ $(TAU_GCCLIB) #ENDIF#
+#INTELCXXLIBICC#TAU_CXXLIBS_INTEL = -lcprts #ENDIF#
+#USE_INTELCXX#TAU_CXXLIBS = $(TAU_CXXLIBS_INTEL) #ENDIF#
+#APPLECXX#TAU_CXXLIBS = -lstdc++ -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lgcc_s.1 -lSystemStubs #ENDIF#
+
+# EXTERNAL PACKAGES: VAMPIRTRACE
+#VAMPIRTRACE#TAU_LINKER_OPT3 = -L$(VAMPIRTRACEDIR)/lib -L$(VAMPIRTRACEDIR)/vtlib -lvt -lotf -lz $(TAU_HITACHI_EXTRA) #ENDIF#
+#VAMPIRTRACEMPI#TAU_LINKER_OPT3 = -L$(VAMPIRTRACEDIR)/lib -L$(VAMPIRTRACEDIR)/vtlib -lvt.mpi -lotf -lz $(TAU_HITACHI_EXTRA) #ENDIF#
+#VAMPIRTRACEOMPI#TAU_LINKER_OPT3 = -L$(VAMPIRTRACEDIR)/lib -L$(VAMPIRTRACEDIR)/vtlib -lvt.ompi -lotf -lz $(TAU_HITACHI_EXTRA) #ENDIF#
+#VAMPIRTRACEOMP#TAU_LINKER_OPT3 = -L$(VAMPIRTRACEDIR)/lib -L$(VAMPIRTRACEDIR)/vtlib -lvt.omp -lotf -lz $(TAU_HITACHI_EXTRA) #ENDIF#
+
+# EXTERNAL PACKAGES: EPILOG
+#SCALASCA#TAU_ELG_SERIAL_SUFFIX =.ser #ENDIF#
+#EPILOG#TAU_LINKER_OPT3 = -L$(EPILOGLIBDIR) -lelg$(TAU_ELG_SERIAL_SUFFIX) $(EPILOGEXTRALINKCMD) $(TAU_HITACHI_EXTRA) #ENDIF#
+#EPILOGMPI#TAU_LINKER_OPT3 = -L$(EPILOGLIBDIR) -lelg.mpi $(EPILOGEXTRALINKCMD) $(TAU_HITACHI_EXTRA) #ENDIF#
+#EPILOGOMPI#TAU_LINKER_OPT3 = -L$(EPILOGLIBDIR) -lelg.ompi $(EPILOGEXTRALINKCMD) $(TAU_HITACHI_EXTRA) #ENDIF#
+#EPILOGOMP#TAU_LINKER_OPT3 = -L$(EPILOGLIBDIR) -lelg.omp $(EPILOGEXTRALINKCMD) $(TAU_HITACHI_EXTRA) #ENDIF#
+
+# When using shared, we don't want -lelg.mpi or -lvt.mpi showing up
+#FORCESHARED#TAU_LINKER_OPT3=#ENDIF#
+
+TAU_LINKER_OPT4 = $(LEXTRA1)
+#HITACHI_OPENMP#TAU_LINKER_OPT4 = -lcompas -lpthreads -lc_r #ENDIF#
+#OPENMP#TAU_LINKER_OPT5 = -mp #ENDIF#
+#SOL2CC_OPENMP#TAU_LINKER_OPT5 = -xopenmp #ENDIF#
+#SUNCC_OPENMP#TAU_LINKER_OPT5 = -xopenmp=parallel #ENDIF#
+#GNU#TAU_LINKER_OPT5 = #ENDIF#
+#COMPAQCXX_OPENMP#TAU_LINKER_OPT5 = -omp #ENDIF#
+#IBMXLC_OPENMP#TAU_LINKER_OPT5 = -qsmp=omp #ENDIF#
+#OPEN64_OPENMP#TAU_LINKER_OPT5 = -mp #ENDIF#
+#GUIDE#TAU_LINKER_OPT5 = #ENDIF#
+#PGIOPENMP#TAU_LINKER_OPT5 = -mp #ENDIF#
+#INTELOPENMP#TAU_LINKER_OPT5 = -openmp #ENDIF#
+
+# MALLINFO needs -lmalloc on sgi, sun
+#SGIMP#TAU_LINKER_OPT6 = -lmalloc #ENDIF#
+#SOL2#TAU_LINKER_OPT6 = #ENDIF#
+#SUN386I#TAU_LINKER_OPT6 = -lmalloc #ENDIF#
+#SUNX86_64#TAU_LINKER_OPT6 = -lmalloc #ENDIF#
+
+# We need -lCio with SGI CC 7.4+
+#SGICC#TAU_LINKER_OPT7 = -lCio #ENDIF#
+
+# charm
+#TAU_CHARM#TAU_LINKER_OPT8 = -lconv-core #ENDIF#
+
+# extra libs
+#SUN386I#TAU_LINKER_OPT9 = $(EXTRALIBS) #ENDIF#
+#SUNX86_64#TAU_LINKER_OPT9 = $(EXTRALIBS) #ENDIF#
+#SOL2#TAU_LINKER_OPT9 = $(ExTRALIBS) #ENDIF#
+
+#BGL#TAU_LINKER_OPT10 = -L/bgl/BlueLight/ppcfloor/bglsys/lib -lrts.rts #ENDIF#
+
+TAU_IBM_PYTHON_SHFLAG = -Wl,-bI:$(PYTHON_LIBDIR)/config/python.exp -Wl,-einitpytau#ENDIF##USE_IBMXLC#
+#GNU#TAU_IBM_PYTHON_SHFLAG = -Wl,-bI:$(PYTHON_LIBDIR)/config/python.exp -Wl,-einitpytau#ENDIF#
+#KAI#TAU_IBM_PYTHON_SHFLAG = --backend -Wl,-bI:$(PYTHON_LIBDIR)/config/python.exp --backend -Wl,-einitpytau#ENDIF#
+#ACC#TAU_HPUX_PYTHON_SHFLAG = -lstd_v2 -lCsup_v2 -lm -lcl -lc #ENDIF#
+
+TAU_IBM_LD_FLAGS = -binitfini:poe_remote_main #ENDIF##USE_IBMXLC#
+#GNU#TAU_IBM_LD_FLAGS = -Wl,-binitfini:poe_remote_main #ENDIF#
+#KAI#TAU_IBM_LD_FLAGS = --backend -binitfini:poe_remote_main #ENDIF#
+
+
+#PYTHON#TAU_IBM_SHFLAGS = $(TAU_IBM_PYTHON_SHFLAG) #ENDIF#
+#PYTHON#TAU_HPUX_SHFLAGS = $(TAU_HPUX_PYTHON_SHFLAG) #ENDIF#
+#SP1#TAU_EXTRA_LIBRARY_FLAGS = $(TAU_IBM_SHFLAGS) #ENDIF#
+#SOL2#TAU_EXTRA_LIBRARY_FLAGS = #ENDIF#
+#SGIMP#TAU_EXTRA_LIBRARY_FLAGS = -lmalloc #ENDIF#
+#HP#TAU_EXTRA_LIBRARY_FLAGS = $(TAU_HPUX_SHFLAGS) #ENDIF#
+
+TAU_MPI_WRAPPER_LIB= -L$(TAU_LIB_DIR) -lTauMpi$(TAU_CONFIG) #ENDIF##MPI#
+#EPILOGMPI#TAU_MPI_WRAPPER_LIB= #ENDIF#
+#EPILOGOMPI#TAU_MPI_WRAPPER_LIB= #ENDIF#
+
+##############################################
+# Build TAU_LINKER_SHOPTS
+#GNU#TAU_IBM_LINKER_SHOPTS=-Wl,-brtl -Wl,-bexpall #ENDIF#
+TAU_IBM_LINKER_SHOPTS= -brtl -bexpall #ENDIF##USE_IBMXLC#
+#KAI#TAU_IBM_LINKER_SHOPTS= --backend -brtl #ENDIF#
+#SP1#TAU_LINKER_SHOPTS= $(TAU_IBM_LINKER_SHOPTS) #ENDIF#
+
+##############################################
+# MPI _r suffix check (as in libmpi_r)
+#MPI_R_SUFFIX#TAU_MPI_R_SUFFIX=_r #ENDIF#
+
+##############################################
+# Flags to build a shared object: TAU_SHFLAGS
+#GNU#AR_SHFLAGS = -shared #ENDIF#
+#PGI#AR_SHFLAGS = -shared #ENDIF#
+#SGICC#AR_SHFLAGS = -shared #ENDIF#
+#APPLECXX#AR_SHFLAGS = -dynamiclib -flat_namespace -undefined suppress #ENDIF#
+#SOL2#AR_SHFLAGS = -G #ENDIF#
+#SUN386I#AR_SHFLAGS = -G #ENDIF#
+#SUNX86_64#AR_SHFLAGS = -G #ENDIF#
+AR_SHFLAGS = -G #ENDIF##USE_IBMXLC#
+#USE_DECCXX#AR_SHFLAGS = -shared #ENDIF#
+#USE_INTELCXX#AR_SHFLAGS = -shared #ENDIF#
+#ACC#AR_SHFLAGS = -b #ENDIF#
+TAU_SHFLAGS = $(AR_SHFLAGS) -o
+
+############# RANLIB Options #############
+TAU_RANLIB = echo "Built"
+#APPLECXX#TAU_RANLIB = ranlib #ENDIF#
+#IBMXLCAPPLE#TAU_RANLIB = ranlib #ENDIF#
+
+##############################################
+TAU_AR = ar #ENDIF#
+#SP1#TAU_AR = ar -X32 #ENDIF#
+#IBM64#TAU_AR = ar -X64 #ENDIF#
+#PPC64#TAU_AR = ar #ENDIF#
+#IBM64LINUX#TAU_AR = ar #ENDIF#
+
+
+##############################################
+# PDT OPTIONS
+# You can specify -pdtcompdir=intel -pdtarchdir=x86_64
+# If nothing is specified, PDTARCHDIR uses TAU_ARCH
+PDTARCHDIRORIG=$(TAU_ARCH)
+PDTARCHITECTURE=x86_64
+PDTARCHDIRFINAL=$(PDTARCHDIRORIG)
+#PDTARCHITECTURE#PDTARCHDIRFINAL=$(PDTARCHITECTURE)#ENDIF#
+PDTARCHDIR=$(PDTARCHDIRFINAL)
+#PDTARCH#PDTARCHDIR=$(PDTARCHDIRFINAL)/$(PDTCOMPDIR)#ENDIF#
+
+
+##############################################
+
+PROFILEOPTS = $(PROFILEOPT1) $(PROFILEOPT2) $(PROFILEOPT3) $(PROFILEOPT4) \
+ $(PROFILEOPT5) $(PROFILEOPT6) $(PROFILEOPT7) $(PROFILEOPT8) \
+ $(PROFILEOPT9) $(PROFILEOPT10) $(PROFILEOPT11) $(PROFILEOPT12) \
+ $(PROFILEOPT13) $(PROFILEOPT14) $(PROFILEOPT15) $(PROFILEOPT16) \
+ $(PROFILEOPT17) $(PROFILEOPT18) $(PROFILEOPT19) $(PROFILEOPT20) \
+ $(PROFILEOPT21) $(PROFILEOPT22) $(PROFILEOPT23) $(PROFILEOPT24) \
+ $(PROFILEOPT25) $(PROFILEOPT26) $(PROFILEOPT27) $(PROFILEOPT28) \
+ $(PROFILEOPT29) $(PROFILEOPT30) $(PROFILEOPT31) $(PROFILEOPT32) \
+ $(PROFILEOPT33) $(PROFILEOPT34) $(PROFILEOPT35) $(PROFILEOPT36) \
+ $(PROFILEOPT37) $(PROFILEOPT38) $(PROFILEOPT39) $(PROFILEOPT40) \
+ $(PROFILEOPT41) $(PROFILEOPT42) $(PROFILEOPT43) $(PROFILEOPT44) \
+ $(PROFILEOPT45) $(PROFILEOPT46) $(PROFILEOPT47) $(PROFILEOPT48) \
+ $(PROFILEOPT49) $(PROFILEOPT50) $(PROFILEOPT51) $(PROFILEOPT52) \
+ $(PROFILEOPT53) $(PROFILEOPT54) $(PROFILEOPT55) $(PROFILEOPT56) \
+ $(PROFILEOPT57) $(PROFILEOPT58) $(PROFILEOPT59) $(PROFILEOPT60) \
+ $(PROFILEOPT61) $(PROFILEOPT62) $(PROFILEOPT63) $(PROFILEOPT64) \
+ $(PROFILEOPT65) $(PROFILEOPT66) $(PROFILEOPT67) $(PROFILEOPT68) \
+ $(PROFILEOPT69) $(PROFILEOPT70) $(PROFILEOPT71) $(PROFILEOPT72) \
+ $(PROFILEOPT73) $(PROFILEOPT74) $(PROFILEOPT75) $(PROFILEOPT76) \
+ $(TRACEOPT)
+
+##############################################
+
+TAU_LINKER_OPTS = $(TAU_LINKER_OPT1) $(TAU_LINKER_OPT2) $(TAU_LINKER_OPT3) \
+ $(TAU_LINKER_OPT4) $(TAU_LINKER_OPT5) $(TAU_LINKER_OPT6) \
+ $(TAU_LINKER_OPT7) $(TAU_LINKER_OPT8) $(TAU_LINKER_OPT9) \
+ $(TAU_LINKER_OPT10) $(TAU_LINKER_OPT11) $(TAU_LINKER_OPT12)
+
+##############################################
+
+############# TAU Fortran ####################
+TAU_LINKER=$(TAU_CXX)
+#INTEL_FORTRAN##TAU_LINKER=$(TAU_F90) #ENDIF#
+#INTEL32_FORTRAN##TAU_LINKER=$(TAU_F90) #ENDIF#
+# Intel efc compiler acts as a linker - NO. Let C++ be the linker.
+
+##############################################
+############# TAU Options ####################
+TAUDEFS = $(PROFILEOPTS)
+
+TAUINC = -I$(TAU_INC_DIR)
+
+TAULIBS = $(TAUHELPER) -L$(TAU_LIB_DIR) -ltau$(TAU_CONFIG) $(TAU_LINKER_OPTS)
+
+TAUMPILIBS = $(TAU_MPI_LIB)
+
+TAUMPIFLIBS = $(TAU_MPI_FLIB)
+
+### ACL S/W requirement
+TAU_DEFS = $(TAUDEFS)
+
+TAU_INCLUDE = -I$(TAU_INC_DIR)
+#PERFLIB#TAU_INCLUDE = -I$(PERFINCDIR) #ENDIF#
+#PERFLIB#TAU_DEFS = #ENDIF#
+#PERFLIB#TAU_COMPILER_EXTRA_OPTIONS=-optTau=-p #ENDIF#
+
+TAU_INCLUDE_MEMORY = -I$(TAU_INC_DIR)/Memory
+#IBMXLCAPPLE#TAU_INCLUDE_MEMORY = -I$(TAU_INC_DIR)/MemoryWrapper #ENDIF#
+#APPLECXX#TAU_INCLUDE_MEMORY = -I$(TAU_INC_DIR)/MemoryWrapper #ENDIF#
+
+TAU_LIBS = $(TAUHELPER) -L$(TAU_LIB_DIR) -ltau$(TAU_CONFIG) $(TAU_LINKER_OPTS)
+#PERFLIB#TAU_LIBS = #ENDIF#
+
+TAU_SHLIBS = $(TAUHELPER) -L$(TAU_LIB_DIR) -lTAUsh$(TAU_CONFIG) $(TAU_LINKER_OPTS) $(TAU_LINKER_SHOPTS) $(TAU_MPI_LIB)
+#PERFLIB#TAU_SHLIBS = #ENDIF#
+TAU_EXLIBS = $(TAUHELPER) -L$(TAU_LIB_DIR) -lTAU $(TAU_LINKER_OPTS) $(TAU_LINKER_SHOPTS) $(TAU_MPI_LIB)
+
+TAU_SHLIBS_NOSHOPTS = $(TAUHELPER) -L$(TAU_LIB_DIR) -lTAUsh$(TAU_CONFIG) $(TAU_LINKER_OPTS)
+
+TAU_DISABLE = $(TAUHELPER) -L$(TAU_LIB_DIR) -lTauDisable
+
+TAU_MPI_INCLUDE = $(TAU_MPI_INC)
+
+TAU_MPI_LIBS = $(TAU_MPI_LIB)
+
+TAU_MPI_FLIBS = $(TAU_MPI_FLIB)
+
+## TAU TRACE INPUT LIBRARY (can build a trace converter using TAU TIL)
+TAU_TRACE_INPUT_LIB = -L$(TAU_LIB_DIR) -lTAU_traceinput$(TAU_CONFIG)
+
+## Don't include -lpthread or -lsmarts. Let app. do that.
+#############################################
+## IBM SPECIFIC CHANGES TO TAU_MPI_LIBS
+#SP1#TAU_MPI_LDFLAGS = $(TAU_IBM_LD_FLAGS) #ENDIF#
+TAU_LDFLAGS = $(TAU_MPI_LDFLAGS) #ENDIF##MPI#
+#SP1#TAU_IBM_MPI_LIBS = $(TAU_MPI_LIB) -L$(TAU_MPILIB_DIR)/ip -lvtd$(TAU_MPI_R_SUFFIX) #ENDIF#
+#SP1#TAU_IBM_FMPI_LIBS = $(TAU_MPI_FLIB) -L$(TAU_MPILIB_DIR)/ip -lvtd$(TAU_MPI_R_SUFFIX) #ENDIF#
+#SP1#TAU_MPI_LIBS_FLAGS= $(TAU_IBM_MPI_LIBS) #ENDIF#
+#SP1#TAU_MPI_FLIBS_FLAGS = $(TAU_IBM_MPI_FLIBS) #ENDIF#
+TAU_MPI_LIBS_FLAGS = $(TAU_MPI_LIB) #ENDIF##MPI#
+TAU_MPI_FLIBS_FLAGS = $(TAU_MPI_FLIB) #ENDIF##MPI#
+TAU_MPI_LIBS = $(TAU_MPI_LIBS_FLAGS) #ENDIF##MPI#
+TAU_MPI_FLIBS = $(TAU_MPI_FLIBS_FLAGS) #ENDIF##MPI#
+
+#SP1#TAUMPILIBS = $(TAU_MPI_LIBS) #ENDIF#
+#SP1#TAUMPIFLIBS = $(TAU_MPI_FLIBS) #ENDIF#
+#############################################
+#SHMEM#TAU_SHMEM_OBJS = TauShmemCray.o #ENDIF#
+#SP1#TAU_SHMEM_OBJS = TauShmemTurbo.o #ENDIF#
+#GPSHMEM#TAU_SHMEM_OBJS = TauShmemGpshmem.o #ENDIF#
+
+TAU_SHMEM_INCLUDE = $(TAU_SHMEM_INC)
+
+TAU_SHMEM_LIBS = -L$(TAU_PREFIX_INSTALL_DIR)/$(CONFIG_ARCH)/ -lTauShmem$(TAU_CONFIG) $(TAU_SHMEM_LIB)
+#############################################
+# TAU COMPILER SHELL SCRIPT OPTIONS
+TAUCOMPILEROPTS= -optPdtDir="$(PDTDIR)/${PDTARCHDIR}"\
+ -optPdtCOpts="$(TAU_INCLUDE) $(TAU_DEFS) $(TAU_MPI_INCLUDE)"\
+ -optPdtCxxOpts="$(TAU_INCLUDE) $(TAU_DEFS) $(TAU_MPI_INCLUDE)"\
+ -optTauInstr="$(TAU_BIN_DIR)/tau_instrumentor" \
+ -optNoMpi \
+ -optOpariDir="$(OPARIDIR)" -optOpariTool="$(TAU_OPARI_TOOL)" \
+ -optTauCC="$(TAU_CC)" \
+ -optTauIncludes="$(TAU_INCLUDE) $(TAU_MPI_INCLUDE)" \
+ -optTauDefs="$(TAU_DEFS)" \
+ -optTauCompile="$(TAU_INCLUDE) $(TAU_MPI_INCLUDE) $(TAU_DEFS) "\
+ -optLinking="$(TAU_MPI_FLIBS) $(TAU_LIBS) $(TAU_LDFLAGS) $(TAU_CXXLIBS)"\
+ -optSharedLinking="$(TAU_MPI_FLIBS) $(TAU_EXLIBS) $(TAU_LDFLAGS) $(TAU_CXXLIBS)"\
+ $(TAU_COMPILER_EXTRA_OPTIONS) \
+ -optIncludeMemory="$(TAU_INCLUDE_MEMORY)"
+#############################################
+
+TAU_SHAREDLIBS=$(TAUHELPER) -L$(TAU_LIB_DIR) -lTAU $(TAU_LINKER_OPTS) $(TAU_LINKER_SHOPTS)
+SHAREDEXTRAS=
+#FORCESHARED#SHAREDEXTRAS=-optSharedLinkReset="$(TAU_SHAREDLIBS) $(TAU_LDFLAGS) $(TAU_CXXLIBS) $(TAU_MPI_NOWRAP_FLIB)" -optShared #ENDIF#
+TAU_COMPILER=$(TAU_BIN_DIR)/tau_compiler.sh $(TAUCOMPILEROPTS) $(SHAREDEXTRAS)
+#############################################
+# These options could be included in the application Makefile as
+#CFLAGS = $(TAUDEFS) $(TAUINC)
+#
+#LIBS = $(TAULIBS)
+#
+# To run the application without Profiling/Tracing use
+#CFLAGS = $(TAUINC)
+# Don't use TAUDEFS but do include TAUINC
+# Also ignore TAULIBS when Profiling/Tracing is not used.
+#############################################
+
--- /dev/null
+###################################################################
+INSTALL_DIR = /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh
+
+
+FC= ifort
+
+OPT = -g -ip -w -CB
+
+FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include
+FFLAGS1 = -c -w -g -d2 -CA -CB -I$(INSTALL_DIR)/include
+FFLAGS2 = -c -w -g -O0 -I$(INSTALL_DIR)/include
+FFLAGSE = -c -w -O3 -ipo -ipo_obj -opt_report -I$(INSTALL_DIR)/include
+
+
+LIBS = -L$(INSTALL_DIR)/lib -lmpich xdrf/libxdrf.a
+
+ARCH = LINUX
+PP = /lib/cpp -P
+
+
+all: unres
+
+.SUFFIXES: .F
+.F.o:
+ ${FC} ${FFLAGS} ${CPPFLAGS} $*.F
+
+
+object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \
+ matmult.o readrtns.o parmread.o gen_rand_conf.o printmat.o map.o \
+ pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \
+ cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \
+ energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \
+ cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \
+ mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \
+ eigen.o blas.o add.o entmcm.o minim_mcmf.o \
+ MP.o compare_s1.o prng.o \
+ banach.o rmsd.o elecont.o dihed_cons.o \
+ sc_move.o local_move.o \
+ intcartderiv.o lagrangian_lesyng.o\
+ stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \
+ surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \
+ q_measure.o gnmr1.o test.o
+
+GAB: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DUNRES -DISNAN -DMP -DMPI \
+ -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC
+GAB: BIN = ../../../bin/unres/MD/unres_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}
+
+E0LL2Y: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DUNRES -DISNAN -DMP -DMPI \
+ -DSPLITELE -DLANG0
+E0LL2Y: BIN = ../../../bin/unres/MD/unres_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}
+
+xdrf/libxdrf.a:
+ cd xdrf && make
+
+
+clean:
+ /bin/rm -f *.o && /bin/rm -f compinfo && cd xdrf && make clean
+
+test.o: test.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} test.F
+
+chainbuild.o: chainbuild.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F
+
+matmult.o: matmult.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f
+
+parmread.o : parmread.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F
+
+intcor.o : intcor.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f
+
+cartder.o : cartder.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F
+
+readpdb.o : readpdb.F
+ ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.F
+
+sumsld.o : sumsld.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f
+
+cored.o : cored.f
+ ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f
+
+rmdd.o : rmdd.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f
+
+energy_p_new_barrier.o : energy_p_new_barrier.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new_barrier.F
+
+gradient_p.o : gradient_p.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} gradient_p.F
+
+energy_p_new-sep_barrier.o : energy_p_new-sep_barrier.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep_barrier.F
+
+lagrangian_lesyng.o : lagrangian_lesyng.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F
+
+MD_A-MTS.o : MD_A-MTS.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} MD_A-MTS.F
+
+blas.o : blas.f
+ ${FC} ${FFLAGS1} blas.f
+
+add.o : add.f
+ ${FC} ${FFLAGS1} add.f
+
+eigen.o : eigen.f
+ ${FC} ${FFLAGS2} eigen.f
+
+proc_proc.o: proc_proc.c
+ ${CC} ${CFLAGS} proc_proc.c
--- /dev/null
+CPPFLAGS = -WF,-DUNRES -WF,-DMP -WF,-DMPI -WF,-DSPLITELE -WF,-DISNAN -WF,-DAIX
+#-DPROCOR
+## -DMOMENT
+#-DCO_BIAS
+#-DCRYST_TOR
+#-DDEBUG
+
+INSTALL_DIR =
+#
+FC= mpxlf90 -qfixed -w
+
+OPT = -q64
+
+FFLAGS = -c ${OPT} -O3
+FFLAGS1 = -c ${OPT} -O2
+FFLAGS2 = -c ${OPT} -O
+FFLAGSE = -c ${OPT} -O4
+
+
+BIN = ${HOME}/UNRES/bin/unres_MD.exe
+LIBS = -qipa
+
+ARCH = LINUX
+PP = /lib/cpp -P
+
+all: unresCSA
+
+.SUFFIXES: .F
+.F.o:
+ ${FC} ${FFLAGS} ${CPPFLAGS} $*.F
+
+object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \
+ matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \
+ pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \
+ cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \
+ energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \
+ cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \
+ mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \
+ eigen.o blas.o add.o entmcm.o minim_mcmf.o \
+ together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \
+ indexx.o MP.o compare_s1.o prng_32.o \
+ test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \
+ sc_move.o local_move.o \
+ intcartderiv.o lagrangian_lesyng.o\
+ stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \
+ surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \
+ q_measure.o gnmr1.o
+
+
+unresCSA: ${objectCSA}
+ cc -o compinfo compinfo.c
+ ./compinfo
+ ${FC} ${FFLAGS} cinfo.f
+ ${FC} ${OPT} ${objectCSA} cinfo.o ${LIBS} -o ${BIN}
+
+
+clean:
+ /bin/rm *.o
+ /bin/rm *.il
+
+newconf.o: newconf.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f
+
+bank.o: bank.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} bank.F
+
+diff12.o: diff12.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f
+
+csa.o: csa.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} csa.f
+
+shift.o: shift.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} shift.F
+
+ran.o: ran.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} ran.f
+
+together.o: together.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} together.F
+
+test.o: test.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} test.F
+
+chainbuild.o: chainbuild.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F
+
+matmult.o: matmult.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f
+
+parmread.o : parmread.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F
+
+intcor.o : intcor.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f
+
+cartder.o : cartder.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F
+
+readpdb.o : readpdb.f
+ ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.f
+
+sumsld.o : sumsld.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f
+
+cored.o : cored.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} cored.f
+
+rmdd.o : rmdd.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f
+
+energy_p_new.o : energy_p_new.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F
--- /dev/null
+#
+FC= ftn
+OPT = -fast \
+-Minline=name:scalar2,scalar,transpose2,matvec2,prodmat3 \
+-Mprefetch=distance:8,nta
+
+#OPT = -C -g
+#OPT1 = -g -fast
+OPT1 = ${OPT}
+OPT2 = -fast
+OPT2 = ${OPT}
+OPTE = ${OPT}
+
+FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include
+FFLAGS1 = -c ${OPT1} -I$(INSTALL_DIR)/include
+FFLAGS2 = -c ${OPT2} -I$(INSTALL_DIR)/include
+FFLAGSE = ${FFLAGS}
+
+CFLAGS = -DSGI -c
+
+BIN = ../bin/unres_MD_Tc_procor-newmat-novec-noparint_barrier_corr-split.exe
+LIBS = xdrf/libxdrf.a
+
+CPPFLAGS = -DLINUX -DUNRES -DMP -DMPI -DPGI \
+ -DSPLITELE -DPROCOR -DAMD64 -DLANG0 \
+#-DTIMING \
+# -DCRYST_BOND -DCRYST_THETA -DCRYST_SC
+#-DPARVEC #-DPARINT -DPARINTDER
+
+ARCH = LINUX
+PP = /lib/cpp -P
+
+
+all: unres
+
+.SUFFIXES: .F
+.F.o:
+ ${FC} ${FFLAGS} ${CPPFLAGS} $*.F
+
+
+object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \
+ matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \
+ pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \
+ cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \
+ energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \
+ cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \
+ mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \
+ eigen.o blas.o add.o entmcm.o minim_mcmf.o \
+ together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \
+ indexx.o MP.o compare_s1.o prng.o \
+ test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \
+ sc_move.o local_move.o \
+ intcartderiv.o lagrangian_lesyng.o\
+ stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \
+ surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \
+ q_measure.o gnmr1.o
+
+unres: ${object} proc_proc.o
+ cc -o compinfo compinfo.c
+ ./compinfo | true
+ ${FC} ${FFLAGS} cinfo.f
+ ${FC} ${OPT} ${object} proc_proc.o cinfo.o ${LIBS} -o ${BIN}
+
+
+clean:
+ /bin/rm *.o
+
+newconf.o: newconf.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f
+
+bank.o: bank.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} bank.F
+
+diff12.o: diff12.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f
+
+csa.o: csa.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} csa.f
+
+shift.o: shift.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} shift.F
+
+ran.o: ran.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} ran.f
+
+together.o: together.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} together.F
+
+test.o: test.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} test.F
+
+chainbuild.o: chainbuild.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F
+
+matmult.o: matmult.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f
+
+parmread.o : parmread.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F
+
+intcor.o : intcor.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f
+
+cartder.o : cartder.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F
+
+readpdb.o : readpdb.f
+ ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.f
+
+sumsld.o : sumsld.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f
+
+cored.o : cored.f
+ ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f
+
+rmdd.o : rmdd.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f
+
+energy_p_new.o : energy_p_new.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F
+
+energy_p_new-sep.o : energy_p_new-sep.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep.F
+
+lagrangian_lesyng.o : lagrangian_lesyng.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F
+
+blas.o : blas.f
+ ${FC} ${FFLAGS1} blas.f
+
+add.o : add.f
+ ${FC} ${FFLAGS1} add.f
+
+eigen.o : eigen.f
+ ${FC} ${FFLAGS1} eigen.f
+
+proc_proc.o: proc_proc.c
+ ${CC} ${CFLAGS} proc_proc.c
--- /dev/null
+#
+FC= ftn
+OPT = -fast \
+-Minline=name:scalar2,scalar,transpose2,matvec2,prodmat3 \
+-Mprefetch=distance:8,nta
+
+#OPT = -C -g
+#OPT1 = -g -fast
+OPT1 = -fast
+OPT2 = -fast
+OPT2 = ${OPT}
+OPTE = ${OPT}
+
+FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include
+FFLAGS1 = -c ${OPT1} -I$(INSTALL_DIR)/include
+FFLAGS2 = -c ${OPT2} -I$(INSTALL_DIR)/include
+FFLAGSE = ${FFLAGS}
+
+CFLAGS = -DSGI -c
+
+BIN = ../bin/unres_MD_Tc_procor-newmat-matgather-oldparm.exe
+LIBS = xdrf/libxdrf.a
+
+CPPFLAGS = -DLINUX -DUNRES -DMP -DMPI -DPGI \
+ -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -DPARVEC -DPARINT -DPARINTDER \
+ -DCRYST_BOND -DCRYST_THETA -DCRYST_SC
+
+ARCH = LINUX
+PP = /lib/cpp -P
+
+
+all: unres
+
+.SUFFIXES: .F
+.F.o:
+ ${FC} ${FFLAGS} ${CPPFLAGS} $*.F
+
+
+object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \
+ matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \
+ pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \
+ cartder.o checkder_p.o econstr_local.o energy_p_new.o \
+ energy_p_new-sep.o gradient_p.o minimize_p.o sumsld.o \
+ cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \
+ mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \
+ eigen.o blas.o add.o entmcm.o minim_mcmf.o \
+ together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \
+ indexx.o MP.o compare_s1.o prng.o \
+ test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \
+ sc_move.o local_move.o \
+ intcartderiv.o lagrangian_lesyng.o\
+ stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \
+ surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \
+ q_measure.o gnmr1.o
+
+unres: ${object} proc_proc.o
+ cc -o compinfo compinfo.c
+ ./compinfo | true
+ ${FC} ${FFLAGS} cinfo.f
+ ${FC} ${OPT} ${object} proc_proc.o cinfo.o ${LIBS} -o ${BIN}
+
+
+clean:
+ /bin/rm *.o
+
+newconf.o: newconf.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f
+
+bank.o: bank.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} bank.F
+
+diff12.o: diff12.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f
+
+csa.o: csa.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} csa.f
+
+shift.o: shift.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} shift.F
+
+ran.o: ran.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} ran.f
+
+together.o: together.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} together.F
+
+test.o: test.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} test.F
+
+chainbuild.o: chainbuild.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F
+
+matmult.o: matmult.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f
+
+parmread.o : parmread.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F
+
+intcor.o : intcor.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f
+
+cartder.o : cartder.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F
+
+readpdb.o : readpdb.f
+ ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.f
+
+sumsld.o : sumsld.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f
+
+cored.o : cored.f
+ ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f
+
+rmdd.o : rmdd.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f
+
+energy_p_new.o : energy_p_new.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F
+
+energy_p_new-sep.o : energy_p_new-sep.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep.F
+
+lagrangian_lesyng.o : lagrangian_lesyng.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F
+
+blas.o : blas.f
+ ${FC} ${FFLAGS1} blas.f
+
+add.o : add.f
+ ${FC} ${FFLAGS1} add.f
+
+eigen.o : eigen.f
+ ${FC} ${FFLAGS1} eigen.f
+
+proc_proc.o: proc_proc.c
+ ${CC} ${CFLAGS} proc_proc.c
--- /dev/null
+#
+#FC= ftn
+TAU_MAKEFILE=/usr/local/packages/TAU-2.17/tau-2.17/xt3/lib/Makefile.tau-mpi-pdt-pgi
+FC=tau_f90.sh
+OPT = -fast \
+-Minline=name:scalar2,scalar,transpose2,matvec2,prodmat3 \
+-Mprefetch=distance:8,nta
+
+#OPT = -C -g
+#OPT1 = -g -fast
+OPT1 = -fast
+OPT2 = -fast
+OPT2 = ${OPT}
+OPTE = ${OPT}
+
+FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include
+FFLAGS1 = -c ${OPT1} -I$(INSTALL_DIR)/include
+FFLAGS2 = -c ${OPT2} -I$(INSTALL_DIR)/include
+FFLAGSE = ${FFLAGS}
+
+CFLAGS = -DSGI -c
+
+BIN = ../bin/unres_MD_Tc_procor-newmat-noparint-barrier-tau.exe
+LIBS = xdrf/libxdrf.a
+
+CPPFLAGS = -DLINUX -DUNRES -DMP -DMPI -DPGI \
+ -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -DPARVEC
+
+ARCH = LINUX
+PP = /lib/cpp -P
+
+
+all: unres
+
+.SUFFIXES: .F
+.F.o:
+ ${FC} ${FFLAGS} ${CPPFLAGS} $*.F
+
+
+object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \
+ matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \
+ pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \
+ cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \
+ energy_p_new-sep.o gradient_p.o minimize_p.o sumsld.o \
+ cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \
+ mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \
+ eigen.o blas.o add.o entmcm.o minim_mcmf.o \
+ together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \
+ indexx.o MP.o compare_s1.o prng.o \
+ test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \
+ sc_move.o local_move.o \
+ intcartderiv.o lagrangian_lesyng.o\
+ stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \
+ surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \
+ q_measure.o gnmr1.o
+
+unres: ${object} proc_proc.o
+ cc -o compinfo compinfo.c
+ ./compinfo | true
+ ${FC} ${FFLAGS} cinfo.f
+ ${FC} ${OPT} ${object} proc_proc.o cinfo.o ${LIBS} -o ${BIN}
+
+
+clean:
+ /bin/rm *.o *.pp.[fF] *.pp.inst.[fF]
+
+newconf.o: newconf.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f
+
+bank.o: bank.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} bank.F
+
+diff12.o: diff12.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f
+
+csa.o: csa.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} csa.f
+
+shift.o: shift.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} shift.F
+
+ran.o: ran.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} ran.f
+
+together.o: together.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} together.F
+
+test.o: test.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} test.F
+
+chainbuild.o: chainbuild.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F
+
+matmult.o: matmult.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f
+
+parmread.o : parmread.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F
+
+intcor.o : intcor.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f
+
+cartder.o : cartder.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F
+
+readpdb.o : readpdb.f
+ ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.f
+
+sumsld.o : sumsld.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f
+
+cored.o : cored.f
+ ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f
+
+rmdd.o : rmdd.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f
+
+energy_p_new.o : energy_p_new.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F
+
+energy_p_new-sep.o : energy_p_new-sep.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep.F
+
+lagrangian_lesyng.o : lagrangian_lesyng.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F
+
+blas.o : blas.f
+ ${FC} ${FFLAGS1} blas.f
+
+add.o : add.f
+ ${FC} ${FFLAGS1} add.f
+
+eigen.o : eigen.f
+ ${FC} ${FFLAGS1} eigen.f
+
+proc_proc.o: proc_proc.c
+ ${CC} ${CFLAGS} proc_proc.c
--- /dev/null
+CPPFLAGS = -DPROCOR -DLINUX -DUNRES -DMP -DMPI -DPGI -DISNAN \
+ -DSPLITELE -DAMD64 -DLANG0
+# -DCRYST_BOND -DCRYST_THETA -DCRYST_SC
+#-DCRYST_TOR
+# -DPROCOR
+# -DTSCSC
+#-DTIMING \
+# -DCRYST_BOND -DCRYST_THETA -DCRYST_SC
+# -DMOMENT
+#-DPARVEC
+#-DPARINT -DPARINTDER
+
+#INSTALL_DIR = /users/local/mpi64/mpich-1.2.7p1/
+#INSTALL_DIR = /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh
+#INSTALL_DIR = /users/software/mpich2.x86_64/
+#INSTALL_DIR = /opt/mpi/mvapich2
+INSTALL_DIR = /opt/mpi/mvapich
+
+FC= ifort
+FCL= ${INSTALL_DIR}/bin/mpif77
+
+OPT = -O3 -ip -w -xHost
+
+FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include
+FFLAGS1 = -c -w -g -d2 -CA -CB -I$(INSTALL_DIR)/include
+FFLAGS2 = -c -w -g -O0 -I$(INSTALL_DIR)/include
+FFLAGSE = -c -w -xHost -O3 -ipo -ipo_obj -no-prec-div -opt_report -I$(INSTALL_DIR)/include
+
+
+BIN = ../bin/unres_Tc_procor_new_em64_hremd_mpich1.exe
+LIBS = -L$(INSTALL_DIR)/lib -lmpich xdrf_em64/libxdrf.a -lpthread
+
+ARCH = LINUX
+PP = /lib/cpp -P
+
+
+all: unres
+
+.SUFFIXES: .F
+.F.o:
+ ${FC} ${FFLAGS} ${CPPFLAGS} $*.F
+
+
+object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \
+ matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \
+ pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \
+ cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \
+ energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \
+ cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \
+ mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \
+ eigen.o blas.o add.o entmcm.o minim_mcmf.o \
+ together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \
+ indexx.o MP.o compare_s1.o prng_32.o \
+ test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \
+ sc_move.o local_move.o \
+ intcartderiv.o lagrangian_lesyng.o\
+ stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \
+ surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \
+ q_measure.o gnmr1.o
+
+unres: ${object}
+ cc -o compinfo compinfo.c
+ ./compinfo | true
+ ${FC} ${FFLAGS} cinfo.f
+ ${FCL} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN}
+
+
+clean:
+ /bin/rm *.o *.il
+
+newconf.o: newconf.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f
+
+bank.o: bank.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} bank.F
+
+diff12.o: diff12.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f
+
+csa.o: csa.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} csa.f
+
+shift.o: shift.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} shift.F
+
+ran.o: ran.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} ran.f
+
+together.o: together.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} together.F
+
+test.o: test.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} test.F
+
+chainbuild.o: chainbuild.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F
+
+matmult.o: matmult.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f
+
+parmread.o : parmread.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F
+
+intcor.o : intcor.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f
+
+cartder.o : cartder.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F
+
+readpdb.o : readpdb.F
+ ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.F
+
+sumsld.o : sumsld.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f
+
+cored.o : cored.f
+ ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f
+
+rmdd.o : rmdd.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f
+
+energy_p_new_barrier.o : energy_p_new_barrier.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new_barrier.F
+
+gradient_p.o : gradient_p.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} gradient_p.F
+
+energy_p_new-sep_barrier.o : energy_p_new-sep_barrier.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep_barrier.F
+
+lagrangian_lesyng.o : lagrangian_lesyng.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F
+
+MD_A-MTS.o : MD_A-MTS.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} MD_A-MTS.F
+
+blas.o : blas.f
+ ${FC} ${FFLAGS1} blas.f
+
+add.o : add.f
+ ${FC} ${FFLAGS1} add.f
+
+eigen.o : eigen.f
+ ${FC} ${FFLAGS2} eigen.f
+
+proc_proc.o: proc_proc.c
+ ${CC} ${CFLAGS} proc_proc.c
--- /dev/null
+#
+FC=/bgsys/drivers/ppcfloor/comm/bin/mpixlf77
+OPT = -O4 -qarch=450 -qtune=450
+#OPT = -O3 -qarch=450 -qtune=450 -qdebug=function_trace
+#OPT = -O -qarch=450 -qtune=450
+#OPT = -O0 -C -g -qarch=450 -qtune=450 #-qdebug=function_trace
+#-Minline=name:scalar2,scalar,transpose2,matvec2,prodmat3 \
+#-Mprefetch=distance:8,nta
+
+#OPT1 = -O -g -qarch=450 -qtune=450
+#OPT1 = -O -g -qarch=450 -qtune=450 -qdebug=function_trace
+OPT1 = ${OPT}
+#OPT2 = -O2 -qarch=450 -qtune=450
+#OPT2 = -O2 -qarch=450 -qtune=450 -qdebug=function_trace
+OPT2 = ${OPT}
+#OPTE = -O4 -qarch=450 -qtune=450
+#OPTE = -O4 -qarch=450 -qtune=450
+OPTE=${OPT}
+
+CFLAGS = -c
+FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include
+FFLAGS1 = -c ${OPT1} -I$(INSTALL_DIR)/include
+FFLAGS2 = -c ${OPT2} -I$(INSTALL_DIR)/include
+FFLAGSE = -c ${OPTE} -I$(INSTALL_DIR)/include
+
+BIN = ../bin/unres_MD_Tc_procor-newparm-O4-parcorr.exe
+#BIN = ../bin/unres_MD_Tc_procor-newparm-O4-PARINT-parcorr.exe
+#BIN = ../bin/unres_MD_Tc_procor-newparm-parvecmatint-O4-notau1.exe
+#BIN = ../bin/unres_MD_Tc_procor-newparm-O4-notau1.exe
+#LIBS = xdrf/libxdrf.a /home/liwo/UNRES/LIB/libmemmon.a
+LIBS = xdrf/libxdrf.a
+
+CPPFLAGS = -WF,-DAIX -WF,-DISNAN -WF,-DUNRES -WF,-DMP -WF,-DMPI -WF,-DPGI \
+ -WF,-DSPLITELE -WF,-DPROCOR -WF,-DAMD64 -WF,-DLANG0
+#-WF,-DPARINT -WF,-DPARINTDER
+#-WF,-DPARVEC -WF,-DPARMAT -WF,-DMATGATHER
+
+ARCH = LINUX
+PP = /lib/cpp -P
+
+
+all: unres
+
+obj: ${object}
+
+.SUFFIXES: .F
+.F.o:
+ ${FC} ${FFLAGS} ${CPPFLAGS} $*.F
+
+
+object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \
+ matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \
+ pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \
+ cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \
+ energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \
+ cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \
+ mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \
+ eigen.o blas.o add.o entmcm.o minim_mcmf.o \
+ together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \
+ indexx.o MP.o compare_s1.o prng.o \
+ test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \
+ sc_move.o local_move.o \
+ intcartderiv.o lagrangian_lesyng.o\
+ stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \
+ surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \
+ q_measure.o gnmr1.o
+
+unres: ${object}
+ ${CC} -o compinfo compinfo.c
+ ./compinfo | true
+ ${FC} ${FFLAGS} cinfo.f
+ ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN}
+
+
+clean:
+ /bin/rm *.o
+
+newconf.o: newconf.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f
+
+bank.o: bank.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} bank.F
+
+diff12.o: diff12.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f
+
+csa.o: csa.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} csa.f
+
+shift.o: shift.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} shift.F
+
+ran.o: ran.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} ran.f
+
+together.o: together.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} together.F
+
+test.o: test.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} test.F
+
+chainbuild.o: chainbuild.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F
+
+matmult.o: matmult.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f
+
+parmread.o : parmread.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F
+
+intcor.o : intcor.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f
+
+cartder.o : cartder.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F
+
+readpdb.o : readpdb.f
+ ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.f
+
+sumsld.o : sumsld.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f
+
+cored.o : cored.f
+ ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f
+
+rmdd.o : rmdd.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f
+
+eigen.o : eigen.f
+ ${FC} ${FFLAGS1} ${CPPFLAGS} eigen.f
+
+blas.o : blas.f
+ ${FC} ${FFLAGS1} ${CPPFLAGS} blas.f
+
+add.o : add.f
+ ${FC} ${FFLAGS1} ${CPPFLAGS} add.f
+
+energy_p_new.o : energy_p_new.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F
+
+energy_p_new-sep.o : energy_p_new-sep.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep.F
+
+lagrangian_lesyng.o : lagrangian_lesyng.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F
+
+proc_proc.o: proc_proc.c
+ ${CC} ${CFLAGS} proc_proc.c
+
+compinfo: compinfo.c
+ ${CC} ${CFLAGS} compinfo.c
--- /dev/null
+CPPFLAGS = -DPROCOR -DLINUX -DUNRES -DMP -DMPI -DPGI -DISNAN \
+ -DSPLITELE -DAMD64 -DLANG0
+# -DCRYST_BOND -DCRYST_THETA -DCRYST_SC
+#-DCRYST_TOR
+# -DPROCOR
+# -DTSCSC
+#-DTIMING \
+# -DCRYST_BOND -DCRYST_THETA -DCRYST_SC
+# -DMOMENT
+#-DPARVEC
+#-DPARINT -DPARINTDER
+
+INSTALL_DIR = /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh
+
+
+FC= ifort
+
+OPT = -O3 -ip -w
+
+FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include
+FFLAGS1 = -c -w -g -d2 -CA -CB -I$(INSTALL_DIR)/include
+FFLAGS2 = -c -w -g -O0 -I$(INSTALL_DIR)/include
+FFLAGSE = -c -w -O3 -ipo -ipo_obj -opt_report -I$(INSTALL_DIR)/include
+
+
+BIN = ../bin/unres_Tc_procor_new_em64_nh_hremd_92110.exe
+LIBS = -L$(INSTALL_DIR)/lib -lmpich xdrf_em64/libxdrf.a -lpthread
+
+ARCH = LINUX
+PP = /lib/cpp -P
+
+
+all: unres
+
+.SUFFIXES: .F
+.F.o:
+ ${FC} ${FFLAGS} ${CPPFLAGS} $*.F
+
+
+object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \
+ matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \
+ pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \
+ cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \
+ energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \
+ cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \
+ mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \
+ eigen.o blas.o add.o entmcm.o minim_mcmf.o \
+ together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \
+ indexx.o MP.o compare_s1.o prng_32.o \
+ test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \
+ sc_move.o local_move.o \
+ intcartderiv.o lagrangian_lesyng.o\
+ stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \
+ surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \
+ q_measure.o gnmr1.o
+
+unres: ${object}
+ cc -o compinfo compinfo.c
+ ./compinfo | true
+ ${FC} ${FFLAGS} cinfo.f
+ ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN}
+
+
+clean:
+ /bin/rm *.o *.il
+
+newconf.o: newconf.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f
+
+bank.o: bank.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} bank.F
+
+diff12.o: diff12.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f
+
+csa.o: csa.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} csa.f
+
+shift.o: shift.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} shift.F
+
+ran.o: ran.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} ran.f
+
+together.o: together.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} together.F
+
+test.o: test.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} test.F
+
+chainbuild.o: chainbuild.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F
+
+matmult.o: matmult.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f
+
+parmread.o : parmread.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F
+
+intcor.o : intcor.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f
+
+cartder.o : cartder.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F
+
+readpdb.o : readpdb.F
+ ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.F
+
+sumsld.o : sumsld.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f
+
+cored.o : cored.f
+ ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f
+
+rmdd.o : rmdd.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f
+
+energy_p_new_barrier.o : energy_p_new_barrier.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new_barrier.F
+
+gradient_p.o : gradient_p.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} gradient_p.F
+
+energy_p_new-sep_barrier.o : energy_p_new-sep_barrier.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep_barrier.F
+
+lagrangian_lesyng.o : lagrangian_lesyng.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F
+
+MD_A-MTS.o : MD_A-MTS.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} MD_A-MTS.F
+
+blas.o : blas.f
+ ${FC} ${FFLAGS1} blas.f
+
+add.o : add.f
+ ${FC} ${FFLAGS1} add.f
+
+eigen.o : eigen.f
+ ${FC} ${FFLAGS2} eigen.f
+
+proc_proc.o: proc_proc.c
+ ${CC} ${CFLAGS} proc_proc.c
--- /dev/null
+CPPFLAGS = -DPROCOR -DLINUX -DUNRES -DMP -DMPI -DPGI -DISNAN \
+ -DSPLITELE -DAMD64 -DLANG0 \
+ -DCRYST_BOND -DCRYST_THETA -DCRYST_SC
+#-DCRYST_TOR
+# -DPROCOR
+# -DTSCSC
+#-DTIMING \
+# -DCRYST_BOND -DCRYST_THETA -DCRYST_SC
+# -DMOMENT
+#-DPARVEC
+#-DPARINT -DPARINTDER
+
+INSTALL_DIR = /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh
+
+
+FC= ifort
+
+OPT = -O3 -ip -w
+
+FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include
+FFLAGS1 = -c -w -g -d2 -CA -CB -I$(INSTALL_DIR)/include
+FFLAGS2 = -c -w -g -O0 -I$(INSTALL_DIR)/include
+FFLAGSE = -c -w -O3 -ipo -ipo_obj -opt_report -I$(INSTALL_DIR)/include
+
+
+BIN = ../bin/unres_Tc_procor_old_em64_nh_hremd_92110.exe
+LIBS = -L$(INSTALL_DIR)/lib -lmpich xdrf_em64/libxdrf.a -lpthread
+
+ARCH = LINUX
+PP = /lib/cpp -P
+
+
+all: unres
+
+.SUFFIXES: .F
+.F.o:
+ ${FC} ${FFLAGS} ${CPPFLAGS} $*.F
+
+
+object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \
+ matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \
+ pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \
+ cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \
+ energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \
+ cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \
+ mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \
+ eigen.o blas.o add.o entmcm.o minim_mcmf.o \
+ together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \
+ indexx.o MP.o compare_s1.o prng_32.o \
+ test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \
+ sc_move.o local_move.o \
+ intcartderiv.o lagrangian_lesyng.o\
+ stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \
+ surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \
+ q_measure.o gnmr1.o
+
+unres: ${object}
+ cc -o compinfo compinfo.c
+ ./compinfo | true
+ ${FC} ${FFLAGS} cinfo.f
+ ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN}
+
+
+clean:
+ /bin/rm *.o *.il
+
+newconf.o: newconf.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f
+
+bank.o: bank.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} bank.F
+
+diff12.o: diff12.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f
+
+csa.o: csa.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} csa.f
+
+shift.o: shift.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} shift.F
+
+ran.o: ran.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} ran.f
+
+together.o: together.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} together.F
+
+test.o: test.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} test.F
+
+chainbuild.o: chainbuild.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F
+
+matmult.o: matmult.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f
+
+parmread.o : parmread.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F
+
+intcor.o : intcor.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f
+
+cartder.o : cartder.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F
+
+readpdb.o : readpdb.F
+ ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.F
+
+sumsld.o : sumsld.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f
+
+cored.o : cored.f
+ ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f
+
+rmdd.o : rmdd.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f
+
+energy_p_new_barrier.o : energy_p_new_barrier.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new_barrier.F
+
+gradient_p.o : gradient_p.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} gradient_p.F
+
+energy_p_new-sep_barrier.o : energy_p_new-sep_barrier.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep_barrier.F
+
+lagrangian_lesyng.o : lagrangian_lesyng.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F
+
+MD_A-MTS.o : MD_A-MTS.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} MD_A-MTS.F
+
+blas.o : blas.f
+ ${FC} ${FFLAGS1} blas.f
+
+add.o : add.f
+ ${FC} ${FFLAGS1} add.f
+
+eigen.o : eigen.f
+ ${FC} ${FFLAGS2} eigen.f
+
+proc_proc.o: proc_proc.c
+ ${CC} ${CFLAGS} proc_proc.c
--- /dev/null
+FC= gfortran
+FFLAGS = -c ${OPT} -I.
+FFLAGS1 = -c ${OPT1} -I.
+
+CC = cc
+
+CFLAGS = -DLINUX -DPGI -c
+
+OPT = -O
+#OPT1 = -fbounds-check -g -O
+
+#OPT = -fbounds-check -g
+OPT1 = -g
+
+# -Mvect <---slows down
+# -Minline=name:matmat2 <---false convergence
+
+LIBS = -Lxdrf -lxdrf
+#-DMOMENT
+#-DCO_BIAS
+#-DCRYST_TOR
+#-DDEBUG
+
+ARCH = LINUX
+PP = /lib/cpp -P
+
+all:
+ @echo "Specify force field: GAB or E0LL2Y"
+
+.SUFFIXES: .F
+.F.o:
+ ${FC} ${FFLAGS} ${CPPFLAGS} $*.F
+
+object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \
+ matmult.o readrtns.o parmread.o gen_rand_conf.o printmat.o map.o \
+ pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \
+ cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \
+ energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \
+ cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \
+ mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \
+ eigen.o blas.o add.o entmcm.o minim_mcmf.o \
+ MP.o compare_s1.o prng_32.o \
+ banach.o rmsd.o elecont.o dihed_cons.o \
+ sc_move.o local_move.o \
+ intcartderiv.o lagrangian_lesyng.o\
+ stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \
+ surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \
+ q_measure.o gnmr1.o test.o
+
+GAB: CPPFLAGS = -DPROCOR -DLINUX -DUNRES -DISNAN \
+ -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC
+GAB: BIN = ../../../bin/unres/MD/unres_gfortran_single_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}
+
+E0LL2Y: CPPFLAGS = -DPROCOR -DLINUX -DUNRES -DISNAN \
+ -DSPLITELE -DLANG0
+E0LL2Y: BIN = ../../../bin/unres/MD/unres_gfortran_single_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}
+
+xdrf/libxdrf.a:
+ cd xdrf && make
+
+clean:
+ /bin/rm -f *.o && /bin/rm -f compinfo && cd xdrf && make clean
+
+newconf.o: newconf.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} newconf.F
+
+bank.o: bank.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} bank.F
+
+diff12.o: diff12.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f
+
+csa.o: csa.f
+ ${FC} ${FFLAGS1} ${CPPFLAGS} csa.f
+
+shift.o: shift.F
+ ${FC} ${FFLAGS1} ${CPPFLAGS} shift.F
+
+ran.o: ran.f
+ ${FC} ${FFLAGS1} ${CPPFLAGS} ran.f
+
+together.o: together.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} together.F
+
+fitsq.o: fitsq.f
+ ${FC} ${FFLAGS1} ${CPPFLAGS} fitsq.f
+
+rmsd.o: rmsd.F
+ ${FC} ${FFLAGS1} ${CPPFLAGS} rmsd.F
+
+contact.o: contact.f
+ ${FC} ${FFLAGS1} ${CPPFLAGS} contact.f
+
+minim_jlee.o: minim_jlee.F
+ ${FC} ${FFLAGS1} ${CPPFLAGS} minim_jlee.F
+
+minimize_p.o: minimize_p.F
+ ${FC} ${FFLAGS1} ${CPPFLAGS} minimize_p.F
+
+gen_rand_conf.o: gen_rand_conf.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} gen_rand_conf.F
+
+
+test.o: test.F
+ ${FC} ${FFLAGS1} ${CPPFLAGS} test.F
+
+elecont.o: elecont.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} elecont.f
+
+eigen.o: eigen.f
+ ${FC} ${FFLAGS1} eigen.f
+
+blas.o: blas.f
+ ${FC} ${FFLAGS1} blas.f
+
+add.o: add.f
+ ${FC} ${FFLAGS1} add.f
+
+proc_proc.o: proc_proc.c
+ ${CC} ${CFLAGS} proc_proc.c
--- /dev/null
+FC = ifort
+FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include
+FFLAGS1 = -c -w -g -d2 -CA -CB -I$(INSTALL_DIR)/include
+FFLAGS2 = -c -w -g -O0 -I$(INSTALL_DIR)/include
+FFLAGSE = -c -w -O3 -ipo -ipo_obj -opt_report -I$(INSTALL_DIR)/include
+
+CC = cc
+
+CFLAGS = -DLINUX -DPGI -c
+
+OPT = -O3 -ip -w
+
+# -Mvect <---slows down
+# -Minline=name:matmat2 <---false convergence
+
+LIBS = -Lxdrf -lxdrf
+#-DMOMENT
+#-DCO_BIAS
+#-DCRYST_TOR
+#-DDEBUG
+
+ARCH = LINUX
+PP = /lib/cpp -P
+
+all:
+ @echo "Specify force field: GAB or E0LL2Y"
+
+.SUFFIXES: .F
+.F.o:
+ ${FC} ${FFLAGS} ${CPPFLAGS} $*.F
+
+object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \
+ matmult.o readrtns.o parmread.o gen_rand_conf.o printmat.o map.o \
+ pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \
+ cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \
+ energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \
+ cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \
+ mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \
+ eigen.o blas.o add.o entmcm.o minim_mcmf.o \
+ MP.o compare_s1.o prng_32.o \
+ banach.o rmsd.o elecont.o dihed_cons.o \
+ sc_move.o local_move.o \
+ intcartderiv.o lagrangian_lesyng.o\
+ stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \
+ surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \
+ q_measure.o gnmr1.o test.o
+
+GAB: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DUNRES -DISNAN \
+ -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC
+GAB: BIN = ../../../bin/unres/MD/unres_ifort_single_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}
+
+E0LL2Y: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DUNRES -DISNAN \
+ -DSPLITELE -DLANG0
+E0LL2Y: BIN = ../../../bin/unres/MD/unres_ifort_single_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}
+
+xdrf/libxdrf.a:
+ cd xdrf && make
+
+clean:
+ /bin/rm -f *.o && /bin/rm -f compinfo && cd xdrf && make clean
+
+test.o: test.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} test.F
+
+chainbuild.o: chainbuild.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F
+
+matmult.o: matmult.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f
+
+parmread.o : parmread.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F
+
+intcor.o : intcor.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f
+
+cartder.o : cartder.F
+ ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F
+
+readpdb.o : readpdb.F
+ ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.F
+
+sumsld.o : sumsld.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f
+
+cored.o : cored.f
+ ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f
+
+rmdd.o : rmdd.f
+ ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f
+
+energy_p_new_barrier.o : energy_p_new_barrier.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new_barrier.F
+
+gradient_p.o : gradient_p.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} gradient_p.F
+
+energy_p_new-sep_barrier.o : energy_p_new-sep_barrier.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep_barrier.F
+
+lagrangian_lesyng.o : lagrangian_lesyng.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F
+
+MD_A-MTS.o : MD_A-MTS.F
+ ${FC} ${FFLAGSE} ${CPPFLAGS} MD_A-MTS.F
+
+blas.o : blas.f
+ ${FC} ${FFLAGS1} blas.f
+
+add.o : add.f
+ ${FC} ${FFLAGS1} add.f
+
+eigen.o : eigen.f
+ ${FC} ${FFLAGS2} eigen.f
+
+proc_proc.o: proc_proc.c
+ ${CC} ${CFLAGS} proc_proc.c
--- /dev/null
+The program will fail if there is no "Makefile" file.\r
+You must copy (cp MakeXXXX Makefile) or use a symbolic link (ln -s MakeXXXX Makefile) before compiling.\r
--- /dev/null
+ SUBROUTINE ABRT
+ STOP 'IN ABRT'
+ END
+C*MODULE MTHLIB *DECK VCLR
+ SUBROUTINE VCLR(A,INCA,N)
+C
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+C
+ DIMENSION A(*)
+C
+ PARAMETER (ZERO=0.0D+00)
+C
+C ----- ZERO OUT VECTOR -A-, USING INCREMENT -INCA- -----
+C
+ IF (INCA .NE. 1) GO TO 200
+ DO 110 L=1,N
+ A(L) = ZERO
+ 110 CONTINUE
+ RETURN
+C
+ 200 CONTINUE
+ LA=1-INCA
+ DO 210 L=1,N
+ LA=LA+INCA
+ A(LA) = ZERO
+ 210 CONTINUE
+ RETURN
+ END
--- /dev/null
+ FUNCTION ARCOS(X)
+ implicit real*8 (a-h,o-z)
+ include 'COMMON.GEO'
+ IF (DABS(X).LT.1.0D0) GOTO 1
+ ARCOS=0.5D0*(PI+DSIGN(1.0D0,X)*PI)
+ RETURN
+ 1 ARCOS=DACOS(X)
+ RETURN
+ END
--- /dev/null
+C
+C**********************
+ SUBROUTINE BANACH(N,NMAX,A,X,osob)
+C**********************
+C Banachiewicz
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ DIMENSION A(NMAX,NMAX),X(NMAX),D(MAXRES6)
+ COMMON /BANII/ D
+ logical osob
+ osob=.false.
+ if (dabs(a(1,1)).lt.1.0d-15) then
+ osob=.true.
+ return
+ endif
+ D(1)=1./A(1,1)
+ DO 80 I=2,N
+ A(I,1)=A(1,I)
+ DO 81 J=2,I-1
+ XX=A(J,I)
+ DO 82 K=1,J-1
+ XX=XX-A(I,K)*A(J,K)
+ 82 CONTINUE
+ A(I,J)=XX
+ 81 CONTINUE
+ XX=A(I,I)
+ JJJJ=I-1
+ DO 83 J=1,JJJJ
+ AIJ=A(I,J)
+ AIJD=AIJ*D(J)
+ A(I,J)=AIJD
+ XX=XX-AIJ*AIJD
+ 83 CONTINUE
+ if (dabs(xx).lt.1.0d-15) then
+ osob=.true.
+ return
+ endif
+ D(I)=1./XX
+ 80 CONTINUE
+C
+ CALL BANAII(N,NMAX,A,X)
+ RETURN
+ END
+C************************
+ SUBROUTINE BANAII(N,NMAX,A,X)
+C************************
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ DIMENSION A(NMAX,NMAX),X(NMAX),D(MAXRES6)
+ COMMON /BANII/ D
+ DO 90 I=1,N
+ Z=X(I)
+ JJJJ=I-1
+ DO 91 J=JJJJ,1,-1
+ Z=Z-A(I,J)*X(J)
+ 91 CONTINUE
+ X(I)=Z
+ 90 CONTINUE
+ DO 92 I=N,1,-1
+ Z=X(I)*D(I)
+ JJJJ=I+1
+ DO 93 J=JJJJ,N
+ Z=Z-A(J,I)*X(J)
+ 93 CONTINUE
+ X(I)=Z
+ 92 CONTINUE
+ RETURN
+ END
+C
+ SUBROUTINE MATINVERT(N,NMAX,A,A1,osob)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ DIMENSION A(NMAX,NMAX),A1(NMAX,NMAX),D(MAXRES6)
+ COMMON /BANII/ D
+ DIMENSION X(NMAX)
+ logical osob
+ DO I=1,N
+ X(I)=0.0
+ ENDDO
+ X(1)=1.0
+ CALL BANACH(N,NMAX,A,X,osob)
+ if (osob) return
+ DO I=1,N
+ A1(I,1)=X(I)
+ ENDDO
+ DO I=2,N
+ DO J=1,N
+ X(J)=0.0
+ ENDDO
+ X(I)=1.0
+ CALL BANAII(N,NMAX,A,X)
+ DO J=1,N
+ A1(J,I)=X(J)
+ ENDDO
+ ENDDO
+ RETURN
+ END
+
+
--- /dev/null
+C 10 NOV 94 - MWS - DNRM2: REMOVE FTNCHECK WARNINGS
+C 11 JUN 94 - MWS - INCLUDE A COPY OF DGEMV (LEVEL TWO ROUTINE)
+C 11 AUG 87 - MWS - SANITIZE FLOATING POINT CONSTANTS IN DNRM2
+C 26 MAR 87 - MWS - USE GENERIC SIGN IN DROTG
+C 28 NOV 86 - STE - SUPPLY ALL LEVEL ONE BLAS
+C 7 JUL 86 - JAB - SANITIZE FLOATING POINT CONSTANTS
+C
+C BASIC LINEAR ALGEBRA SUBPROGRAMS (BLAS) FROM LINPACK (LEVEL 1)
+C
+C THIS MODULE SHOULD BE COMPILED ONLY IF SPECIALLY CODED
+C VERSIONS OF THESE ROUTINES ARE NOT AVAILABLE ON THE TARGET MACHINE
+C
+C*MODULE BLAS1 *DECK DASUM
+ DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX)
+C
+C TAKES THE SUM OF THE ABSOLUTE VALUES.
+C JACK DONGARRA, LINPACK, 3/11/78.
+C
+ DOUBLE PRECISION DX(1),DTEMP
+ INTEGER I,INCX,M,MP1,N,NINCX
+C
+ DASUM = 0.0D+00
+ DTEMP = 0.0D+00
+ IF(N.LE.0)RETURN
+ IF(INCX.EQ.1)GO TO 20
+C
+C CODE FOR INCREMENT NOT EQUAL TO 1
+C
+ NINCX = N*INCX
+ DO 10 I = 1,NINCX,INCX
+ DTEMP = DTEMP + ABS(DX(I))
+ 10 CONTINUE
+ DASUM = DTEMP
+ RETURN
+C
+C CODE FOR INCREMENT EQUAL TO 1
+C
+C
+C CLEAN-UP LOOP
+C
+ 20 M = MOD(N,6)
+ IF( M .EQ. 0 ) GO TO 40
+ DO 30 I = 1,M
+ DTEMP = DTEMP + ABS(DX(I))
+ 30 CONTINUE
+ IF( N .LT. 6 ) GO TO 60
+ 40 MP1 = M + 1
+ DO 50 I = MP1,N,6
+ DTEMP = DTEMP + ABS(DX(I)) + ABS(DX(I + 1)) + ABS(DX(I + 2))
+ * + ABS(DX(I + 3)) + ABS(DX(I + 4)) + ABS(DX(I + 5))
+ 50 CONTINUE
+ 60 DASUM = DTEMP
+ RETURN
+ END
+C*MODULE BLAS1 *DECK DAXPY
+ SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY)
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ DIMENSION DX(1),DY(1)
+C
+C CONSTANT TIMES A VECTOR PLUS A VECTOR.
+C DY(I) = DY(I) + DA * DX(I)
+C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE.
+C JACK DONGARRA, LINPACK, 3/11/78.
+C
+ IF(N.LE.0)RETURN
+ IF (DA .EQ. 0.0D+00) RETURN
+ IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
+C
+C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
+C NOT EQUAL TO 1
+C
+ IX = 1
+ IY = 1
+ IF(INCX.LT.0)IX = (-N+1)*INCX + 1
+ IF(INCY.LT.0)IY = (-N+1)*INCY + 1
+ DO 10 I = 1,N
+ DY(IY) = DY(IY) + DA*DX(IX)
+ IX = IX + INCX
+ IY = IY + INCY
+ 10 CONTINUE
+ RETURN
+C
+C CODE FOR BOTH INCREMENTS EQUAL TO 1
+C
+C
+C CLEAN-UP LOOP
+C
+ 20 M = MOD(N,4)
+ IF( M .EQ. 0 ) GO TO 40
+ DO 30 I = 1,M
+ DY(I) = DY(I) + DA*DX(I)
+ 30 CONTINUE
+ IF( N .LT. 4 ) RETURN
+ 40 MP1 = M + 1
+ DO 50 I = MP1,N,4
+ DY(I) = DY(I) + DA*DX(I)
+ DY(I + 1) = DY(I + 1) + DA*DX(I + 1)
+ DY(I + 2) = DY(I + 2) + DA*DX(I + 2)
+ DY(I + 3) = DY(I + 3) + DA*DX(I + 3)
+ 50 CONTINUE
+ RETURN
+ END
+C*MODULE BLAS1 *DECK DCOPY
+ SUBROUTINE DCOPY(N,DX,INCX,DY,INCY)
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ DIMENSION DX(*),DY(*)
+C
+C COPIES A VECTOR.
+C DY(I) <== DX(I)
+C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE.
+C JACK DONGARRA, LINPACK, 3/11/78.
+C
+ IF(N.LE.0)RETURN
+ IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
+C
+C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
+C NOT EQUAL TO 1
+C
+ IX = 1
+ IY = 1
+ IF(INCX.LT.0)IX = (-N+1)*INCX + 1
+ IF(INCY.LT.0)IY = (-N+1)*INCY + 1
+ DO 10 I = 1,N
+ DY(IY) = DX(IX)
+ IX = IX + INCX
+ IY = IY + INCY
+ 10 CONTINUE
+ RETURN
+C
+C CODE FOR BOTH INCREMENTS EQUAL TO 1
+C
+C
+C CLEAN-UP LOOP
+C
+ 20 M = MOD(N,7)
+ IF( M .EQ. 0 ) GO TO 40
+ DO 30 I = 1,M
+ DY(I) = DX(I)
+ 30 CONTINUE
+ IF( N .LT. 7 ) RETURN
+ 40 MP1 = M + 1
+ DO 50 I = MP1,N,7
+ DY(I) = DX(I)
+ DY(I + 1) = DX(I + 1)
+ DY(I + 2) = DX(I + 2)
+ DY(I + 3) = DX(I + 3)
+ DY(I + 4) = DX(I + 4)
+ DY(I + 5) = DX(I + 5)
+ DY(I + 6) = DX(I + 6)
+ 50 CONTINUE
+ RETURN
+ END
+C*MODULE BLAS1 *DECK DDOT
+ DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY)
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ DIMENSION DX(1),DY(1)
+C
+C FORMS THE DOT PRODUCT OF TWO VECTORS.
+C DOT = DX(I) * DY(I)
+C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE.
+C JACK DONGARRA, LINPACK, 3/11/78.
+C
+ DDOT = 0.0D+00
+ DTEMP = 0.0D+00
+ IF(N.LE.0)RETURN
+ IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
+C
+C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
+C NOT EQUAL TO 1
+C
+ IX = 1
+ IY = 1
+ IF(INCX.LT.0)IX = (-N+1)*INCX + 1
+ IF(INCY.LT.0)IY = (-N+1)*INCY + 1
+ DO 10 I = 1,N
+ DTEMP = DTEMP + DX(IX)*DY(IY)
+ IX = IX + INCX
+ IY = IY + INCY
+ 10 CONTINUE
+ DDOT = DTEMP
+ RETURN
+C
+C CODE FOR BOTH INCREMENTS EQUAL TO 1
+C
+C
+C CLEAN-UP LOOP
+C
+ 20 M = MOD(N,5)
+ IF( M .EQ. 0 ) GO TO 40
+ DO 30 I = 1,M
+ DTEMP = DTEMP + DX(I)*DY(I)
+ 30 CONTINUE
+ IF( N .LT. 5 ) GO TO 60
+ 40 MP1 = M + 1
+ DO 50 I = MP1,N,5
+ DTEMP = DTEMP + DX(I)*DY(I) + DX(I + 1)*DY(I + 1) +
+ * DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4)
+ 50 CONTINUE
+ 60 DDOT = DTEMP
+ RETURN
+ END
+C*MODULE BLAS1 *DECK DNRM2
+ DOUBLE PRECISION FUNCTION DNRM2 ( N, DX, INCX)
+ INTEGER NEXT
+ DOUBLE PRECISION DX(1), CUTLO, CUTHI, HITEST, SUM, XMAX,ZERO,ONE
+ DATA ZERO, ONE /0.0D+00, 1.0D+00/
+C
+C EUCLIDEAN NORM OF THE N-VECTOR STORED IN DX() WITH STORAGE
+C INCREMENT INCX .
+C IF N .LE. 0 RETURN WITH RESULT = 0.
+C IF N .GE. 1 THEN INCX MUST BE .GE. 1
+C
+C C.L.LAWSON, 1978 JAN 08
+C
+C FOUR PHASE METHOD USING TWO BUILT-IN CONSTANTS THAT ARE
+C HOPEFULLY APPLICABLE TO ALL MACHINES.
+C CUTLO = MAXIMUM OF SQRT(U/EPS) OVER ALL KNOWN MACHINES.
+C CUTHI = MINIMUM OF SQRT(V) OVER ALL KNOWN MACHINES.
+C WHERE
+C EPS = SMALLEST NO. SUCH THAT EPS + 1. .GT. 1.
+C U = SMALLEST POSITIVE NO. (UNDERFLOW LIMIT)
+C V = LARGEST NO. (OVERFLOW LIMIT)
+C
+C BRIEF OUTLINE OF ALGORITHM..
+C
+C PHASE 1 SCANS ZERO COMPONENTS.
+C MOVE TO PHASE 2 WHEN A COMPONENT IS NONZERO AND .LE. CUTLO
+C MOVE TO PHASE 3 WHEN A COMPONENT IS .GT. CUTLO
+C MOVE TO PHASE 4 WHEN A COMPONENT IS .GE. CUTHI/M
+C WHERE M = N FOR X() REAL AND M = 2*N FOR COMPLEX.
+C
+C VALUES FOR CUTLO AND CUTHI..
+C FROM THE ENVIRONMENTAL PARAMETERS LISTED IN THE IMSL CONVERTER
+C DOCUMENT THE LIMITING VALUES ARE AS FOLLOWS..
+C CUTLO, S.P. U/EPS = 2**(-102) FOR HONEYWELL. CLOSE SECONDS ARE
+C UNIVAC AND DEC AT 2**(-103)
+C THUS CUTLO = 2**(-51) = 4.44089E-16
+C CUTHI, S.P. V = 2**127 FOR UNIVAC, HONEYWELL, AND DEC.
+C THUS CUTHI = 2**(63.5) = 1.30438E19
+C CUTLO, D.P. U/EPS = 2**(-67) FOR HONEYWELL AND DEC.
+C THUS CUTLO = 2**(-33.5) = 8.23181D-11
+C CUTHI, D.P. SAME AS S.P. CUTHI = 1.30438D+19
+C DATA CUTLO, CUTHI / 8.232D-11, 1.304D+19 /
+C DATA CUTLO, CUTHI / 4.441E-16, 1.304E19 /
+ DATA CUTLO, CUTHI / 8.232D-11, 1.304D+19 /
+C
+ J=0
+ IF(N .GT. 0) GO TO 10
+ DNRM2 = ZERO
+ GO TO 300
+C
+ 10 ASSIGN 30 TO NEXT
+ SUM = ZERO
+ NN = N * INCX
+C BEGIN MAIN LOOP
+ I = 1
+ 20 GO TO NEXT,(30, 50, 70, 110)
+ 30 IF( ABS(DX(I)) .GT. CUTLO) GO TO 85
+ ASSIGN 50 TO NEXT
+ XMAX = ZERO
+C
+C PHASE 1. SUM IS ZERO
+C
+ 50 IF( DX(I) .EQ. ZERO) GO TO 200
+ IF( ABS(DX(I)) .GT. CUTLO) GO TO 85
+C
+C PREPARE FOR PHASE 2.
+ ASSIGN 70 TO NEXT
+ GO TO 105
+C
+C PREPARE FOR PHASE 4.
+C
+ 100 I = J
+ ASSIGN 110 TO NEXT
+ SUM = (SUM / DX(I)) / DX(I)
+ 105 XMAX = ABS(DX(I))
+ GO TO 115
+C
+C PHASE 2. SUM IS SMALL.
+C SCALE TO AVOID DESTRUCTIVE UNDERFLOW.
+C
+ 70 IF( ABS(DX(I)) .GT. CUTLO ) GO TO 75
+C
+C COMMON CODE FOR PHASES 2 AND 4.
+C IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW.
+C
+ 110 IF( ABS(DX(I)) .LE. XMAX ) GO TO 115
+ SUM = ONE + SUM * (XMAX / DX(I))**2
+ XMAX = ABS(DX(I))
+ GO TO 200
+C
+ 115 SUM = SUM + (DX(I)/XMAX)**2
+ GO TO 200
+C
+C
+C PREPARE FOR PHASE 3.
+C
+ 75 SUM = (SUM * XMAX) * XMAX
+C
+C
+C FOR REAL OR D.P. SET HITEST = CUTHI/N
+C FOR COMPLEX SET HITEST = CUTHI/(2*N)
+C
+ 85 HITEST = CUTHI/N
+C
+C PHASE 3. SUM IS MID-RANGE. NO SCALING.
+C
+ DO 95 J =I,NN,INCX
+ IF(ABS(DX(J)) .GE. HITEST) GO TO 100
+ 95 SUM = SUM + DX(J)**2
+ DNRM2 = SQRT( SUM )
+ GO TO 300
+C
+ 200 CONTINUE
+ I = I + INCX
+ IF ( I .LE. NN ) GO TO 20
+C
+C END OF MAIN LOOP.
+C
+C COMPUTE SQUARE ROOT AND ADJUST FOR SCALING.
+C
+ DNRM2 = XMAX * SQRT(SUM)
+ 300 CONTINUE
+ RETURN
+ END
+C*MODULE BLAS1 *DECK DROT
+ SUBROUTINE DROT (N,DX,INCX,DY,INCY,C,S)
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ DIMENSION DX(1),DY(1)
+C
+C APPLIES A PLANE ROTATION.
+C DX(I) = C*DX(I) + S*DY(I)
+C DY(I) = -S*DX(I) + C*DY(I)
+C JACK DONGARRA, LINPACK, 3/11/78.
+C
+ IF(N.LE.0)RETURN
+ IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
+C
+C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL
+C TO 1
+C
+ IX = 1
+ IY = 1
+ IF(INCX.LT.0)IX = (-N+1)*INCX + 1
+ IF(INCY.LT.0)IY = (-N+1)*INCY + 1
+ DO 10 I = 1,N
+ DTEMP = C*DX(IX) + S*DY(IY)
+ DY(IY) = C*DY(IY) - S*DX(IX)
+ DX(IX) = DTEMP
+ IX = IX + INCX
+ IY = IY + INCY
+ 10 CONTINUE
+ RETURN
+C
+C CODE FOR BOTH INCREMENTS EQUAL TO 1
+C
+ 20 DO 30 I = 1,N
+ DTEMP = C*DX(I) + S*DY(I)
+ DY(I) = C*DY(I) - S*DX(I)
+ DX(I) = DTEMP
+ 30 CONTINUE
+ RETURN
+ END
+C*MODULE BLAS1 *DECK DROTG
+ SUBROUTINE DROTG(DA,DB,C,S)
+C
+C CONSTRUCT GIVENS PLANE ROTATION.
+C JACK DONGARRA, LINPACK, 3/11/78.
+C
+ DOUBLE PRECISION DA,DB,C,S,ROE,SCALE,R,Z
+ DOUBLE PRECISION ZERO, ONE
+C
+ PARAMETER (ZERO=0.0D+00, ONE=1.0D+00)
+C
+C-----------------------------------------------------------------------
+C
+C
+ ROE = DB
+ IF( ABS(DA) .GT. ABS(DB) ) ROE = DA
+ SCALE = ABS(DA) + ABS(DB)
+ IF( SCALE .NE. ZERO ) GO TO 10
+ C = ONE
+ S = ZERO
+ R = ZERO
+ GO TO 20
+C
+ 10 R = SCALE*SQRT((DA/SCALE)**2 + (DB/SCALE)**2)
+ R = SIGN(ONE,ROE)*R
+ C = DA/R
+ S = DB/R
+ 20 Z = ONE
+ IF( ABS(DA) .GT. ABS(DB) ) Z = S
+ IF( ABS(DB) .GE. ABS(DA) .AND. C .NE. ZERO ) Z = ONE/C
+ DA = R
+ DB = Z
+ RETURN
+ END
+C*MODULE BLAS1 *DECK DSCAL
+ SUBROUTINE DSCAL(N,DA,DX,INCX)
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ DIMENSION DX(1)
+C
+C SCALES A VECTOR BY A CONSTANT.
+C DX(I) = DA * DX(I)
+C USES UNROLLED LOOPS FOR INCREMENT EQUAL TO ONE.
+C JACK DONGARRA, LINPACK, 3/11/78.
+C
+ IF(N.LE.0)RETURN
+ IF(INCX.EQ.1)GO TO 20
+C
+C CODE FOR INCREMENT NOT EQUAL TO 1
+C
+ NINCX = N*INCX
+ DO 10 I = 1,NINCX,INCX
+ DX(I) = DA*DX(I)
+ 10 CONTINUE
+ RETURN
+C
+C CODE FOR INCREMENT EQUAL TO 1
+C
+C
+C CLEAN-UP LOOP
+C
+ 20 M = MOD(N,5)
+ IF( M .EQ. 0 ) GO TO 40
+ DO 30 I = 1,M
+ DX(I) = DA*DX(I)
+ 30 CONTINUE
+ IF( N .LT. 5 ) RETURN
+ 40 MP1 = M + 1
+ DO 50 I = MP1,N,5
+ DX(I) = DA*DX(I)
+ DX(I + 1) = DA*DX(I + 1)
+ DX(I + 2) = DA*DX(I + 2)
+ DX(I + 3) = DA*DX(I + 3)
+ DX(I + 4) = DA*DX(I + 4)
+ 50 CONTINUE
+ RETURN
+ END
+C*MODULE BLAS1 *DECK DSWAP
+ SUBROUTINE DSWAP (N,DX,INCX,DY,INCY)
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ DIMENSION DX(1),DY(1)
+C
+C INTERCHANGES TWO VECTORS.
+C DX(I) <==> DY(I)
+C USES UNROLLED LOOPS FOR INCREMENTS EQUAL ONE.
+C JACK DONGARRA, LINPACK, 3/11/78.
+C
+ IF(N.LE.0)RETURN
+ IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20
+C
+C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL
+C TO 1
+C
+ IX = 1
+ IY = 1
+ IF(INCX.LT.0)IX = (-N+1)*INCX + 1
+ IF(INCY.LT.0)IY = (-N+1)*INCY + 1
+ DO 10 I = 1,N
+ DTEMP = DX(IX)
+ DX(IX) = DY(IY)
+ DY(IY) = DTEMP
+ IX = IX + INCX
+ IY = IY + INCY
+ 10 CONTINUE
+ RETURN
+C
+C CODE FOR BOTH INCREMENTS EQUAL TO 1
+C
+C
+C CLEAN-UP LOOP
+C
+ 20 M = MOD(N,3)
+ IF( M .EQ. 0 ) GO TO 40
+ DO 30 I = 1,M
+ DTEMP = DX(I)
+ DX(I) = DY(I)
+ DY(I) = DTEMP
+ 30 CONTINUE
+ IF( N .LT. 3 ) RETURN
+ 40 MP1 = M + 1
+ DO 50 I = MP1,N,3
+ DTEMP = DX(I)
+ DX(I) = DY(I)
+ DY(I) = DTEMP
+ DTEMP = DX(I + 1)
+ DX(I + 1) = DY(I + 1)
+ DY(I + 1) = DTEMP
+ DTEMP = DX(I + 2)
+ DX(I + 2) = DY(I + 2)
+ DY(I + 2) = DTEMP
+ 50 CONTINUE
+ RETURN
+ END
+C*MODULE BLAS1 *DECK IDAMAX
+ INTEGER FUNCTION IDAMAX(N,DX,INCX)
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ DIMENSION DX(1)
+C
+C FINDS THE INDEX OF ELEMENT HAVING MAX. ABSOLUTE VALUE.
+C JACK DONGARRA, LINPACK, 3/11/78.
+C
+ IDAMAX = 0
+ IF( N .LT. 1 ) RETURN
+ IDAMAX = 1
+ IF(N.EQ.1)RETURN
+ IF(INCX.EQ.1)GO TO 20
+C
+C CODE FOR INCREMENT NOT EQUAL TO 1
+C
+ IX = 1
+ RMAX = ABS(DX(1))
+ IX = IX + INCX
+ DO 10 I = 2,N
+ IF(ABS(DX(IX)).LE.RMAX) GO TO 5
+ IDAMAX = I
+ RMAX = ABS(DX(IX))
+ 5 IX = IX + INCX
+ 10 CONTINUE
+ RETURN
+C
+C CODE FOR INCREMENT EQUAL TO 1
+C
+ 20 RMAX = ABS(DX(1))
+ DO 30 I = 2,N
+ IF(ABS(DX(I)).LE.RMAX) GO TO 30
+ IDAMAX = I
+ RMAX = ABS(DX(I))
+ 30 CONTINUE
+ RETURN
+ END
+C*MODULE BLAS *DECK DGEMV
+ SUBROUTINE DGEMV(FORMA,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ CHARACTER*1 FORMA
+ DIMENSION A(LDA,*),X(*),Y(*)
+ PARAMETER (ZERO=0.0D+00, ONE=1.0D+00)
+C
+C CLONE OF -DGEMV- WRITTEN BY MIKE SCHMIDT
+C
+ LOCY = 1
+ IF(FORMA.EQ.'T') GO TO 200
+C
+C Y = ALPHA * A * X + BETA * Y
+C
+ IF(ALPHA.EQ.ONE .AND. BETA.EQ.ZERO) THEN
+ DO 110 I=1,M
+ Y(LOCY) = DDOT(N,A(I,1),LDA,X,INCX)
+ LOCY = LOCY+INCY
+ 110 CONTINUE
+ ELSE
+ DO 120 I=1,M
+ Y(LOCY) = ALPHA*DDOT(N,A(I,1),LDA,X,INCX) + BETA*Y(LOCY)
+ LOCY = LOCY+INCY
+ 120 CONTINUE
+ END IF
+ RETURN
+C
+C Y = ALPHA * A-TRANSPOSE * X + BETA * Y
+C
+ 200 CONTINUE
+ IF(ALPHA.EQ.ONE .AND. BETA.EQ.ZERO) THEN
+ DO 210 I=1,N
+ Y(LOCY) = DDOT(M,A(1,I),1,X,INCX)
+ LOCY = LOCY+INCY
+ 210 CONTINUE
+ ELSE
+ DO 220 I=1,N
+ Y(LOCY) = ALPHA*DDOT(M,A(1,I),1,X,INCX) + BETA*Y(LOCY)
+ LOCY = LOCY+INCY
+ 220 CONTINUE
+ END IF
+ RETURN
+ END
--- /dev/null
+ subroutine bond_move(nbond,nstart,psi,lprint,error)
+C Move NBOND fragment starting from the CA(nstart) by angle PSI.
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ integer nbond,nstart
+ double precision psi
+ logical fail,error,lprint
+ include 'COMMON.GEO'
+ include 'COMMON.CHAIN'
+ include 'COMMON.VAR'
+ include 'COMMON.REFSYS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.MCM'
+ dimension x(3),e(3,3),rot(3,3),trans(3,3)
+ error=.false.
+ nend=nstart+nbond
+ if (print_mc.gt.2) then
+ write (iout,*) 'nstart=',nstart,' nend=',nend,' nbond=',nbond
+ write (iout,*) 'psi=',psi
+ write (iout,'(a)') 'Original coordinates of the fragment'
+ do i=nstart,nend
+ write (iout,'(i5,3f10.5)') i,(c(j,i),j=1,3)
+ enddo
+ endif
+ if (nstart.lt.1 .or. nend .gt.nres .or. nbond.lt.2 .or.
+ & nbond.ge.nres-1) then
+ write (iout,'(a)') 'Bad data in BOND_MOVE.'
+ error=.true.
+ return
+ endif
+C Generate the reference system.
+ i2=nend
+ i3=nstart
+ i4=nstart+1
+ call refsys(error)
+C Return, if couldn't define the reference system.
+ if (error) return
+C Compute the transformation matrix.
+ cospsi=dcos(psi)
+ sinpsi=dsin(psi)
+ rot(1,1)=1.0D0
+ rot(1,2)=0.0D0
+ rot(1,3)=0.0D0
+ rot(2,1)=0.0D0
+ rot(2,2)=cospsi
+ rot(2,3)=-sinpsi
+ rot(3,1)=0.0D0
+ rot(3,2)=sinpsi
+ rot(3,3)=cospsi
+ do i=1,3
+ e(1,i)=e1(i)
+ e(2,i)=e2(i)
+ e(3,i)=e3(i)
+ enddo
+
+ if (print_mc.gt.2) then
+ write (iout,'(a)') 'Reference system and matrix r:'
+ do i=1,3
+ write(iout,'(i5,2(3f10.5,5x))')i,(e(i,j),j=1,3),(rot(i,j),j=1,3)
+ enddo
+ endif
+
+ call matmult(rot,e,trans)
+ do i=1,3
+ do j=1,3
+ e(i,1)=e1(i)
+ e(i,2)=e2(i)
+ e(i,3)=e3(i)
+ enddo
+ enddo
+ call matmult(e,trans,trans)
+
+ if (lprint) then
+ write (iout,'(a)') 'The trans matrix:'
+ do i=1,3
+ write (iout,'(i5,3f10.5)') i,(trans(i,j),j=1,3)
+ enddo
+ endif
+
+ do i=nstart,nend
+ do j=1,3
+ rij=c(j,nstart)
+ do k=1,3
+ rij=rij+trans(j,k)*(c(k,i)-c(k,nstart))
+ enddo
+ x(j)=rij
+ enddo
+ do j=1,3
+ c(j,i)=x(j)
+ enddo
+ enddo
+
+ if (lprint) then
+ write (iout,'(a)') 'Rotated coordinates of the fragment'
+ do i=nstart,nend
+ write (iout,'(i5,3f10.5)') i,(c(j,i),j=1,3)
+ enddo
+ endif
+
+c call int_from_cart(.false.,lprint)
+ if (nstart.gt.1) then
+ theta(nstart+1)=alpha(nstart-1,nstart,nstart+1)
+ phi(nstart+2)=beta(nstart-1,nstart,nstart+1,nstart+2)
+ if (nstart.gt.2) phi(nstart+1)=
+ & beta(nstart-2,nstart-1,nstart,nstart+1)
+ endif
+ if (nend.lt.nres) then
+ theta(nend+1)=alpha(nend-1,nend,nend+1)
+ phi(nend+1)=beta(nend-2,nend-1,nend,nend+1)
+ if (nend.lt.nres-1) phi(nend+2)=
+ & beta(nend-1,nend,nend+1,nend+2)
+ endif
+ if (print_mc.gt.2) then
+ write (iout,'(/a,i3,a,i3,a/)')
+ & 'Moved internal coordinates of the ',nstart,'-',nend,
+ & ' fragment:'
+ do i=nstart+1,nstart+2
+ write (iout,'(i5,2f10.5)') i,rad2deg*theta(i),rad2deg*phi(i)
+ enddo
+ do i=nend+1,nend+2
+ write (iout,'(i5,2f10.5)') i,rad2deg*theta(i),rad2deg*phi(i)
+ enddo
+ endif
+ return
+ end
--- /dev/null
+ subroutine cartder
+***********************************************************************
+* This subroutine calculates the derivatives of the consecutive virtual
+* bond vectors and the SC vectors in the virtual-bond angles theta and
+* virtual-torsional angles phi, as well as the derivatives of SC vectors
+* in the angles alpha and omega, describing the location of a side chain
+* in its local coordinate system.
+*
+* The derivatives are stored in the following arrays:
+*
+* DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
+* The structure is as follows:
+*
+* dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0, 0, 0
+* dDC(x,3)/dT(4),...,dDC(z,3)/dT(4),dDC(x,3)/dP(4),dDC(y,4)/dP(4),dDC(z,4)/dP(4)
+* . . . . . . . . . . . . . . . . . .
+* dDC(x,N-1)/dT(4),...,dDC(z,N-1)/dT(4),dDC(x,N-1)/dP(4),dDC(y,N-1)/dP(4),dDC(z,N-1)/dP(4)
+* .
+* .
+* .
+* dDC(x,N-1)/dT(N),...,dDC(z,N-1)/dT(N),dDC(x,N-1)/dP(N),dDC(y,N-1)/dP(N),dDC(z,N-1)/dP(N)
+*
+* DXDV - the derivatives of the side-chain vectors in theta and phi.
+* The structure is same as above.
+*
+* DCDS - the derivatives of the side chain vectors in the local spherical
+* andgles alph and omega:
+*
+* dX(x,2)/dA(2),dX(y,2)/dA(2),dX(z,2)/dA(2),dX(x,2)/dO(2),dX(y,2)/dO(2),dX(z,2)/dO(2)
+* dX(x,3)/dA(3),dX(y,3)/dA(3),dX(z,3)/dA(3),dX(x,3)/dO(3),dX(y,3)/dO(3),dX(z,3)/dO(3)
+* .
+* .
+* .
+* dX(x,N-1)/dA(N-1),dX(y,N-1)/dA(N-1),dX(z,N-1)/dA(N-1),dX(x,N-1)/dO(N-1),dX(y,N-1)/dO(N-1),dX(z,N-1)/dO(N-1)
+*
+* Version of March '95, based on an early version of November '91.
+*
+***********************************************************************
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.VAR'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ dimension drt(3,3,maxres),rdt(3,3,maxres),dp(3,3),temp(3,3),
+ & fromto(3,3,maxdim),prordt(3,3,maxres),prodrt(3,3,maxres)
+ dimension xx(3),xx1(3)
+c common /przechowalnia/ fromto
+* get the position of the jth ijth fragment of the chain coordinate system
+* in the fromto array.
+ indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
+*
+* calculate the derivatives of transformation matrix elements in theta
+*
+ do i=1,nres-2
+ rdt(1,1,i)=-rt(1,2,i)
+ rdt(1,2,i)= rt(1,1,i)
+ rdt(1,3,i)= 0.0d0
+ rdt(2,1,i)=-rt(2,2,i)
+ rdt(2,2,i)= rt(2,1,i)
+ rdt(2,3,i)= 0.0d0
+ rdt(3,1,i)=-rt(3,2,i)
+ rdt(3,2,i)= rt(3,1,i)
+ rdt(3,3,i)= 0.0d0
+ enddo
+*
+* derivatives in phi
+*
+ do i=2,nres-2
+ drt(1,1,i)= 0.0d0
+ drt(1,2,i)= 0.0d0
+ drt(1,3,i)= 0.0d0
+ drt(2,1,i)= rt(3,1,i)
+ drt(2,2,i)= rt(3,2,i)
+ drt(2,3,i)= rt(3,3,i)
+ drt(3,1,i)=-rt(2,1,i)
+ drt(3,2,i)=-rt(2,2,i)
+ drt(3,3,i)=-rt(2,3,i)
+ enddo
+*
+* generate the matrix products of type r(i)t(i)...r(j)t(j)
+*
+ do i=2,nres-2
+ ind=indmat(i,i+1)
+ do k=1,3
+ do l=1,3
+ temp(k,l)=rt(k,l,i)
+ enddo
+ enddo
+ do k=1,3
+ do l=1,3
+ fromto(k,l,ind)=temp(k,l)
+ enddo
+ enddo
+ do j=i+1,nres-2
+ ind=indmat(i,j+1)
+ do k=1,3
+ do l=1,3
+ dpkl=0.0d0
+ do m=1,3
+ dpkl=dpkl+temp(k,m)*rt(m,l,j)
+ enddo
+ dp(k,l)=dpkl
+ fromto(k,l,ind)=dpkl
+ enddo
+ enddo
+ do k=1,3
+ do l=1,3
+ temp(k,l)=dp(k,l)
+ enddo
+ enddo
+ enddo
+ enddo
+*
+* Calculate derivatives.
+*
+ ind1=0
+ do i=1,nres-2
+ ind1=ind1+1
+*
+* Derivatives of DC(i+1) in theta(i+2)
+*
+ do j=1,3
+ do k=1,2
+ dpjk=0.0D0
+ do l=1,3
+ dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
+ enddo
+ dp(j,k)=dpjk
+ prordt(j,k,i)=dp(j,k)
+ enddo
+ dp(j,3)=0.0D0
+ dcdv(j,ind1)=vbld(i+1)*dp(j,1)
+ enddo
+*
+* Derivatives of SC(i+1) in theta(i+2)
+*
+ xx1(1)=-0.5D0*xloc(2,i+1)
+ xx1(2)= 0.5D0*xloc(1,i+1)
+ do j=1,3
+ xj=0.0D0
+ do k=1,2
+ xj=xj+r(j,k,i)*xx1(k)
+ enddo
+ xx(j)=xj
+ enddo
+ do j=1,3
+ rj=0.0D0
+ do k=1,3
+ rj=rj+prod(j,k,i)*xx(k)
+ enddo
+ dxdv(j,ind1)=rj
+ enddo
+*
+* Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
+* than the other off-diagonal derivatives.
+*
+ do j=1,3
+ dxoiij=0.0D0
+ do k=1,3
+ dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
+ enddo
+ dxdv(j,ind1+1)=dxoiij
+ enddo
+cd print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
+*
+* Derivatives of DC(i+1) in phi(i+2)
+*
+ do j=1,3
+ do k=1,3
+ dpjk=0.0
+ do l=2,3
+ dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
+ enddo
+ dp(j,k)=dpjk
+ prodrt(j,k,i)=dp(j,k)
+ enddo
+ dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
+ enddo
+*
+* Derivatives of SC(i+1) in phi(i+2)
+*
+ xx(1)= 0.0D0
+ xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
+ xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
+ do j=1,3
+ rj=0.0D0
+ do k=2,3
+ rj=rj+prod(j,k,i)*xx(k)
+ enddo
+ dxdv(j+3,ind1)=-rj
+ enddo
+*
+* Derivatives of SC(i+1) in phi(i+3).
+*
+ do j=1,3
+ dxoiij=0.0D0
+ do k=1,3
+ dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
+ enddo
+ dxdv(j+3,ind1+1)=dxoiij
+ enddo
+*
+* Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
+* theta(nres) and phi(i+3) thru phi(nres).
+*
+ do j=i+1,nres-2
+ ind1=ind1+1
+ ind=indmat(i+1,j+1)
+cd print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
+ do k=1,3
+ do l=1,3
+ tempkl=0.0D0
+ do m=1,2
+ tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
+ enddo
+ temp(k,l)=tempkl
+ enddo
+ enddo
+cd print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
+cd print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
+cd print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
+* Derivatives of virtual-bond vectors in theta
+ do k=1,3
+ dcdv(k,ind1)=vbld(i+1)*temp(k,1)
+ enddo
+cd print '(3f8.3)',(dcdv(k,ind1),k=1,3)
+* Derivatives of SC vectors in theta
+ do k=1,3
+ dxoijk=0.0D0
+ do l=1,3
+ dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
+ enddo
+ dxdv(k,ind1+1)=dxoijk
+ enddo
+*
+*--- Calculate the derivatives in phi
+*
+ do k=1,3
+ do l=1,3
+ tempkl=0.0D0
+ do m=1,3
+ tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
+ enddo
+ temp(k,l)=tempkl
+ enddo
+ enddo
+ do k=1,3
+ dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
+ enddo
+ do k=1,3
+ dxoijk=0.0D0
+ do l=1,3
+ dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
+ enddo
+ dxdv(k+3,ind1+1)=dxoijk
+ enddo
+ enddo
+ enddo
+*
+* Derivatives in alpha and omega:
+*
+ do i=2,nres-1
+c dsci=dsc(itype(i))
+ dsci=vbld(i+nres)
+#ifdef OSF
+ alphi=alph(i)
+ omegi=omeg(i)
+ if(alphi.ne.alphi) alphi=100.0
+ if(omegi.ne.omegi) omegi=-100.0
+#else
+ alphi=alph(i)
+ omegi=omeg(i)
+#endif
+cd print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
+ cosalphi=dcos(alphi)
+ sinalphi=dsin(alphi)
+ cosomegi=dcos(omegi)
+ sinomegi=dsin(omegi)
+ temp(1,1)=-dsci*sinalphi
+ temp(2,1)= dsci*cosalphi*cosomegi
+ temp(3,1)=-dsci*cosalphi*sinomegi
+ temp(1,2)=0.0D0
+ temp(2,2)=-dsci*sinalphi*sinomegi
+ temp(3,2)=-dsci*sinalphi*cosomegi
+ theta2=pi-0.5D0*theta(i+1)
+ cost2=dcos(theta2)
+ sint2=dsin(theta2)
+ jjj=0
+cd print *,((temp(l,k),l=1,3),k=1,2)
+ do j=1,2
+ xp=temp(1,j)
+ yp=temp(2,j)
+ xxp= xp*cost2+yp*sint2
+ yyp=-xp*sint2+yp*cost2
+ zzp=temp(3,j)
+ xx(1)=xxp
+ xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
+ xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
+ do k=1,3
+ dj=0.0D0
+ do l=1,3
+ dj=dj+prod(k,l,i-1)*xx(l)
+ enddo
+ dxds(jjj+k,i)=dj
+ enddo
+ jjj=jjj+3
+ enddo
+ enddo
+ return
+ end
+
--- /dev/null
+ subroutine cartprint
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.NAMES'
+ include 'COMMON.IOUNITS'
+ write (iout,100)
+ do i=1,nres
+ write (iout,110) restyp(itype(i)),i,c(1,i),c(2,i),
+ & c(3,i),c(1,nres+i),c(2,nres+i),c(3,nres+i)
+ enddo
+ 100 format (//' alpha-carbon coordinates ',
+ & ' centroid coordinates'/
+ 1 ' ', 6X,'X',11X,'Y',11X,'Z',
+ & 10X,'X',11X,'Y',11X,'Z')
+ 110 format (a,'(',i3,')',6f12.5)
+ return
+ end
--- /dev/null
+ subroutine chainbuild
+C
+C Build the virtual polypeptide chain. Side-chain centroids are moveable.
+C As of 2/17/95.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.LOCAL'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ include 'COMMON.INTERACT'
+ logical lprn
+C Set lprn=.true. for debugging
+ lprn = .false.
+C
+C Define the origin and orientation of the coordinate system and locate the
+C first three CA's and SC(2).
+C
+ call orig_frame
+*
+* Build the alpha-carbon chain.
+*
+ do i=4,nres
+ call locate_next_res(i)
+ enddo
+C
+C First and last SC must coincide with the corresponding CA.
+C
+ do j=1,3
+ dc(j,nres+1)=0.0D0
+ dc_norm(j,nres+1)=0.0D0
+ dc(j,nres+nres)=0.0D0
+ dc_norm(j,nres+nres)=0.0D0
+ c(j,nres+1)=c(j,1)
+ c(j,nres+nres)=c(j,nres)
+ enddo
+*
+* Temporary diagnosis
+*
+ if (lprn) then
+
+ call cartprint
+ write (iout,'(/a)') 'Recalculated internal coordinates'
+ do i=2,nres-1
+ do j=1,3
+ c(j,maxres2)=0.5D0*(c(j,i-1)+c(j,i+1))
+ enddo
+ be=0.0D0
+ if (i.gt.3) be=rad2deg*beta(i-3,i-2,i-1,i)
+ be1=rad2deg*beta(nres+i,i,maxres2,i+1)
+ alfai=0.0D0
+ if (i.gt.2) alfai=rad2deg*alpha(i-2,i-1,i)
+ write (iout,1212) restyp(itype(i)),i,dist(i-1,i),
+ & alfai,be,dist(nres+i,i),rad2deg*alpha(nres+i,i,maxres2),be1
+ enddo
+ 1212 format (a3,'(',i3,')',2(f10.5,2f10.2))
+
+ endif
+
+ return
+ end
+c-------------------------------------------------------------------------
+ subroutine orig_frame
+C
+C Define the origin and orientation of the coordinate system and locate
+C the first three atoms.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.LOCAL'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ cost=dcos(theta(3))
+ sint=dsin(theta(3))
+ t(1,1,1)=-cost
+ t(1,2,1)=-sint
+ t(1,3,1)= 0.0D0
+ t(2,1,1)=-sint
+ t(2,2,1)= cost
+ t(2,3,1)= 0.0D0
+ t(3,1,1)= 0.0D0
+ t(3,2,1)= 0.0D0
+ t(3,3,1)= 1.0D0
+ r(1,1,1)= 1.0D0
+ r(1,2,1)= 0.0D0
+ r(1,3,1)= 0.0D0
+ r(2,1,1)= 0.0D0
+ r(2,2,1)= 1.0D0
+ r(2,3,1)= 0.0D0
+ r(3,1,1)= 0.0D0
+ r(3,2,1)= 0.0D0
+ r(3,3,1)= 1.0D0
+ do i=1,3
+ do j=1,3
+ rt(i,j,1)=t(i,j,1)
+ enddo
+ enddo
+ do i=1,3
+ do j=1,3
+ prod(i,j,1)=0.0D0
+ prod(i,j,2)=t(i,j,1)
+ enddo
+ prod(i,i,1)=1.0D0
+ enddo
+ c(1,1)=0.0D0
+ c(2,1)=0.0D0
+ c(3,1)=0.0D0
+ c(1,2)=vbld(2)
+ c(2,2)=0.0D0
+ c(3,2)=0.0D0
+ dc(1,0)=0.0d0
+ dc(2,0)=0.0D0
+ dc(3,0)=0.0D0
+ dc(1,1)=vbld(2)
+ dc(2,1)=0.0D0
+ dc(3,1)=0.0D0
+ dc_norm(1,0)=0.0D0
+ dc_norm(2,0)=0.0D0
+ dc_norm(3,0)=0.0D0
+ dc_norm(1,1)=1.0D0
+ dc_norm(2,1)=0.0D0
+ dc_norm(3,1)=0.0D0
+ do j=1,3
+ dc_norm(j,2)=prod(j,1,2)
+ dc(j,2)=vbld(3)*prod(j,1,2)
+ c(j,3)=c(j,2)+dc(j,2)
+ enddo
+ call locate_side_chain(2)
+ return
+ end
+c-----------------------------------------------------------------------------
+ subroutine locate_next_res(i)
+C
+C Locate CA(i) and SC(i-1)
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.LOCAL'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ include 'COMMON.INTERACT'
+C
+C Define the rotation matrices corresponding to CA(i)
+C
+#ifdef OSF
+ theti=theta(i)
+ if (theti.ne.theti) theti=100.0
+ phii=phi(i)
+ if (phii.ne.phii) phii=180.0
+#else
+ theti=theta(i)
+ phii=phi(i)
+#endif
+ cost=dcos(theti)
+ sint=dsin(theti)
+ cosphi=dcos(phii)
+ sinphi=dsin(phii)
+* Define the matrices of the rotation about the virtual-bond valence angles
+* theta, T(i,j,k), virtual-bond dihedral angles gamma (miscalled PHI in this
+* program), R(i,j,k), and, the cumulative matrices of rotation RT
+ t(1,1,i-2)=-cost
+ t(1,2,i-2)=-sint
+ t(1,3,i-2)= 0.0D0
+ t(2,1,i-2)=-sint
+ t(2,2,i-2)= cost
+ t(2,3,i-2)= 0.0D0
+ t(3,1,i-2)= 0.0D0
+ t(3,2,i-2)= 0.0D0
+ t(3,3,i-2)= 1.0D0
+ r(1,1,i-2)= 1.0D0
+ r(1,2,i-2)= 0.0D0
+ r(1,3,i-2)= 0.0D0
+ r(2,1,i-2)= 0.0D0
+ r(2,2,i-2)=-cosphi
+ r(2,3,i-2)= sinphi
+ r(3,1,i-2)= 0.0D0
+ r(3,2,i-2)= sinphi
+ r(3,3,i-2)= cosphi
+ rt(1,1,i-2)=-cost
+ rt(1,2,i-2)=-sint
+ rt(1,3,i-2)=0.0D0
+ rt(2,1,i-2)=sint*cosphi
+ rt(2,2,i-2)=-cost*cosphi
+ rt(2,3,i-2)=sinphi
+ rt(3,1,i-2)=-sint*sinphi
+ rt(3,2,i-2)=cost*sinphi
+ rt(3,3,i-2)=cosphi
+ call matmult(prod(1,1,i-2),rt(1,1,i-2),prod(1,1,i-1))
+ do j=1,3
+ dc_norm(j,i-1)=prod(j,1,i-1)
+ dc(j,i-1)=vbld(i)*prod(j,1,i-1)
+ c(j,i)=c(j,i-1)+dc(j,i-1)
+ enddo
+cd print '(2i3,2(3f10.5,5x))', i-1,i,(dc(j,i-1),j=1,3),(c(j,i),j=1,3)
+C
+C Now calculate the coordinates of SC(i-1)
+C
+ call locate_side_chain(i-1)
+ return
+ end
+c-----------------------------------------------------------------------------
+ subroutine locate_side_chain(i)
+C
+C Locate the side-chain centroid i, 1 < i < NRES. Put in C(*,NRES+i).
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.LOCAL'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ include 'COMMON.INTERACT'
+ dimension xx(3)
+
+c dsci=dsc(itype(i))
+c dsci_inv=dsc_inv(itype(i))
+ dsci=vbld(i+nres)
+ dsci_inv=vbld_inv(i+nres)
+#ifdef OSF
+ alphi=alph(i)
+ omegi=omeg(i)
+ if (alphi.ne.alphi) alphi=100.0
+ if (omegi.ne.omegi) omegi=-100.0
+#else
+ alphi=alph(i)
+ omegi=omeg(i)
+#endif
+ cosalphi=dcos(alphi)
+ sinalphi=dsin(alphi)
+ cosomegi=dcos(omegi)
+ sinomegi=dsin(omegi)
+ xp= dsci*cosalphi
+ yp= dsci*sinalphi*cosomegi
+ zp=-dsci*sinalphi*sinomegi
+* Now we have to rotate the coordinate system by 180-theta(i)/2 so as to get its
+* X-axis aligned with the vector DC(*,i)
+ theta2=pi-0.5D0*theta(i+1)
+ cost2=dcos(theta2)
+ sint2=dsin(theta2)
+ xx(1)= xp*cost2+yp*sint2
+ xx(2)=-xp*sint2+yp*cost2
+ xx(3)= zp
+cd print '(a3,i3,3f10.5,5x,3f10.5)',restyp(itype(i)),i,
+cd & xp,yp,zp,(xx(k),k=1,3)
+ do j=1,3
+ xloc(j,i)=xx(j)
+ enddo
+* Bring the SC vectors to the common coordinate system.
+ xx(1)=xloc(1,i)
+ xx(2)=xloc(2,i)*r(2,2,i-1)+xloc(3,i)*r(2,3,i-1)
+ xx(3)=xloc(2,i)*r(3,2,i-1)+xloc(3,i)*r(3,3,i-1)
+ do j=1,3
+ xrot(j,i)=xx(j)
+ enddo
+ do j=1,3
+ rj=0.0D0
+ do k=1,3
+ rj=rj+prod(j,k,i-1)*xx(k)
+ enddo
+ dc(j,nres+i)=rj
+ dc_norm(j,nres+i)=rj*dsci_inv
+ c(j,nres+i)=c(j,i)+rj
+ enddo
+ return
+ end
--- /dev/null
+{
+ if($0==" include 'COMMON.LANGEVIN'") {
+ print "#ifndef LANG0"
+ print " include 'COMMON.LANGEVIN'"
+ print "#else"
+ print " include 'COMMON.LANGEVIN.lang0'"
+ print "#endif"
+ }else{
+ print $0
+ }
+}
--- /dev/null
+ subroutine check_bond
+C Subroutine is checking if the fitted function which describs sc_rot_pot
+C is correct, printing, alpha,beta, energy, data - for some known theta.
+C theta angle is read from the input file. Sc_rot_pot are printed
+C for the second residue in sequance.
+ include 'DIMENSIONS'
+ include 'COMMON.VAR'
+ include 'COMMON.GEO'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CHAIN'
+ double precision energia(0:n_ene)
+ it=itype(2)
+ do i=1,101
+ vbld(nres+2)=0.5d0+0.05d0*(i-1)
+ call chainbuild
+ call etotal(energia)
+ write (2,*) vbld(nres+2),energia(17)
+ enddo
+ return
+ end
--- /dev/null
+ subroutine check_sc_distr
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.TIME1'
+ include 'COMMON.INTERACT'
+ include 'COMMON.NAMES'
+ include 'COMMON.GEO'
+ include 'COMMON.HEADER'
+ include 'COMMON.CONTROL'
+ logical fail
+ double precision varia(maxvar)
+ double precision hrtime,mintime,sectime
+ parameter (MaxSample=10000000,delt=1.0D0/MaxSample)
+ dimension prob(0:72,0:90)
+ dV=2.0D0*5.0D0*deg2rad*deg2rad
+ print *,'dv=',dv
+ do 10 it=1,1
+ if (it.eq.10) goto 10
+ open (20,file=restyp(it)//'_distr.sdc',status='unknown')
+ call gen_side(it,90.0D0*deg2rad,al,om,fail)
+ close (20)
+ goto 10
+ open (20,file=restyp(it)//'_distr1.sdc',status='unknown')
+ do i=0,90
+ do j=0,72
+ prob(j,i)=0.0D0
+ enddo
+ enddo
+ do isample=1,MaxSample
+ call gen_side(it,90.0D0*deg2rad,al,om)
+ indal=rad2deg*al/2
+ indom=(rad2deg*om+180.0D0)/5
+ prob(indom,indal)=prob(indom,indal)+delt
+ enddo
+ do i=45,90
+ do j=0,72
+ write (20,'(2f10.3,1pd15.5)') 2*i+0.0D0,5*j-180.0D0,
+ & prob(j,i)/dV
+ enddo
+ enddo
+ 10 continue
+ return
+ end
--- /dev/null
+ subroutine check_cartgrad
+C Check the gradient of Cartesian coordinates in internal coordinates.
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.VAR'
+ include 'COMMON.CHAIN'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.DERIV'
+ include 'COMMON.SCCOR'
+ dimension temp(6,maxres),xx(3),gg(3)
+ indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
+*
+* Check the gradient of the virtual-bond and SC vectors in the internal
+* coordinates.
+*
+ aincr=1.0d-7
+ aincr2=5.0d-8
+ call cartder
+ write (iout,'(a)') '**************** dx/dalpha'
+ write (iout,'(a)')
+ do i=2,nres-1
+ alphi=alph(i)
+ alph(i)=alph(i)+aincr
+ do k=1,3
+ temp(k,i)=dc(k,nres+i)
+ enddo
+ call chainbuild
+ do k=1,3
+ gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
+ xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
+ enddo
+ write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)')
+ & i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
+ write (iout,'(a)')
+ alph(i)=alphi
+ call chainbuild
+ enddo
+ write (iout,'(a)')
+ write (iout,'(a)') '**************** dx/domega'
+ write (iout,'(a)')
+ do i=2,nres-1
+ omegi=omeg(i)
+ omeg(i)=omeg(i)+aincr
+ do k=1,3
+ temp(k,i)=dc(k,nres+i)
+ enddo
+ call chainbuild
+ do k=1,3
+ gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
+ xx(k)=dabs((gg(k)-dxds(k+3,i))/
+ & (aincr*dabs(dxds(k+3,i))+aincr))
+ enddo
+ write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)')
+ & i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
+ write (iout,'(a)')
+ omeg(i)=omegi
+ call chainbuild
+ enddo
+ write (iout,'(a)')
+ write (iout,'(a)') '**************** dx/dtheta'
+ write (iout,'(a)')
+ do i=3,nres
+ theti=theta(i)
+ theta(i)=theta(i)+aincr
+ do j=i-1,nres-1
+ do k=1,3
+ temp(k,j)=dc(k,nres+j)
+ enddo
+ enddo
+ call chainbuild
+ do j=i-1,nres-1
+ ii = indmat(i-2,j)
+c print *,'i=',i-2,' j=',j-1,' ii=',ii
+ do k=1,3
+ gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
+ xx(k)=dabs((gg(k)-dxdv(k,ii))/
+ & (aincr*dabs(dxdv(k,ii))+aincr))
+ enddo
+ write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)')
+ & i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
+ write(iout,'(a)')
+ enddo
+ write (iout,'(a)')
+ theta(i)=theti
+ call chainbuild
+ enddo
+ write (iout,'(a)') '***************** dx/dphi'
+ write (iout,'(a)')
+ do i=4,nres
+ phi(i)=phi(i)+aincr
+ do j=i-1,nres-1
+ do k=1,3
+ temp(k,j)=dc(k,nres+j)
+ enddo
+ enddo
+ call chainbuild
+ do j=i-1,nres-1
+ ii = indmat(i-2,j)
+c print *,'ii=',ii
+ do k=1,3
+ gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
+ xx(k)=dabs((gg(k)-dxdv(k+3,ii))/
+ & (aincr*dabs(dxdv(k+3,ii))+aincr))
+ enddo
+ write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)')
+ & i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
+ write(iout,'(a)')
+ enddo
+ phi(i)=phi(i)-aincr
+ call chainbuild
+ enddo
+ write (iout,'(a)') '****************** ddc/dtheta'
+ do i=1,nres-2
+ thet=theta(i+2)
+ theta(i+2)=thet+aincr
+ do j=i,nres
+ do k=1,3
+ temp(k,j)=dc(k,j)
+ enddo
+ enddo
+ call chainbuild
+ do j=i+1,nres-1
+ ii = indmat(i,j)
+c print *,'ii=',ii
+ do k=1,3
+ gg(k)=(dc(k,j)-temp(k,j))/aincr
+ xx(k)=dabs((gg(k)-dcdv(k,ii))/
+ & (aincr*dabs(dcdv(k,ii))+aincr))
+ enddo
+ write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)')
+ & i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
+ write (iout,'(a)')
+ enddo
+ do j=1,nres
+ do k=1,3
+ dc(k,j)=temp(k,j)
+ enddo
+ enddo
+ theta(i+2)=thet
+ enddo
+ write (iout,'(a)') '******************* ddc/dphi'
+ do i=1,nres-3
+ phii=phi(i+3)
+ phi(i+3)=phii+aincr
+ do j=1,nres
+ do k=1,3
+ temp(k,j)=dc(k,j)
+ enddo
+ enddo
+ call chainbuild
+ do j=i+2,nres-1
+ ii = indmat(i+1,j)
+c print *,'ii=',ii
+ do k=1,3
+ gg(k)=(dc(k,j)-temp(k,j))/aincr
+ xx(k)=dabs((gg(k)-dcdv(k+3,ii))/
+ & (aincr*dabs(dcdv(k+3,ii))+aincr))
+ enddo
+ write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)')
+ & i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
+ write (iout,'(a)')
+ enddo
+ do j=1,nres
+ do k=1,3
+ dc(k,j)=temp(k,j)
+ enddo
+ enddo
+ phi(i+3)=phii
+ enddo
+ return
+ end
+C----------------------------------------------------------------------------
+ subroutine check_ecart
+C Check the gradient of the energy in Cartesian coordinates.
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.VAR'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.SCCOR'
+ common /srutu/ icall
+ dimension ggg(6),cc(3),xx(3),ddc(3),ddx(3),x(maxvar),g(maxvar)
+ dimension grad_s(6,maxres)
+ double precision energia(0:n_ene),energia1(0:n_ene)
+ integer uiparm(1)
+ double precision urparm(1)
+ external fdum
+ icg=1
+ nf=0
+ nfl=0
+ call zerograd
+ aincr=1.0D-7
+ print '(a)','CG processor',me,' calling CHECK_CART.'
+ nf=0
+ icall=0
+ call geom_to_var(nvar,x)
+ call etotal(energia(0))
+ etot=energia(0)
+ call enerprint(energia(0))
+ call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
+ icall =1
+ do i=1,nres
+ write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
+ enddo
+ do i=1,nres
+ do j=1,3
+ grad_s(j,i)=gradc(j,i,icg)
+ grad_s(j+3,i)=gradx(j,i,icg)
+ enddo
+ enddo
+ call flush(iout)
+ write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
+ do i=1,nres
+ do j=1,3
+ xx(j)=c(j,i+nres)
+ ddc(j)=dc(j,i)
+ ddx(j)=dc(j,i+nres)
+ enddo
+ do j=1,3
+ dc(j,i)=dc(j,i)+aincr
+ do k=i+1,nres
+ c(j,k)=c(j,k)+aincr
+ c(j,k+nres)=c(j,k+nres)+aincr
+ enddo
+ call etotal(energia1(0))
+ etot1=energia1(0)
+ ggg(j)=(etot1-etot)/aincr
+ dc(j,i)=ddc(j)
+ do k=i+1,nres
+ c(j,k)=c(j,k)-aincr
+ c(j,k+nres)=c(j,k+nres)-aincr
+ enddo
+ enddo
+ do j=1,3
+ c(j,i+nres)=c(j,i+nres)+aincr
+ dc(j,i+nres)=dc(j,i+nres)+aincr
+ call etotal(energia1(0))
+ etot1=energia1(0)
+ ggg(j+3)=(etot1-etot)/aincr
+ c(j,i+nres)=xx(j)
+ dc(j,i+nres)=ddx(j)
+ enddo
+ write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)')
+ & i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
+ enddo
+ return
+ end
+c----------------------------------------------------------------------------
+ subroutine check_ecartint
+C Check the gradient of the energy in Cartesian coordinates.
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.VAR'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.MD'
+ include 'COMMON.LOCAL'
+ include 'COMMON.SPLITELE'
+ include 'COMMON.SCCOR'
+ common /srutu/ icall
+ dimension ggg(6),ggg1(6),cc(3),xx(3),ddc(3),ddx(3),x(maxvar),
+ & g(maxvar)
+ dimension dcnorm_safe(3),dxnorm_safe(3)
+ dimension grad_s(6,0:maxres),grad_s1(6,0:maxres)
+ double precision phi_temp(maxres),theta_temp(maxres),
+ & alph_temp(maxres),omeg_temp(maxres)
+ double precision energia(0:n_ene),energia1(0:n_ene)
+ integer uiparm(1)
+ double precision urparm(1)
+ external fdum
+ r_cut=2.0d0
+ rlambd=0.3d0
+ icg=1
+ nf=0
+ nfl=0
+ call intout
+c call intcartderiv
+c call checkintcartgrad
+ call zerograd
+ aincr=1.0D-5
+ write(iout,*) 'Calling CHECK_ECARTINT.'
+ nf=0
+ icall=0
+ call geom_to_var(nvar,x)
+ if (.not.split_ene) then
+ call etotal(energia(0))
+c do i=1,nres
+c write (iout,*) "atu?", gloc_sc(1,i,icg),gloc(i,icg)
+c enddo
+ etot=energia(0)
+ call enerprint(energia(0))
+ call flush(iout)
+ write (iout,*) "enter cartgrad"
+c do i=1,nres
+c write (iout,*) gloc_sc(1,i,icg)
+c enddo
+ call flush(iout)
+ call cartgrad
+ write (iout,*) "exit cartgrad"
+ call flush(iout)
+ icall =1
+ do i=1,nres
+ write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
+ enddo
+ do j=1,3
+ grad_s(j,0)=gcart(j,0)
+ enddo
+ do i=1,nres
+ do j=1,3
+ grad_s(j,i)=gcart(j,i)
+ grad_s(j+3,i)=gxcart(j,i)
+ enddo
+ enddo
+ else
+!- split gradient check
+ call zerograd
+ call etotal_long(energia(0))
+ call enerprint(energia(0))
+ call flush(iout)
+ write (iout,*) "enter cartgrad"
+ call flush(iout)
+ call cartgrad
+ write (iout,*) "exit cartgrad"
+ call flush(iout)
+ icall =1
+ write (iout,*) "longrange grad"
+ do i=1,nres
+ write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),
+ & (gxcart(j,i),j=1,3)
+ enddo
+ do j=1,3
+ grad_s(j,0)=gcart(j,0)
+ enddo
+ do i=1,nres
+ do j=1,3
+ grad_s(j,i)=gcart(j,i)
+ grad_s(j+3,i)=gxcart(j,i)
+ enddo
+ enddo
+ call zerograd
+ call etotal_short(energia(0))
+ call enerprint(energia(0))
+c do i=1,nres
+c write (iout,*) gloc_sc(1,i,icg)
+c enddo
+ call flush(iout)
+ write (iout,*) "enter cartgrad"
+ call flush(iout)
+ call cartgrad
+ write (iout,*) "exit cartgrad"
+ call flush(iout)
+ icall =1
+ write (iout,*) "shortrange grad"
+ do i=1,nres
+ write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),
+ & (gxcart(j,i),j=1,3)
+ enddo
+ do j=1,3
+ grad_s1(j,0)=gcart(j,0)
+ enddo
+ do i=1,nres
+ do j=1,3
+ grad_s1(j,i)=gcart(j,i)
+ grad_s1(j+3,i)=gxcart(j,i)
+ enddo
+ enddo
+ endif
+ write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
+ do i=0,nres
+ do j=1,3
+ xx(j)=c(j,i+nres)
+ ddc(j)=dc(j,i)
+ ddx(j)=dc(j,i+nres)
+ do k=1,3
+ dcnorm_safe(k)=dc_norm(k,i)
+ dxnorm_safe(k)=dc_norm(k,i+nres)
+ enddo
+ enddo
+ do j=1,3
+ dc(j,i)=ddc(j)+aincr
+ call chainbuild_cart
+#ifdef MPI
+c Broadcast the order to compute internal coordinates to the slaves.
+c if (nfgtasks.gt.1)
+c & call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
+#endif
+c call int_from_cart1(.false.)
+ if (.not.split_ene) then
+ call etotal(energia1(0))
+ etot1=energia1(0)
+ else
+!- split gradient
+ call etotal_long(energia1(0))
+ etot11=energia1(0)
+ call etotal_short(energia1(0))
+ etot12=energia1(0)
+c write (iout,*) "etot11",etot11," etot12",etot12
+ endif
+!- end split gradient
+c write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
+ dc(j,i)=ddc(j)-aincr
+ call chainbuild_cart
+c call int_from_cart1(.false.)
+ if (.not.split_ene) then
+ call etotal(energia1(0))
+ etot2=energia1(0)
+ ggg(j)=(etot1-etot2)/(2*aincr)
+ else
+!- split gradient
+ call etotal_long(energia1(0))
+ etot21=energia1(0)
+ ggg(j)=(etot11-etot21)/(2*aincr)
+ call etotal_short(energia1(0))
+ etot22=energia1(0)
+ ggg1(j)=(etot12-etot22)/(2*aincr)
+!- end split gradient
+c write (iout,*) "etot21",etot21," etot22",etot22
+ endif
+c write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
+ dc(j,i)=ddc(j)
+ call chainbuild_cart
+ enddo
+ do j=1,3
+ dc(j,i+nres)=ddx(j)+aincr
+ call chainbuild_cart
+c write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
+c write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
+c write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
+c write (iout,*) "dxnormnorm",dsqrt(
+c & dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
+c write (iout,*) "dxnormnormsafe",dsqrt(
+c & dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
+c write (iout,*)
+ if (.not.split_ene) then
+ call etotal(energia1(0))
+ etot1=energia1(0)
+ else
+!- split gradient
+ call etotal_long(energia1(0))
+ etot11=energia1(0)
+ call etotal_short(energia1(0))
+ etot12=energia1(0)
+ endif
+!- end split gradient
+c write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
+ dc(j,i+nres)=ddx(j)-aincr
+ call chainbuild_cart
+c write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
+c write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
+c write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
+c write (iout,*)
+c write (iout,*) "dxnormnorm",dsqrt(
+c & dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
+c write (iout,*) "dxnormnormsafe",dsqrt(
+c & dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
+ if (.not.split_ene) then
+ call etotal(energia1(0))
+ etot2=energia1(0)
+ ggg(j+3)=(etot1-etot2)/(2*aincr)
+ else
+!- split gradient
+ call etotal_long(energia1(0))
+ etot21=energia1(0)
+ ggg(j+3)=(etot11-etot21)/(2*aincr)
+ call etotal_short(energia1(0))
+ etot22=energia1(0)
+ ggg1(j+3)=(etot12-etot22)/(2*aincr)
+!- end split gradient
+ endif
+c write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
+ dc(j,i+nres)=ddx(j)
+ call chainbuild_cart
+ enddo
+ write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)')
+ & i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
+ if (split_ene) then
+ write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)')
+ & i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),
+ & k=1,6)
+ write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)')
+ & i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),
+ & ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
+ endif
+ enddo
+ return
+ end
+c-------------------------------------------------------------------------
+ subroutine int_from_cart1(lprn)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+ integer ierror
+#endif
+ include 'COMMON.IOUNITS'
+ include 'COMMON.VAR'
+ include 'COMMON.CHAIN'
+ include 'COMMON.GEO'
+ include 'COMMON.INTERACT'
+ include 'COMMON.LOCAL'
+ include 'COMMON.NAMES'
+ include 'COMMON.SETUP'
+ include 'COMMON.TIME1'
+ logical lprn
+ if (lprn) write (iout,'(/a)') 'Recalculated internal coordinates'
+#ifdef TIMING
+ time01=MPI_Wtime()
+#endif
+#if defined(PARINT) && defined(MPI)
+ do i=iint_start,iint_end+1
+#else
+ do i=2,nres
+#endif
+ 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) then
+ if (i.le.nres) phi(i+1)=beta(i-2,i-1,i,i+1)
+ if ((itype(i).ne.10).and.(itype(i-1).ne.10)) then
+ tauangle(3,i+1)=beta(i+nres-1,i-1,i,i+nres)
+ endif
+ if (itype(i-1).ne.10) then
+ tauangle(1,i+1)=beta(i-1+nres,i-1,i,i+1)
+ omicron(1,i)=alpha(i-2,i-1,i-1+nres)
+ omicron(2,i)=alpha(i-1+nres,i-1,i)
+ endif
+ if (itype(i).ne.10) then
+ tauangle(2,i+1)=beta(i-2,i-1,i,i+nres)
+ endif
+ endif
+ omeg(i)=beta(nres+i,i,maxres2,i+1)
+ alph(i)=alpha(nres+i,i,maxres2)
+ theta(i+1)=alpha(i-1,i,i+1)
+ 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
+
+#if defined(PARINT) && defined(MPI)
+ if (nfgtasks1.gt.1) then
+cd write(iout,*) "iint_start",iint_start," iint_count",
+cd & (iint_count(i),i=0,nfgtasks-1)," iint_displ",
+cd & (iint_displ(i),i=0,nfgtasks-1)
+cd write (iout,*) "Gather vbld backbone"
+cd call flush(iout)
+ time00=MPI_Wtime()
+ call MPI_Allgatherv(vbld(iint_start),iint_count(fg_rank1),
+ & MPI_DOUBLE_PRECISION,vbld(1),iint_count(0),iint_displ(0),
+ & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
+cd write (iout,*) "Gather vbld_inv"
+cd call flush(iout)
+ call MPI_Allgatherv(vbld_inv(iint_start),iint_count(fg_rank1),
+ & MPI_DOUBLE_PRECISION,vbld_inv(1),iint_count(0),iint_displ(0),
+ & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
+cd write (iout,*) "Gather vbld side chain"
+cd call flush(iout)
+ call MPI_Allgatherv(vbld(iint_start+nres),iint_count(fg_rank1),
+ & MPI_DOUBLE_PRECISION,vbld(nres+1),iint_count(0),iint_displ(0),
+ & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
+cd write (iout,*) "Gather vbld_inv side chain"
+cd call flush(iout)
+ call MPI_Allgatherv(vbld_inv(iint_start+nres),
+ & iint_count(fg_rank1),MPI_DOUBLE_PRECISION,vbld_inv(nres+1),
+ & iint_count(0),iint_displ(0),MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
+cd write (iout,*) "Gather theta"
+cd call flush(iout)
+ call MPI_Allgatherv(theta(iint_start+1),iint_count(fg_rank1),
+ & MPI_DOUBLE_PRECISION,theta(2),iint_count(0),iint_displ(0),
+ & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
+cd write (iout,*) "Gather phi"
+cd call flush(iout)
+ call MPI_Allgatherv(phi(iint_start+1),iint_count(fg_rank1),
+ & MPI_DOUBLE_PRECISION,phi(2),iint_count(0),iint_displ(0),
+ & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
+#ifdef CRYST_SC
+cd write (iout,*) "Gather alph"
+cd call flush(iout)
+ call MPI_Allgatherv(alph(iint_start),iint_count(fg_rank1),
+ & MPI_DOUBLE_PRECISION,alph(1),iint_count(0),iint_displ(0),
+ & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
+cd write (iout,*) "Gather omeg"
+cd call flush(iout)
+ call MPI_Allgatherv(omeg(iint_start),iint_count(fg_rank1),
+ & MPI_DOUBLE_PRECISION,omeg(1),iint_count(0),iint_displ(0),
+ & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
+#endif
+ time_gather=time_gather+MPI_Wtime()-time00
+ endif
+#endif
+ do i=1,nres-1
+ do j=1,3
+ dc_norm(j,i)=dc(j,i)*vbld_inv(i+1)
+ enddo
+ enddo
+ do i=2,nres-1
+ do j=1,3
+ 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))
+#ifdef TIMING
+ time_intfcart=time_intfcart+MPI_Wtime()-time01
+#endif
+ return
+ end
+c----------------------------------------------------------------------------
+ subroutine check_eint
+C Check the gradient of energy in internal coordinates.
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.VAR'
+ include 'COMMON.GEO'
+ common /srutu/ icall
+ dimension x(maxvar),gana(maxvar),gg(maxvar)
+ integer uiparm(1)
+ double precision urparm(1)
+ double precision energia(0:n_ene),energia1(0:n_ene),
+ & energia2(0:n_ene)
+ character*6 key
+ external fdum
+ call zerograd
+ aincr=1.0D-7
+ print '(a)','Calling CHECK_INT.'
+ nf=0
+ nfl=0
+ icg=1
+ call geom_to_var(nvar,x)
+ call var_to_geom(nvar,x)
+ call chainbuild
+ icall=1
+ print *,'ICG=',ICG
+ call etotal(energia(0))
+ etot = energia(0)
+ call enerprint(energia(0))
+ print *,'ICG=',ICG
+#ifdef MPL
+ if (MyID.ne.BossID) then
+ call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
+ nf=x(nvar+1)
+ nfl=x(nvar+2)
+ icg=x(nvar+3)
+ endif
+#endif
+ nf=1
+ nfl=3
+cd write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
+ call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
+cd write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar)
+ icall=1
+ do i=1,nvar
+ xi=x(i)
+ x(i)=xi-0.5D0*aincr
+ call var_to_geom(nvar,x)
+ call chainbuild
+ call etotal(energia1(0))
+ etot1=energia1(0)
+ x(i)=xi+0.5D0*aincr
+ call var_to_geom(nvar,x)
+ call chainbuild
+ call etotal(energia2(0))
+ etot2=energia2(0)
+ gg(i)=(etot2-etot1)/aincr
+ write (iout,*) i,etot1,etot2
+ x(i)=xi
+ enddo
+ write (iout,'(/2a)')' Variable Numerical Analytical',
+ & ' RelDiff*100% '
+ do i=1,nvar
+ if (i.le.nphi) then
+ ii=i
+ key = ' phi'
+ else if (i.le.nphi+ntheta) then
+ ii=i-nphi
+ key=' theta'
+ else if (i.le.nphi+ntheta+nside) then
+ ii=i-(nphi+ntheta)
+ key=' alpha'
+ else
+ ii=i-(nphi+ntheta+nside)
+ key=' omega'
+ endif
+ write (iout,'(i3,a,i3,3(1pd16.6))')
+ & i,key,ii,gg(i),gana(i),
+ & 100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
+ enddo
+ return
+ end
--- /dev/null
+ subroutine compare_s1(n_thr,num_thread_save,energyx,x,
+ & icomp,enetbss,coordss,rms_d,modif,iprint)
+C This subroutine compares the new conformation, whose variables are in X
+C with the previously accumulated conformations whose energies and variables
+C are stored in ENETBSS and COORDSS, respectively. The meaning of other
+C variables is as follows:
+C
+C N_THR - on input the previous # of accumulated confs, on output the current
+C # of accumulated confs.
+C N_REPEAT - an array that indicates how many times the structure has already
+C been used to start the reversed-reversing procedure. Addition of
+C a new structure replacement of a structure with a similar, but
+C lower-energy structure resets the respective entry in N_REPEAT to zero
+C I9 - output unit
+C ENERGYX,X - the energy and variables of the new conformations.
+C ICOMP - comparison result:
+C 0 - the new structure is similar to one of the previous ones and does
+C not have a remarkably lower energy and is therefore rejected;
+C 1 - the new structure is different and is added to the set, because
+C there is still room in the COORDSS and ENETBSS arrays;
+C 2 - the new structure is different, but higher in energy than any
+C previous one and is therefore rejected
+C 3 - there is no more room in the COORDSS and ENETBSS arrays, but
+C the new structure is lower in energy than at least the highest-
+C energy previous structure and therefore replaces it.
+C 9 - the new structure is similar to a number of previous structures,
+C but has a remarkably lower energy than any of them; therefore
+C replaces all these structures;
+C MODIF - a logical variable that shows whether to include the new structure
+C in the set of accumulated structures
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+crc include 'COMMON.DEFORM'
+ include 'COMMON.IOUNITS'
+#ifdef UNRES
+ include 'COMMON.CHAIN'
+#endif
+
+ dimension x(maxvar)
+ dimension x1(maxvar)
+ double precision przes(3),obrot(3,3)
+ integer list(max_thread)
+ logical non_conv,modif
+ double precision enetbss(max_threadss)
+ double precision coordss(maxvar,max_threadss)
+
+ nlist=0
+#ifdef UNRES
+ call var_to_geom(nvar,x)
+ call chainbuild
+ do k=1,2*nres
+ do kk=1,3
+ cref(kk,k)=c(kk,k)
+ enddo
+ enddo
+#endif
+c write(iout,*)'*ene=',energyx
+ j=0
+ enex_jp=-1.0d+99
+ do i=1,n_thr
+ do k=1,nvar
+ x1(k)=coordss(k,i)
+ enddo
+ if (iprint.gt.3) then
+ write (iout,*) 'Compare_ss, i=',i
+ write (iout,*) 'New structure Energy:',energyx
+ write (iout,'(10f8.3)') (rad2deg*x(k),k=1,nvar)
+ write (iout,*) 'Template structure Energy:',enetbss(i)
+ write (iout,'(10f8.3)') (rad2deg*x1(k),k=1,nvar)
+ endif
+
+#ifdef UNRES
+ call var_to_geom(nvar,x1)
+ call chainbuild
+cd write(iout,*)'C and CREF'
+cd write(iout,'(i5,3f10.5,5x,3f10.5)')(k,(c(j,k),j=1,3),
+cd & (cref(j,k),j=1,3),k=1,nres)
+ call fitsq(roznica,c(1,1),cref(1,1),nres,przes,obrot,non_conv)
+ if (non_conv) then
+ print *,'Problems in FITSQ!!!'
+ print *,'X'
+ print '(10f8.3)',(x(k),k=1,nvar)
+ print *,'X1'
+ print '(10f8.3)',(x1(k),k=1,nvar)
+ print *,'C and CREF'
+ print '(i5,3f10.5,5x,3f10.5)',(k,(c(j,k),j=1,3),
+ & (cref(j,k),j=1,3),k=1,nres)
+ endif
+ roznica=dsqrt(dabs(roznica))
+ iresult = 1
+ if (roznica.lt.rms_d) iresult = 0
+#else
+ energyy=enetbss(i)
+ call cmprs(x,x1,roznica,energyx,energyy,iresult)
+#endif
+ if (iprint.gt.1) write(iout,'(i5,f10.6,$)') i,roznica
+c print '(i5,f8.3)',i,roznica
+ if(iresult.eq.0) then
+ nlist = nlist + 1
+ list(nlist)=i
+ if (iprint.gt.1) write(iout,*)
+ if(energyx.ge.enetbss(i)) then
+ if (iprint.gt.1)
+ & write(iout,*)'s*>> structure rejected - same as nr ',i,
+ & ' RMS',roznica
+ minimize_s_flag=0
+ icomp=0
+ go to 1106
+ endif
+ endif
+ if(energyx.lt.enetbss(i).and.enex_jp.lt.enetbss(i))then
+ j=i
+ enex_jp=enetbss(i)
+ endif
+ enddo
+ if (iprint.gt.1) write(iout,*)
+ if(nlist.gt.0) then
+ if (modif) then
+ if (iprint.gt.1)
+ & write(iout,'(a,i3,$)')'s*>> structure accepted1 - repl nr ',
+ & list(1)
+ else
+ if (iprint.gt.1)
+ & write(iout,'(a,i3)')
+ & 's*>> structure accepted1 - would repl nr ',list(1)
+ endif
+ icomp=9
+ if (.not. modif) goto 1106
+ j=list(1)
+ enetbss(j)=energyx
+ do i=1,nvar
+ coordss(i,j)=x(i)
+ enddo
+ do j=2,nlist
+ if (iprint.gt.1) write(iout,'(i3,$)')list(j)
+ do kk=list(j)+1,nlist
+ enetbss(kk-1)=enetbss(kk)
+ do i=1,nvar
+ coordss(i,kk-1)=coordss(i,kk)
+ enddo
+ enddo
+ enddo
+ if (iprint.gt.1) write(iout,*)
+ go to 1106
+ endif
+ if(n_thr.lt.num_thread_save) then
+ icomp=1
+ if (modif) then
+ if (iprint.gt.1)
+ & write(iout,*)'s*>> structure accepted - add with nr ',n_thr+1
+ else
+ if (iprint.gt.1)
+ & write(iout,*)'s*>> structure accepted - would add with nr ',
+ & n_thr+1
+ goto 1106
+ endif
+ n_thr=n_thr+1
+ enetbss(n_thr)=energyx
+ do i=1,nvar
+ coordss(i,n_thr)=x(i)
+ enddo
+ else
+ if(j.eq.0) then
+ if (iprint.gt.1)
+ & write(iout,*)'s*>> structure rejected - too high energy'
+ icomp=2
+ go to 1106
+ end if
+ icomp=3
+ if (modif) then
+ if (iprint.gt.1)
+ & write(iout,*)'s*>> structure accepted - repl nr ',j
+ else
+ if (iprint.gt.1)
+ & write(iout,*)'s*>> structure accepted - would repl nr ',j
+ goto 1106
+ endif
+ enetbss(j)=energyx
+ do i=1,nvar
+ coordss(i,j)=x(i)
+ enddo
+ end if
+
+1106 continue
+ return
+ end
--- /dev/null
+#include <stdio.h>
+#include <sys/utsname.h>
+#include <sys/types.h>
+#include <time.h>
+#include <string.h>
+
+main()
+{
+FILE *in, *in1, *out;
+int i,j,k,iv1,iv2,iv3;
+char *p1,buf[500],buf1[500],buf2[100],buf3[100];
+struct utsname Name;
+time_t Tp;
+
+in=fopen("cinfo.f","r");
+out=fopen("cinfo.f.new","w");
+if (fgets(buf,498,in) != NULL)
+ fprintf(out,"C DO NOT EDIT THIS FILE - IT HAS BEEN GENERATED BY COMPINFO.C\n");
+if (fgets(buf,498,in) != NULL)
+ sscanf(&buf[1],"%d %d %d",&iv1,&iv2,&iv3);
+iv3++;
+fprintf(out,"C %d %d %d\n",iv1,iv2,iv3);
+fprintf(out," subroutine cinfo\n");
+fprintf(out," include 'COMMON.IOUNITS'\n");
+fprintf(out," write(iout,*)'++++ Compile info ++++'\n");
+fprintf(out," write(iout,*)'Version %d.%-d build %d'\n",iv1,iv2,iv3);
+uname(&Name);
+time(&Tp);
+system("whoami > tmptmp");
+in1=fopen("tmptmp","r");
+if (fscanf(in1,"%s",buf1) != EOF)
+{
+p1=ctime(&Tp);
+p1[strlen(p1)-1]='\0';
+fprintf(out," write(iout,*)'compiled %s'\n",p1);
+fprintf(out," write(iout,*)'compiled by %s@%s'\n",buf1,Name.nodename);
+fprintf(out," write(iout,*)'OS name: %s '\n",Name.sysname);
+fprintf(out," write(iout,*)'OS release: %s '\n",Name.release);
+fprintf(out," write(iout,*)'OS version:',\n");
+fprintf(out," & ' %s '\n",Name.version);
+fprintf(out," write(iout,*)'flags:'\n");
+}
+system("rm tmptmp");
+fclose(in1);
+in1=fopen("Makefile","r");
+while(fgets(buf,498,in1) != NULL)
+ {
+ if((p1=strchr(buf,'=')) != NULL && buf[0] != '#')
+ {
+ buf[strlen(buf)-1]='\0';
+ if(strlen(buf) > 49)
+ {
+ buf[47]='\0';
+ strcat(buf,"...");
+ }
+ else
+ {
+ while(buf[strlen(buf)-1]=='\\')
+ {
+ strcat(buf,"\\");
+ fprintf(out," write(iout,*)'%s'\n",buf);
+ if (fgets(buf,498,in1) != NULL)
+ buf[strlen(buf)-1]='\0';
+ if(strlen(buf) > 49)
+ {
+ buf[47]='\0';
+ strcat(buf,"...");
+ }
+ }
+ }
+
+ fprintf(out," write(iout,*)'%s'\n",buf);
+ }
+ }
+fprintf(out," write(iout,*)'++++ End of compile info ++++'\n");
+fprintf(out," return\n");
+fprintf(out," end\n");
+fclose(out);
+fclose(in1);
+fclose(in);
+system("mv cinfo.f.new cinfo.f");
+}
--- /dev/null
+ subroutine contact(lprint,ncont,icont,co)
+ implicit real*8 (a-h,o-z)
+ 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
+ do i=nnt+kkk,nct
+ iti=itype(i)
+ do j=nnt,i-kkk
+ itj=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
+ co = 0.0d0
+ do i=1,ncont
+ co = co + dfloat(iabs(icont(1,i)-icont(2,i)))
+ enddo
+ co = co / (nres*ncont)
+ return
+ end
+c----------------------------------------------------------------------------
+ double precision function contact_fract(ncont,ncont_ref,
+ & icont,icont_ref)
+ implicit real*8 (a-h,o-z)
+ 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
+c----------------------------------------------------------------------------
+ double precision function contact_fract_nn(ncont,ncont_ref,
+ & icont,icont_ref)
+ implicit real*8 (a-h,o-z)
+ 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_nn=dfloat(ncont-nmatch)/dfloat(ncont)
+ return
+ end
+c----------------------------------------------------------------------------
+ subroutine hairpin(lprint,nharp,iharp)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.FFIELD'
+ include 'COMMON.NAMES'
+ integer ncont,icont(2,maxcont)
+ integer nharp,iharp(4,maxres/3)
+ logical lprint,not_done
+ real*8 rcomp /6.0d0/
+ ncont=0
+ kkk=0
+c print *,'nnt=',nnt,' nct=',nct
+ do i=nnt,nct-3
+ do k=1,3
+ c(k,2*nres+1)=0.5d0*(c(k,i)+c(k,i+1))
+ enddo
+ do j=i+2,nct-1
+ do k=1,3
+ c(k,2*nres+2)=0.5d0*(c(k,j)+c(k,j+1))
+ enddo
+ if (dist(2*nres+1,2*nres+2).lt.rcomp) then
+ ncont=ncont+1
+ icont(1,ncont)=i
+ icont(2,ncont)=j
+ endif
+ enddo
+ enddo
+ if (lprint) then
+ write (iout,'(a)') 'PP contact map:'
+ do i=1,ncont
+ i1=icont(1,i)
+ i2=icont(2,i)
+ it1=itype(i1)
+ it2=itype(i2)
+ write (iout,'(i3,2x,a,i4,2x,a,i4)')
+ & i,restyp(it1),i1,restyp(it2),i2
+ enddo
+ endif
+c finding hairpins
+ nharp=0
+ do i=1,ncont
+ i1=icont(1,i)
+ j1=icont(2,i)
+ if (j1.eq.i1+2 .and. i1.gt.nnt .and. j1.lt.nct) then
+c write (iout,*) "found turn at ",i1,j1
+ ii1=i1
+ jj1=j1
+ not_done=.true.
+ do while (not_done)
+ i1=i1-1
+ j1=j1+1
+ do j=1,ncont
+ if (i1.eq.icont(1,j) .and. j1.eq.icont(2,j)) goto 10
+ enddo
+ not_done=.false.
+ 10 continue
+c write (iout,*) i1,j1,not_done
+ enddo
+ i1=i1+1
+ j1=j1-1
+ if (j1-i1.gt.4) then
+ nharp=nharp+1
+ iharp(1,nharp)=i1
+ iharp(2,nharp)=j1
+ iharp(3,nharp)=ii1
+ iharp(4,nharp)=jj1
+c write (iout,*)'nharp',nharp,' iharp',(iharp(k,nharp),k=1,4)
+ endif
+ endif
+ enddo
+c do i=1,nharp
+c write (iout,*)'i',i,' iharp',(iharp(k,i),k=1,4)
+c enddo
+ if (lprint) then
+ write (iout,*) "Hairpins:"
+ do i=1,nharp
+ i1=iharp(1,i)
+ j1=iharp(2,i)
+ ii1=iharp(3,i)
+ jj1=iharp(4,i)
+ write (iout,*)
+ write (iout,'(20(a,i3,1x))') (restyp(itype(k)),k,k=i1,ii1)
+ write (iout,'(20(a,i3,1x))') (restyp(itype(k)),k,k=j1,jj1,-1)
+c do k=jj1,j1,-1
+c write (iout,'(a,i3,$)') restyp(itype(k)),k
+c enddo
+ enddo
+ endif
+ return
+ end
+c----------------------------------------------------------------------------
+
--- /dev/null
+ subroutine geom_to_var(n,x)
+C
+C Transfer the geometry parameters to the variable array.
+C The positions of variables are as follows:
+C 1. Virtual-bond torsional angles: 1 thru nres-3
+C 2. Virtual-bond valence angles: nres-2 thru 2*nres-5
+C 3. The polar angles alpha of local SC orientation: 2*nres-4 thru
+C 2*nres-4+nside
+C 4. The torsional angles omega of SC orientation: 2*nres-4+nside+1
+C thru 2*nre-4+2*nside
+C
+ implicit real*8 (a-h,o-z)
+ 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
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.VAR'
+ include 'COMMON.CHAIN'
+ include 'COMMON.GEO'
+ include 'COMMON.IOUNITS'
+ dimension x(n)
+ logical change,reduce
+ change=reduce(x)
+ if (n.gt.nphi+ntheta) then
+ do i=1,nside
+ ii=ialph(i,2)
+ alph(ii)=x(nphi+ntheta+i)
+ omeg(ii)=pinorm(x(nphi+ntheta+nside+i))
+ enddo
+ endif
+ do i=4,nres
+ phi(i)=x(i-3)
+ enddo
+ if (n.eq.nphi) return
+ do i=3,nres
+ theta(i)=x(i-2+nphi)
+ if (theta(i).eq.pi) theta(i)=0.99d0*pi
+ x(i-2+nphi)=theta(i)
+ enddo
+ return
+ end
+c-------------------------------------------------------------------------
+ logical function convert_side(alphi,omegi)
+ implicit none
+ double precision alphi,omegi
+ double precision pinorm
+ include 'COMMON.GEO'
+ convert_side=.false.
+C Apply periodicity restrictions.
+ if (alphi.gt.pi) then
+ alphi=dwapi-alphi
+ omegi=pinorm(omegi+pi)
+ convert_side=.true.
+ endif
+ return
+ end
+c-------------------------------------------------------------------------
+ logical function reduce(x)
+C
+C Apply periodic restrictions to variables.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.VAR'
+ include 'COMMON.CHAIN'
+ include 'COMMON.GEO'
+ logical zm,zmiana,convert_side
+ dimension x(nvar)
+ zmiana=.false.
+ do i=4,nres
+ x(i-3)=pinorm(x(i-3))
+ enddo
+ if (nvar.gt.nphi+ntheta) then
+ do i=1,nside
+ ii=nphi+ntheta+i
+ iii=ii+nside
+ x(ii)=thetnorm(x(ii))
+ x(iii)=pinorm(x(iii))
+C Apply periodic restrictions.
+ zm=convert_side(x(ii),x(iii))
+ zmiana=zmiana.or.zm
+ enddo
+ endif
+ if (nvar.eq.nphi) return
+ do i=3,nres
+ ii=i-2+nphi
+ iii=i-3
+ x(ii)=dmod(x(ii),dwapi)
+C Apply periodic restrictions.
+ if (x(ii).gt.pi) then
+ zmiana=.true.
+ x(ii)=dwapi-x(ii)
+ if (iii.gt.0) x(iii)=pinorm(x(iii)+pi)
+ if (i.lt.nres) x(iii+1)=pinorm(x(iii+1)+pi)
+ ii=ialph(i-1,1)
+ if (ii.gt.0) then
+ x(ii)=dmod(pi-x(ii),dwapi)
+ x(ii+nside)=pinorm(-x(ii+nside))
+ zm=convert_side(x(ii),x(ii+nside))
+ endif
+ else if (x(ii).lt.-pi) then
+ zmiana=.true.
+ x(ii)=dwapi+x(ii)
+ ii=ialph(i-1,1)
+ if (ii.gt.0) then
+ x(ii)=dmod(pi-x(ii),dwapi)
+ x(ii+nside)=pinorm(-pi-x(ii+nside))
+ zm=convert_side(x(ii),x(ii+nside))
+ endif
+ else if (x(ii).lt.0.0d0) then
+ zmiana=.true.
+ x(ii)=-x(ii)
+ if (iii.gt.0) x(iii)=pinorm(x(iii)+pi)
+ if (i.lt.nres) x(iii+1)=pinorm(x(iii+1)+pi)
+ ii=ialph(i-1,1)
+ if (ii.gt.0) then
+ x(ii+nside)=pinorm(-x(ii+nside))
+ zm=convert_side(x(ii),x(ii+nside))
+ endif
+ endif
+ enddo
+ reduce=zmiana
+ return
+ end
+c--------------------------------------------------------------------------
+ double precision function thetnorm(x)
+C This function puts x within [0,2Pi].
+ implicit none
+ double precision x,xx
+ include 'COMMON.GEO'
+ xx=dmod(x,dwapi)
+ if (xx.lt.0.0d0) xx=xx+dwapi
+ if (xx.gt.0.9999d0*pi) xx=0.9999d0*pi
+ thetnorm=xx
+ return
+ end
+C--------------------------------------------------------------------
+ subroutine var_to_geom_restr(n,xx)
+C
+C Update geometry parameters according to the variable array.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.VAR'
+ include 'COMMON.CHAIN'
+ include 'COMMON.GEO'
+ include 'COMMON.IOUNITS'
+ dimension x(maxvar),xx(maxvar)
+ logical change,reduce
+
+ call xx2x(x,xx)
+ change=reduce(x)
+ do i=1,nside
+ ii=ialph(i,2)
+ alph(ii)=x(nphi+ntheta+i)
+ omeg(ii)=pinorm(x(nphi+ntheta+nside+i))
+ enddo
+ do i=4,nres
+ phi(i)=x(i-3)
+ enddo
+ do i=3,nres
+ theta(i)=x(i-2+nphi)
+ if (theta(i).eq.pi) theta(i)=0.99d0*pi
+ x(i-2+nphi)=theta(i)
+ enddo
+ return
+ end
+c-------------------------------------------------------------------------
--- /dev/null
+ subroutine assst(iv, liv, lv, v)
+c
+c *** assess candidate step (***sol version 2.3) ***
+c
+ integer liv, l
+ integer iv(liv)
+ double precision v(lv)
+c
+c *** purpose ***
+c
+c this subroutine is called by an unconstrained minimization
+c routine to assess the next candidate step. it may recommend one
+c of several courses of action, such as accepting the step, recom-
+c puting it using the same or a new quadratic model, or halting due
+c to convergence or false convergence. see the return code listing
+c below.
+c
+c-------------------------- parameter usage --------------------------
+c
+c iv (i/o) integer parameter and scratch vector -- see description
+c below of iv values referenced.
+c liv (in) length of iv array.
+c lv (in) length of v array.
+c v (i/o) real parameter and scratch vector -- see description
+c below of v values referenced.
+c
+c *** iv values referenced ***
+c
+c iv(irc) (i/o) on input for the first step tried in a new iteration,
+c iv(irc) should be set to 3 or 4 (the value to which it is
+c set when step is definitely to be accepted). on input
+c after step has been recomputed, iv(irc) should be
+c unchanged since the previous return of assst.
+c on output, iv(irc) is a return code having one of the
+c following values...
+c 1 = switch models or try smaller step.
+c 2 = switch models or accept step.
+c 3 = accept step and determine v(radfac) by gradient
+c tests.
+c 4 = accept step, v(radfac) has been determined.
+c 5 = recompute step (using the same model).
+c 6 = recompute step with radius = v(lmaxs) but do not
+c evaulate the objective function.
+c 7 = x-convergence (see v(xctol)).
+c 8 = relative function convergence (see v(rfctol)).
+c 9 = both x- and relative function convergence.
+c 10 = absolute function convergence (see v(afctol)).
+c 11 = singular convergence (see v(lmaxs)).
+c 12 = false convergence (see v(xftol)).
+c 13 = iv(irc) was out of range on input.
+c return code i has precdence over i+1 for i = 9, 10, 11.
+c iv(mlstgd) (i/o) saved value of iv(model).
+c iv(model) (i/o) on input, iv(model) should be an integer identifying
+c the current quadratic model of the objective function.
+c if a previous step yielded a better function reduction,
+c then iv(model) will be set to iv(mlstgd) on output.
+c iv(nfcall) (in) invocation count for the objective function.
+c iv(nfgcal) (i/o) value of iv(nfcall) at step that gave the biggest
+c function reduction this iteration. iv(nfgcal) remains
+c unchanged until a function reduction is obtained.
+c iv(radinc) (i/o) the number of radius increases (or minus the number
+c of decreases) so far this iteration.
+c iv(restor) (out) set to 1 if v(f) has been restored and x should be
+c restored to its initial value, to 2 if x should be saved,
+c to 3 if x should be restored from the saved value, and to
+c 0 otherwise.
+c iv(stage) (i/o) count of the number of models tried so far in the
+c current iteration.
+c iv(stglim) (in) maximum number of models to consider.
+c iv(switch) (out) set to 0 unless a new model is being tried and it
+c gives a smaller function value than the previous model,
+c in which case assst sets iv(switch) = 1.
+c iv(toobig) (in) is nonzero if step was too big (e.g. if it caused
+c overflow).
+c iv(xirc) (i/o) value that iv(irc) would have in the absence of
+c convergence, false convergence, and oversized steps.
+c
+c *** v values referenced ***
+c
+c v(afctol) (in) absolute function convergence tolerance. if the
+c absolute value of the current function value v(f) is less
+c than v(afctol), then assst returns with iv(irc) = 10.
+c v(decfac) (in) factor by which to decrease radius when iv(toobig) is
+c nonzero.
+c v(dstnrm) (in) the 2-norm of d*step.
+c v(dstsav) (i/o) value of v(dstnrm) on saved step.
+c v(dst0) (in) the 2-norm of d times the newton step (when defined,
+c i.e., for v(nreduc) .ge. 0).
+c v(f) (i/o) on both input and output, v(f) is the objective func-
+c tion value at x. if x is restored to a previous value,
+c then v(f) is restored to the corresponding value.
+c v(fdif) (out) the function reduction v(f0) - v(f) (for the output
+c value of v(f) if an earlier step gave a bigger function
+c decrease, and for the input value of v(f) otherwise).
+c v(flstgd) (i/o) saved value of v(f).
+c v(f0) (in) objective function value at start of iteration.
+c v(gtslst) (i/o) value of v(gtstep) on saved step.
+c v(gtstep) (in) inner product between step and gradient.
+c v(incfac) (in) minimum factor by which to increase radius.
+c v(lmaxs) (in) maximum reasonable step size (and initial step bound).
+c if the actual function decrease is no more than twice
+c what was predicted, if a return with iv(irc) = 7, 8, 9,
+c or 10 does not occur, if v(dstnrm) .gt. v(lmaxs), and if
+c v(preduc) .le. v(sctol) * abs(v(f0)), then assst re-
+c turns with iv(irc) = 11. if so doing appears worthwhile,
+c then assst repeats this test with v(preduc) computed for
+c a step of length v(lmaxs) (by a return with iv(irc) = 6).
+c v(nreduc) (i/o) function reduction predicted by quadratic model for
+c newton step. if assst is called with iv(irc) = 6, i.e.,
+c if v(preduc) has been computed with radius = v(lmaxs) for
+c use in the singular convervence test, then v(nreduc) is
+c set to -v(preduc) before the latter is restored.
+c v(plstgd) (i/o) value of v(preduc) on saved step.
+c v(preduc) (i/o) function reduction predicted by quadratic model for
+c current step.
+c v(radfac) (out) factor to be used in determining the new radius,
+c which should be v(radfac)*dst, where dst is either the
+c output value of v(dstnrm) or the 2-norm of
+c diag(newd)*step for the output value of step and the
+c updated version, newd, of the scale vector d. for
+c iv(irc) = 3, v(radfac) = 1.0 is returned.
+c v(rdfcmn) (in) minimum value for v(radfac) in terms of the input
+c value of v(dstnrm) -- suggested value = 0.1.
+c v(rdfcmx) (in) maximum value for v(radfac) -- suggested value = 4.0.
+c v(reldx) (in) scaled relative change in x caused by step, computed
+c (e.g.) by function reldst as
+c max (d(i)*abs(x(i)-x0(i)), 1 .le. i .le. p) /
+c max (d(i)*(abs(x(i))+abs(x0(i))), 1 .le. i .le. p).
+c v(rfctol) (in) relative function convergence tolerance. if the
+c actual function reduction is at most twice what was pre-
+c dicted and v(nreduc) .le. v(rfctol)*abs(v(f0)), then
+c assst returns with iv(irc) = 8 or 9.
+c v(stppar) (in) marquardt parameter -- 0 means full newton step.
+c v(tuner1) (in) tuning constant used to decide if the function
+c reduction was much less than expected. suggested
+c value = 0.1.
+c v(tuner2) (in) tuning constant used to decide if the function
+c reduction was large enough to accept step. suggested
+c value = 10**-4.
+c v(tuner3) (in) tuning constant used to decide if the radius
+c should be increased. suggested value = 0.75.
+c v(xctol) (in) x-convergence criterion. if step is a newton step
+c (v(stppar) = 0) having v(reldx) .le. v(xctol) and giving
+c at most twice the predicted function decrease, then
+c assst returns iv(irc) = 7 or 9.
+c v(xftol) (in) false convergence tolerance. if step gave no or only
+c a small function decrease and v(reldx) .le. v(xftol),
+c then assst returns with iv(irc) = 12.
+c
+c------------------------------- notes -------------------------------
+c
+c *** application and usage restrictions ***
+c
+c this routine is called as part of the nl2sol (nonlinear
+c least-squares) package. it may be used in any unconstrained
+c minimization solver that uses dogleg, goldfeld-quandt-trotter,
+c or levenberg-marquardt steps.
+c
+c *** algorithm notes ***
+c
+c see (1) for further discussion of the assessing and model
+c switching strategies. while nl2sol considers only two models,
+c assst is designed to handle any number of models.
+c
+c *** usage notes ***
+c
+c on the first call of an iteration, only the i/o variables
+c step, x, iv(irc), iv(model), v(f), v(dstnrm), v(gtstep), and
+c v(preduc) need have been initialized. between calls, no i/o
+c values execpt step, x, iv(model), v(f) and the stopping toler-
+c ances should be changed.
+c after a return for convergence or false convergence, one can
+c change the stopping tolerances and call assst again, in which
+c case the stopping tests will be repeated.
+c
+c *** references ***
+c
+c (1) dennis, j.e., jr., gay, d.m., and welsch, r.e. (1981),
+c an adaptive nonlinear least-squares algorithm,
+c acm trans. math. software, vol. 7, no. 3.
+c
+c (2) powell, m.j.d. (1970) a fortran subroutine for solving
+c systems of nonlinear algebraic equations, in numerical
+c methods for nonlinear algebraic equations, edited by
+c p. rabinowitz, gordon and breach, london.
+c
+c *** history ***
+c
+c john dennis designed much of this routine, starting with
+c ideas in (2). roy welsch suggested the model switching strategy.
+c david gay and stephen peters cast this subroutine into a more
+c portable form (winter 1977), and david gay cast it into its
+c present form (fall 1978).
+c
+c *** general ***
+c
+c this subroutine was written in connection with research
+c supported by the national science foundation under grants
+c mcs-7600324, dcr75-10143, 76-14311dss, mcs76-11989, and
+c mcs-7906671.
+c
+c------------------------ external quantities ------------------------
+c
+c *** no external functions and subroutines ***
+c
+c *** intrinsic functions ***
+c/+
+ double precision dabs, dmax1
+c/
+c *** no common blocks ***
+c
+c-------------------------- local variables --------------------------
+c
+ logical goodx
+ integer i, nfc
+ double precision emax, emaxs, gts, rfac1, xmax
+ double precision half, one, onep2, two, zero
+c
+c *** subscripts for iv and v ***
+c
+ integer afctol, decfac, dstnrm, dstsav, dst0, f, fdif, flstgd, f0,
+ 1 gtslst, gtstep, incfac, irc, lmaxs, mlstgd, model, nfcall,
+ 2 nfgcal, nreduc, plstgd, preduc, radfac, radinc, rdfcmn,
+ 3 rdfcmx, reldx, restor, rfctol, sctol, stage, stglim,
+ 4 stppar, switch, toobig, tuner1, tuner2, tuner3, xctol,
+ 5 xftol, xirc
+c
+c *** data initializations ***
+c
+c/6
+c data half/0.5d+0/, one/1.d+0/, onep2/1.2d+0/, two/2.d+0/,
+c 1 zero/0.d+0/
+c/7
+ parameter (half=0.5d+0, one=1.d+0, onep2=1.2d+0, two=2.d+0,
+ 1 zero=0.d+0)
+c/
+c
+c/6
+c data irc/29/, mlstgd/32/, model/5/, nfcall/6/, nfgcal/7/,
+c 1 radinc/8/, restor/9/, stage/10/, stglim/11/, switch/12/,
+c 2 toobig/2/, xirc/13/
+c/7
+ parameter (irc=29, mlstgd=32, model=5, nfcall=6, nfgcal=7,
+ 1 radinc=8, restor=9, stage=10, stglim=11, switch=12,
+ 2 toobig=2, xirc=13)
+c/
+c/6
+c data afctol/31/, decfac/22/, dstnrm/2/, dst0/3/, dstsav/18/,
+c 1 f/10/, fdif/11/, flstgd/12/, f0/13/, gtslst/14/, gtstep/4/,
+c 2 incfac/23/, lmaxs/36/, nreduc/6/, plstgd/15/, preduc/7/,
+c 3 radfac/16/, rdfcmn/24/, rdfcmx/25/, reldx/17/, rfctol/32/,
+c 4 sctol/37/, stppar/5/, tuner1/26/, tuner2/27/, tuner3/28/,
+c 5 xctol/33/, xftol/34/
+c/7
+ parameter (afctol=31, decfac=22, dstnrm=2, dst0=3, dstsav=18,
+ 1 f=10, fdif=11, flstgd=12, f0=13, gtslst=14, gtstep=4,
+ 2 incfac=23, lmaxs=36, nreduc=6, plstgd=15, preduc=7,
+ 3 radfac=16, rdfcmn=24, rdfcmx=25, reldx=17, rfctol=32,
+ 4 sctol=37, stppar=5, tuner1=26, tuner2=27, tuner3=28,
+ 5 xctol=33, xftol=34)
+c/
+c
+c+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++
+c
+ nfc = iv(nfcall)
+ iv(switch) = 0
+ iv(restor) = 0
+ rfac1 = one
+ goodx = .true.
+ i = iv(irc)
+ if (i .ge. 1 .and. i .le. 12)
+ 1 go to (20,30,10,10,40,280,220,220,220,220,220,170), i
+ iv(irc) = 13
+ go to 999
+c
+c *** initialize for new iteration ***
+c
+ 10 iv(stage) = 1
+ iv(radinc) = 0
+ v(flstgd) = v(f0)
+ if (iv(toobig) .eq. 0) go to 110
+ iv(stage) = -1
+ iv(xirc) = i
+ go to 60
+c
+c *** step was recomputed with new model or smaller radius ***
+c *** first decide which ***
+c
+ 20 if (iv(model) .ne. iv(mlstgd)) go to 30
+c *** old model retained, smaller radius tried ***
+c *** do not consider any more new models this iteration ***
+ iv(stage) = iv(stglim)
+ iv(radinc) = -1
+ go to 110
+c
+c *** a new model is being tried. decide whether to keep it. ***
+c
+ 30 iv(stage) = iv(stage) + 1
+c
+c *** now we add the possibiltiy that step was recomputed with ***
+c *** the same model, perhaps because of an oversized step. ***
+c
+ 40 if (iv(stage) .gt. 0) go to 50
+c
+c *** step was recomputed because it was too big. ***
+c
+ if (iv(toobig) .ne. 0) go to 60
+c
+c *** restore iv(stage) and pick up where we left off. ***
+c
+ iv(stage) = -iv(stage)
+ i = iv(xirc)
+ go to (20, 30, 110, 110, 70), i
+c
+ 50 if (iv(toobig) .eq. 0) go to 70
+c
+c *** handle oversize step ***
+c
+ if (iv(radinc) .gt. 0) go to 80
+ iv(stage) = -iv(stage)
+ iv(xirc) = iv(irc)
+c
+ 60 v(radfac) = v(decfac)
+ iv(radinc) = iv(radinc) - 1
+ iv(irc) = 5
+ iv(restor) = 1
+ go to 999
+c
+ 70 if (v(f) .lt. v(flstgd)) go to 110
+c
+c *** the new step is a loser. restore old model. ***
+c
+ if (iv(model) .eq. iv(mlstgd)) go to 80
+ iv(model) = iv(mlstgd)
+ iv(switch) = 1
+c
+c *** restore step, etc. only if a previous step decreased v(f).
+c
+ 80 if (v(flstgd) .ge. v(f0)) go to 110
+ iv(restor) = 1
+ v(f) = v(flstgd)
+ v(preduc) = v(plstgd)
+ v(gtstep) = v(gtslst)
+ if (iv(switch) .eq. 0) rfac1 = v(dstnrm) / v(dstsav)
+ v(dstnrm) = v(dstsav)
+ nfc = iv(nfgcal)
+ goodx = .false.
+c
+ 110 v(fdif) = v(f0) - v(f)
+ if (v(fdif) .gt. v(tuner2) * v(preduc)) go to 140
+ if(iv(radinc).gt.0) go to 140
+c
+c *** no (or only a trivial) function decrease
+c *** -- so try new model or smaller radius
+c
+ if (v(f) .lt. v(f0)) go to 120
+ iv(mlstgd) = iv(model)
+ v(flstgd) = v(f)
+ v(f) = v(f0)
+ iv(restor) = 1
+ go to 130
+ 120 iv(nfgcal) = nfc
+ 130 iv(irc) = 1
+ if (iv(stage) .lt. iv(stglim)) go to 160
+ iv(irc) = 5
+ iv(radinc) = iv(radinc) - 1
+ go to 160
+c
+c *** nontrivial function decrease achieved ***
+c
+ 140 iv(nfgcal) = nfc
+ rfac1 = one
+ v(dstsav) = v(dstnrm)
+ if (v(fdif) .gt. v(preduc)*v(tuner1)) go to 190
+c
+c *** decrease was much less than predicted -- either change models
+c *** or accept step with decreased radius.
+c
+ if (iv(stage) .ge. iv(stglim)) go to 150
+c *** consider switching models ***
+ iv(irc) = 2
+ go to 160
+c
+c *** accept step with decreased radius ***
+c
+ 150 iv(irc) = 4
+c
+c *** set v(radfac) to fletcher*s decrease factor ***
+c
+ 160 iv(xirc) = iv(irc)
+ emax = v(gtstep) + v(fdif)
+ v(radfac) = half * rfac1
+ if (emax .lt. v(gtstep)) v(radfac) = rfac1 * dmax1(v(rdfcmn),
+ 1 half * v(gtstep)/emax)
+c
+c *** do false convergence test ***
+c
+ 170 if (v(reldx) .le. v(xftol)) go to 180
+ iv(irc) = iv(xirc)
+ if (v(f) .lt. v(f0)) go to 200
+ go to 230
+c
+ 180 iv(irc) = 12
+ go to 240
+c
+c *** handle good function decrease ***
+c
+ 190 if (v(fdif) .lt. (-v(tuner3) * v(gtstep))) go to 210
+c
+c *** increasing radius looks worthwhile. see if we just
+c *** recomputed step with a decreased radius or restored step
+c *** after recomputing it with a larger radius.
+c
+ if (iv(radinc) .lt. 0) go to 210
+ if (iv(restor) .eq. 1) go to 210
+c
+c *** we did not. try a longer step unless this was a newton
+c *** step.
+c
+ v(radfac) = v(rdfcmx)
+ gts = v(gtstep)
+ if (v(fdif) .lt. (half/v(radfac) - one) * gts)
+ 1 v(radfac) = dmax1(v(incfac), half*gts/(gts + v(fdif)))
+ iv(irc) = 4
+ if (v(stppar) .eq. zero) go to 230
+ if (v(dst0) .ge. zero .and. (v(dst0) .lt. two*v(dstnrm)
+ 1 .or. v(nreduc) .lt. onep2*v(fdif))) go to 230
+c *** step was not a newton step. recompute it with
+c *** a larger radius.
+ iv(irc) = 5
+ iv(radinc) = iv(radinc) + 1
+c
+c *** save values corresponding to good step ***
+c
+ 200 v(flstgd) = v(f)
+ iv(mlstgd) = iv(model)
+ if (iv(restor) .ne. 1) iv(restor) = 2
+ v(dstsav) = v(dstnrm)
+ iv(nfgcal) = nfc
+ v(plstgd) = v(preduc)
+ v(gtslst) = v(gtstep)
+ go to 230
+c
+c *** accept step with radius unchanged ***
+c
+ 210 v(radfac) = one
+ iv(irc) = 3
+ go to 230
+c
+c *** come here for a restart after convergence ***
+c
+ 220 iv(irc) = iv(xirc)
+ if (v(dstsav) .ge. zero) go to 240
+ iv(irc) = 12
+ go to 240
+c
+c *** perform convergence tests ***
+c
+ 230 iv(xirc) = iv(irc)
+ 240 if (iv(restor) .eq. 1 .and. v(flstgd) .lt. v(f0)) iv(restor) = 3
+ if (half * v(fdif) .gt. v(preduc)) go to 999
+ emax = v(rfctol) * dabs(v(f0))
+ emaxs = v(sctol) * dabs(v(f0))
+ if (v(dstnrm) .gt. v(lmaxs) .and. v(preduc) .le. emaxs)
+ 1 iv(irc) = 11
+ if (v(dst0) .lt. zero) go to 250
+ i = 0
+ if ((v(nreduc) .gt. zero .and. v(nreduc) .le. emax) .or.
+ 1 (v(nreduc) .eq. zero. and. v(preduc) .eq. zero)) i = 2
+ if (v(stppar) .eq. zero .and. v(reldx) .le. v(xctol)
+ 1 .and. goodx) i = i + 1
+ if (i .gt. 0) iv(irc) = i + 6
+c
+c *** consider recomputing step of length v(lmaxs) for singular
+c *** convergence test.
+c
+ 250 if (iv(irc) .gt. 5 .and. iv(irc) .ne. 12) go to 999
+ if (v(dstnrm) .gt. v(lmaxs)) go to 260
+ if (v(preduc) .ge. emaxs) go to 999
+ if (v(dst0) .le. zero) go to 270
+ if (half * v(dst0) .le. v(lmaxs)) go to 999
+ go to 270
+ 260 if (half * v(dstnrm) .le. v(lmaxs)) go to 999
+ xmax = v(lmaxs) / v(dstnrm)
+ if (xmax * (two - xmax) * v(preduc) .ge. emaxs) go to 999
+ 270 if (v(nreduc) .lt. zero) go to 290
+c
+c *** recompute v(preduc) for use in singular convergence test ***
+c
+ v(gtslst) = v(gtstep)
+ v(dstsav) = v(dstnrm)
+ if (iv(irc) .eq. 12) v(dstsav) = -v(dstsav)
+ v(plstgd) = v(preduc)
+ i = iv(restor)
+ iv(restor) = 2
+ if (i .eq. 3) iv(restor) = 0
+ iv(irc) = 6
+ go to 999
+c
+c *** perform singular convergence test with recomputed v(preduc) ***
+c
+ 280 v(gtstep) = v(gtslst)
+ v(dstnrm) = dabs(v(dstsav))
+ iv(irc) = iv(xirc)
+ if (v(dstsav) .le. zero) iv(irc) = 12
+ v(nreduc) = -v(preduc)
+ v(preduc) = v(plstgd)
+ iv(restor) = 3
+ 290 if (-v(nreduc) .le. v(sctol) * dabs(v(f0))) iv(irc) = 11
+c
+ 999 return
+c
+c *** last card of assst follows ***
+ end
+ subroutine deflt(alg, iv, liv, lv, v)
+c
+c *** supply ***sol (version 2.3) default values to iv and v ***
+c
+c *** alg = 1 means regression constants.
+c *** alg = 2 means general unconstrained optimization constants.
+c
+ integer liv, l
+ integer alg, iv(liv)
+ double precision v(lv)
+c
+ external imdcon, vdflt
+ integer imdcon
+c imdcon... returns machine-dependent integer constants.
+c vdflt.... provides default values to v.
+c
+ integer miv, m
+ integer miniv(2), minv(2)
+c
+c *** subscripts for iv ***
+c
+ integer algsav, covprt, covreq, dtype, hc, ierr, inith, inits,
+ 1 ipivot, ivneed, lastiv, lastv, lmat, mxfcal, mxiter,
+ 2 nfcov, ngcov, nvdflt, outlev, parprt, parsav, perm,
+ 3 prunit, qrtyp, rdreq, rmat, solprt, statpr, vneed,
+ 4 vsave, x0prt
+c
+c *** iv subscript values ***
+c
+c/6
+c data algsav/51/, covprt/14/, covreq/15/, dtype/16/, hc/71/,
+c 1 ierr/75/, inith/25/, inits/25/, ipivot/76/, ivneed/3/,
+c 2 lastiv/44/, lastv/45/, lmat/42/, mxfcal/17/, mxiter/18/,
+c 3 nfcov/52/, ngcov/53/, nvdflt/50/, outlev/19/, parprt/20/,
+c 4 parsav/49/, perm/58/, prunit/21/, qrtyp/80/, rdreq/57/,
+c 5 rmat/78/, solprt/22/, statpr/23/, vneed/4/, vsave/60/,
+c 6 x0prt/24/
+c/7
+ parameter (algsav=51, covprt=14, covreq=15, dtype=16, hc=71,
+ 1 ierr=75, inith=25, inits=25, ipivot=76, ivneed=3,
+ 2 lastiv=44, lastv=45, lmat=42, mxfcal=17, mxiter=18,
+ 3 nfcov=52, ngcov=53, nvdflt=50, outlev=19, parprt=20,
+ 4 parsav=49, perm=58, prunit=21, qrtyp=80, rdreq=57,
+ 5 rmat=78, solprt=22, statpr=23, vneed=4, vsave=60,
+ 6 x0prt=24)
+c/
+ data miniv(1)/80/, miniv(2)/59/, minv(1)/98/, minv(2)/71/
+c
+c------------------------------- body --------------------------------
+c
+ if (alg .lt. 1 .or. alg .gt. 2) go to 40
+ miv = miniv(alg)
+ if (liv .lt. miv) go to 20
+ mv = minv(alg)
+ if (lv .lt. mv) go to 30
+ call vdflt(alg, lv, v)
+ iv(1) = 12
+ iv(algsav) = alg
+ iv(ivneed) = 0
+ iv(lastiv) = miv
+ iv(lastv) = mv
+ iv(lmat) = mv + 1
+ iv(mxfcal) = 200
+ iv(mxiter) = 150
+ iv(outlev) = 1
+ iv(parprt) = 1
+ iv(perm) = miv + 1
+ iv(prunit) = imdcon(1)
+ iv(solprt) = 1
+ iv(statpr) = 1
+ iv(vneed) = 0
+ iv(x0prt) = 1
+c
+ if (alg .ge. 2) go to 10
+c
+c *** regression values
+c
+ iv(covprt) = 3
+ iv(covreq) = 1
+ iv(dtype) = 1
+ iv(hc) = 0
+ iv(ierr) = 0
+ iv(inits) = 0
+ iv(ipivot) = 0
+ iv(nvdflt) = 32
+ iv(parsav) = 67
+ iv(qrtyp) = 1
+ iv(rdreq) = 3
+ iv(rmat) = 0
+ iv(vsave) = 58
+ go to 999
+c
+c *** general optimization values
+c
+ 10 iv(dtype) = 0
+ iv(inith) = 1
+ iv(nfcov) = 0
+ iv(ngcov) = 0
+ iv(nvdflt) = 25
+ iv(parsav) = 47
+ go to 999
+c
+ 20 iv(1) = 15
+ go to 999
+c
+ 30 iv(1) = 16
+ go to 999
+c
+ 40 iv(1) = 67
+c
+ 999 return
+c *** last card of deflt follows ***
+ end
+ double precision function dotprd(p, x, y)
+c
+c *** return the inner product of the p-vectors x and y. ***
+c
+ integer p
+ double precision x(p), y(p)
+c
+ integer i
+ double precision one, sqteta, t, zero
+c/+
+ double precision dmax1, dabs
+c/
+ external rmdcon
+ double precision rmdcon
+c
+c *** rmdcon(2) returns a machine-dependent constant, sqteta, which
+c *** is slightly larger than the smallest positive number that
+c *** can be squared without underflowing.
+c
+c/6
+c data one/1.d+0/, sqteta/0.d+0/, zero/0.d+0/
+c/7
+ parameter (one=1.d+0, zero=0.d+0)
+ data sqteta/0.d+0/
+c/
+c
+ dotprd = zero
+ if (p .le. 0) go to 999
+crc if (sqteta .eq. zero) sqteta = rmdcon(2)
+ do 20 i = 1, p
+crc t = dmax1(dabs(x(i)), dabs(y(i)))
+crc if (t .gt. one) go to 10
+crc if (t .lt. sqteta) go to 20
+crc t = (x(i)/sqteta)*y(i)
+crc if (dabs(t) .lt. sqteta) go to 20
+ 10 dotprd = dotprd + x(i)*y(i)
+ 20 continue
+c
+ 999 return
+c *** last card of dotprd follows ***
+ end
+ subroutine itsum(d, g, iv, liv, lv, p, v, x)
+c
+c *** print iteration summary for ***sol (version 2.3) ***
+c
+c *** parameter declarations ***
+c
+ integer liv, lv, p
+ integer iv(liv)
+ double precision d(p), g(p), v(lv), x(p)
+c
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c
+c *** local variables ***
+c
+ integer alg, i, iv1, m, nf, ng, ol, pu
+c/6
+c real model1(6), model2(6)
+c/7
+ character*4 model1(6), model2(6)
+c/
+ double precision nreldf, oldf, preldf, reldf, zero
+c
+c *** intrinsic functions ***
+c/+
+ integer iabs
+ double precision dabs, dmax1
+c/
+c *** no external functions or subroutines ***
+c
+c *** subscripts for iv and v ***
+c
+ integer algsav, dstnrm, f, fdif, f0, needhd, nfcall, nfcov, ngcov,
+ 1 ngcall, niter, nreduc, outlev, preduc, prntit, prunit,
+ 2 reldx, solprt, statpr, stppar, sused, x0prt
+c
+c *** iv subscript values ***
+c
+c/6
+c data algsav/51/, needhd/36/, nfcall/6/, nfcov/52/, ngcall/30/,
+c 1 ngcov/53/, niter/31/, outlev/19/, prntit/39/, prunit/21/,
+c 2 solprt/22/, statpr/23/, sused/64/, x0prt/24/
+c/7
+ parameter (algsav=51, needhd=36, nfcall=6, nfcov=52, ngcall=30,
+ 1 ngcov=53, niter=31, outlev=19, prntit=39, prunit=21,
+ 2 solprt=22, statpr=23, sused=64, x0prt=24)
+c/
+c
+c *** v subscript values ***
+c
+c/6
+c data dstnrm/2/, f/10/, f0/13/, fdif/11/, nreduc/6/, preduc/7/,
+c 1 reldx/17/, stppar/5/
+c/7
+ parameter (dstnrm=2, f=10, f0=13, fdif=11, nreduc=6, preduc=7,
+ 1 reldx=17, stppar=5)
+c/
+c
+c/6
+c data zero/0.d+0/
+c/7
+ parameter (zero=0.d+0)
+c/
+c/6
+c data model1(1)/4h /, model1(2)/4h /, model1(3)/4h /,
+c 1 model1(4)/4h /, model1(5)/4h g /, model1(6)/4h s /,
+c 2 model2(1)/4h g /, model2(2)/4h s /, model2(3)/4hg-s /,
+c 3 model2(4)/4hs-g /, model2(5)/4h-s-g/, model2(6)/4h-g-s/
+c/7
+ data model1/' ',' ',' ',' ',' g ',' s '/,
+ 1 model2/' g ',' s ','g-s ','s-g ','-s-g','-g-s'/
+c/
+c
+c------------------------------- body --------------------------------
+c
+ pu = iv(prunit)
+ if (pu .eq. 0) go to 999
+ iv1 = iv(1)
+ if (iv1 .gt. 62) iv1 = iv1 - 51
+ ol = iv(outlev)
+ alg = iv(algsav)
+ if (iv1 .lt. 2 .or. iv1 .gt. 15) go to 370
+ if (iv1 .ge. 12) go to 120
+ if (iv1 .eq. 2 .and. iv(niter) .eq. 0) go to 390
+ if (ol .eq. 0) go to 120
+ if (iv1 .ge. 10 .and. iv(prntit) .eq. 0) go to 120
+ if (iv1 .gt. 2) go to 10
+ iv(prntit) = iv(prntit) + 1
+ if (iv(prntit) .lt. iabs(ol)) go to 999
+ 10 nf = iv(nfcall) - iabs(iv(nfcov))
+ iv(prntit) = 0
+ reldf = zero
+ preldf = zero
+ oldf = dmax1(dabs(v(f0)), dabs(v(f)))
+ if (oldf .le. zero) go to 20
+ reldf = v(fdif) / oldf
+ preldf = v(preduc) / oldf
+ 20 if (ol .gt. 0) go to 60
+c
+c *** print short summary line ***
+c
+ if (iv(needhd) .eq. 1 .and. alg .eq. 1) write(pu,30)
+ 30 format(/10h it nf,6x,1hf,7x,5hreldf,3x,6hpreldf,3x,5hreldx,
+ 1 2x,13hmodel stppar)
+ if (iv(needhd) .eq. 1 .and. alg .eq. 2) write(pu,40)
+ 40 format(/11h it nf,7x,1hf,8x,5hreldf,4x,6hpreldf,4x,5hreldx,
+ 1 3x,6hstppar)
+ iv(needhd) = 0
+ if (alg .eq. 2) go to 50
+ m = iv(sused)
+ write(pu,100) iv(niter), nf, v(f), reldf, preldf, v(reldx),
+ 1 model1(m), model2(m), v(stppar)
+ go to 120
+c
+ 50 write(pu,110) iv(niter), nf, v(f), reldf, preldf, v(reldx),
+ 1 v(stppar)
+ go to 120
+c
+c *** print long summary line ***
+c
+ 60 if (iv(needhd) .eq. 1 .and. alg .eq. 1) write(pu,70)
+ 70 format(/11h it nf,6x,1hf,7x,5hreldf,3x,6hpreldf,3x,5hreldx,
+ 1 2x,13hmodel stppar,2x,6hd*step,2x,7hnpreldf)
+ if (iv(needhd) .eq. 1 .and. alg .eq. 2) write(pu,80)
+ 80 format(/11h it nf,7x,1hf,8x,5hreldf,4x,6hpreldf,4x,5hreldx,
+ 1 3x,6hstppar,3x,6hd*step,3x,7hnpreldf)
+ iv(needhd) = 0
+ nreldf = zero
+ if (oldf .gt. zero) nreldf = v(nreduc) / oldf
+ if (alg .eq. 2) go to 90
+ m = iv(sused)
+ write(pu,100) iv(niter), nf, v(f), reldf, preldf, v(reldx),
+ 1 model1(m), model2(m), v(stppar), v(dstnrm), nreldf
+ go to 120
+c
+ 90 write(pu,110) iv(niter), nf, v(f), reldf, preldf,
+ 1 v(reldx), v(stppar), v(dstnrm), nreldf
+ 100 format(i6,i5,d10.3,2d9.2,d8.1,a3,a4,2d8.1,d9.2)
+ 110 format(i6,i5,d11.3,2d10.2,3d9.1,d10.2)
+c
+ 120 if (iv(statpr) .lt. 0) go to 430
+ go to (999, 999, 130, 150, 170, 190, 210, 230, 250, 270, 290, 310,
+ 1 330, 350, 520), iv1
+c
+ 130 write(pu,140)
+ 140 format(/26h ***** x-convergence *****)
+ go to 430
+c
+ 150 write(pu,160)
+ 160 format(/42h ***** relative function convergence *****)
+ go to 430
+c
+ 170 write(pu,180)
+ 180 format(/49h ***** x- and relative function convergence *****)
+ go to 430
+c
+ 190 write(pu,200)
+ 200 format(/42h ***** absolute function convergence *****)
+ go to 430
+c
+ 210 write(pu,220)
+ 220 format(/33h ***** singular convergence *****)
+ go to 430
+c
+ 230 write(pu,240)
+ 240 format(/30h ***** false convergence *****)
+ go to 430
+c
+ 250 write(pu,260)
+ 260 format(/38h ***** function evaluation limit *****)
+ go to 430
+c
+ 270 write(pu,280)
+ 280 format(/28h ***** iteration limit *****)
+ go to 430
+c
+ 290 write(pu,300)
+ 300 format(/18h ***** stopx *****)
+ go to 430
+c
+ 310 write(pu,320)
+ 320 format(/44h ***** initial f(x) cannot be computed *****)
+c
+ go to 390
+c
+ 330 write(pu,340)
+ 340 format(/37h ***** bad parameters to assess *****)
+ go to 999
+c
+ 350 write(pu,360)
+ 360 format(/43h ***** gradient could not be computed *****)
+ if (iv(niter) .gt. 0) go to 480
+ go to 390
+c
+ 370 write(pu,380) iv(1)
+ 380 format(/14h ***** iv(1) =,i5,6h *****)
+ go to 999
+c
+c *** initial call on itsum ***
+c
+ 390 if (iv(x0prt) .ne. 0) write(pu,400) (i, x(i), d(i), i = 1, p)
+ 400 format(/23h i initial x(i),8x,4hd(i)//(1x,i5,d17.6,d14.3))
+c *** the following are to avoid undefined variables when the
+c *** function evaluation limit is 1...
+ v(dstnrm) = zero
+ v(fdif) = zero
+ v(nreduc) = zero
+ v(preduc) = zero
+ v(reldx) = zero
+ if (iv1 .ge. 12) go to 999
+ iv(needhd) = 0
+ iv(prntit) = 0
+ if (ol .eq. 0) go to 999
+ if (ol .lt. 0 .and. alg .eq. 1) write(pu,30)
+ if (ol .lt. 0 .and. alg .eq. 2) write(pu,40)
+ if (ol .gt. 0 .and. alg .eq. 1) write(pu,70)
+ if (ol .gt. 0 .and. alg .eq. 2) write(pu,80)
+ if (alg .eq. 1) write(pu,410) v(f)
+ if (alg .eq. 2) write(pu,420) v(f)
+ 410 format(/11h 0 1,d10.3)
+c365 format(/11h 0 1,e11.3)
+ 420 format(/11h 0 1,d11.3)
+ go to 999
+c
+c *** print various information requested on solution ***
+c
+ 430 iv(needhd) = 1
+ if (iv(statpr) .eq. 0) go to 480
+ oldf = dmax1(dabs(v(f0)), dabs(v(f)))
+ preldf = zero
+ nreldf = zero
+ if (oldf .le. zero) go to 440
+ preldf = v(preduc) / oldf
+ nreldf = v(nreduc) / oldf
+ 440 nf = iv(nfcall) - iv(nfcov)
+ ng = iv(ngcall) - iv(ngcov)
+ write(pu,450) v(f), v(reldx), nf, ng, preldf, nreldf
+ 450 format(/9h function,d17.6,8h reldx,d17.3/12h func. evals,
+ 1 i8,9x,11hgrad. evals,i8/7h preldf,d16.3,6x,7hnpreldf,d15.3)
+c
+ if (iv(nfcov) .gt. 0) write(pu,460) iv(nfcov)
+ 460 format(/1x,i4,50h extra func. evals for covariance and diagnost
+ 1ics.)
+ if (iv(ngcov) .gt. 0) write(pu,470) iv(ngcov)
+ 470 format(1x,i4,50h extra grad. evals for covariance and diagnosti
+ 1cs.)
+c
+ 480 if (iv(solprt) .eq. 0) go to 999
+ iv(needhd) = 1
+ write(pu,490)
+ 490 format(/22h i final x(i),8x,4hd(i),10x,4hg(i)/)
+ do 500 i = 1, p
+ write(pu,510) i, x(i), d(i), g(i)
+ 500 continue
+ 510 format(1x,i5,d16.6,2d14.3)
+ go to 999
+c
+ 520 write(pu,530)
+ 530 format(/24h inconsistent dimensions)
+ 999 return
+c *** last card of itsum follows ***
+ end
+ subroutine litvmu(n, x, l, y)
+c
+c *** solve (l**t)*x = y, where l is an n x n lower triangular
+c *** matrix stored compactly by rows. x and y may occupy the same
+c *** storage. ***
+c
+ integer n
+cal double precision x(n), l(1), y(n)
+ double precision x(n), l(n*(n+1)/2), y(n)
+ integer i, ii, ij, im1, i0, j, np1
+ double precision xi, zero
+c/6
+c data zero/0.d+0/
+c/7
+ parameter (zero=0.d+0)
+c/
+c
+ do 10 i = 1, n
+ 10 x(i) = y(i)
+ np1 = n + 1
+ i0 = n*(n+1)/2
+ do 30 ii = 1, n
+ i = np1 - ii
+ xi = x(i)/l(i0)
+ x(i) = xi
+ if (i .le. 1) go to 999
+ i0 = i0 - i
+ if (xi .eq. zero) go to 30
+ im1 = i - 1
+ do 20 j = 1, im1
+ ij = i0 + j
+ x(j) = x(j) - xi*l(ij)
+ 20 continue
+ 30 continue
+ 999 return
+c *** last card of litvmu follows ***
+ end
+ subroutine livmul(n, x, l, y)
+c
+c *** solve l*x = y, where l is an n x n lower triangular
+c *** matrix stored compactly by rows. x and y may occupy the same
+c *** storage. ***
+c
+ integer n
+cal double precision x(n), l(1), y(n)
+ double precision x(n), l(n*(n+1)/2), y(n)
+ external dotprd
+ double precision dotprd
+ integer i, j, k
+ double precision t, zero
+c/6
+c data zero/0.d+0/
+c/7
+ parameter (zero=0.d+0)
+c/
+c
+ do 10 k = 1, n
+ if (y(k) .ne. zero) go to 20
+ x(k) = zero
+ 10 continue
+ go to 999
+ 20 j = k*(k+1)/2
+ x(k) = y(k) / l(j)
+ if (k .ge. n) go to 999
+ k = k + 1
+ do 30 i = k, n
+ t = dotprd(i-1, l(j+1), x)
+ j = j + i
+ x(i) = (y(i) - t)/l(j)
+ 30 continue
+ 999 return
+c *** last card of livmul follows ***
+ end
+ subroutine parck(alg, d, iv, liv, lv, n, v)
+c
+c *** check ***sol (version 2.3) parameters, print changed values ***
+c
+c *** alg = 1 for regression, alg = 2 for general unconstrained opt.
+c
+ integer alg, liv, lv, n
+ integer iv(liv)
+ double precision d(n), v(lv)
+c
+ external rmdcon, vcopy, vdflt
+ double precision rmdcon
+c rmdcon -- returns machine-dependent constants.
+c vcopy -- copies one vector to another.
+c vdflt -- supplies default parameter values to v alone.
+c/+
+ integer max0
+c/
+c
+c *** local variables ***
+c
+ integer i, ii, iv1, j, k, l, m, miv1, miv2, ndfalt, parsv1, pu
+ integer ijmp, jlim(2), miniv(2), ndflt(2)
+c/6
+c integer varnm(2), sh(2)
+c real cngd(3), dflt(3), vn(2,34), which(3)
+c/7
+ character*1 varnm(2), sh(2)
+ character*4 cngd(3), dflt(3), vn(2,34), which(3)
+c/
+ double precision big, machep, tiny, vk, vm(34), vx(34), zero
+c
+c *** iv and v subscripts ***
+c
+ integer algsav, dinit, dtype, dtype0, epslon, inits, ivneed,
+ 1 lastiv, lastv, lmat, nextiv, nextv, nvdflt, oldn,
+ 2 parprt, parsav, perm, prunit, vneed
+c
+c
+c/6
+c data algsav/51/, dinit/38/, dtype/16/, dtype0/54/, epslon/19/,
+c 1 inits/25/, ivneed/3/, lastiv/44/, lastv/45/, lmat/42/,
+c 2 nextiv/46/, nextv/47/, nvdflt/50/, oldn/38/, parprt/20/,
+c 3 parsav/49/, perm/58/, prunit/21/, vneed/4/
+c/7
+ parameter (algsav=51, dinit=38, dtype=16, dtype0=54, epslon=19,
+ 1 inits=25, ivneed=3, lastiv=44, lastv=45, lmat=42,
+ 2 nextiv=46, nextv=47, nvdflt=50, oldn=38, parprt=20,
+ 3 parsav=49, perm=58, prunit=21, vneed=4)
+ save big, machep, tiny
+c/
+c
+ data big/0.d+0/, machep/-1.d+0/, tiny/1.d+0/, zero/0.d+0/
+c/6
+c data vn(1,1),vn(2,1)/4hepsl,4hon../
+c data vn(1,2),vn(2,2)/4hphmn,4hfc../
+c data vn(1,3),vn(2,3)/4hphmx,4hfc../
+c data vn(1,4),vn(2,4)/4hdecf,4hac../
+c data vn(1,5),vn(2,5)/4hincf,4hac../
+c data vn(1,6),vn(2,6)/4hrdfc,4hmn../
+c data vn(1,7),vn(2,7)/4hrdfc,4hmx../
+c data vn(1,8),vn(2,8)/4htune,4hr1../
+c data vn(1,9),vn(2,9)/4htune,4hr2../
+c data vn(1,10),vn(2,10)/4htune,4hr3../
+c data vn(1,11),vn(2,11)/4htune,4hr4../
+c data vn(1,12),vn(2,12)/4htune,4hr5../
+c data vn(1,13),vn(2,13)/4hafct,4hol../
+c data vn(1,14),vn(2,14)/4hrfct,4hol../
+c data vn(1,15),vn(2,15)/4hxcto,4hl.../
+c data vn(1,16),vn(2,16)/4hxfto,4hl.../
+c data vn(1,17),vn(2,17)/4hlmax,4h0.../
+c data vn(1,18),vn(2,18)/4hlmax,4hs.../
+c data vn(1,19),vn(2,19)/4hscto,4hl.../
+c data vn(1,20),vn(2,20)/4hdini,4ht.../
+c data vn(1,21),vn(2,21)/4hdtin,4hit../
+c data vn(1,22),vn(2,22)/4hd0in,4hit../
+c data vn(1,23),vn(2,23)/4hdfac,4h..../
+c data vn(1,24),vn(2,24)/4hdltf,4hdc../
+c data vn(1,25),vn(2,25)/4hdltf,4hdj../
+c data vn(1,26),vn(2,26)/4hdelt,4ha0../
+c data vn(1,27),vn(2,27)/4hfuzz,4h..../
+c data vn(1,28),vn(2,28)/4hrlim,4hit../
+c data vn(1,29),vn(2,29)/4hcosm,4hin../
+c data vn(1,30),vn(2,30)/4hhube,4hrc../
+c data vn(1,31),vn(2,31)/4hrspt,4hol../
+c data vn(1,32),vn(2,32)/4hsigm,4hin../
+c data vn(1,33),vn(2,33)/4heta0,4h..../
+c data vn(1,34),vn(2,34)/4hbias,4h..../
+c/7
+ data vn(1,1),vn(2,1)/'epsl','on..'/
+ data vn(1,2),vn(2,2)/'phmn','fc..'/
+ data vn(1,3),vn(2,3)/'phmx','fc..'/
+ data vn(1,4),vn(2,4)/'decf','ac..'/
+ data vn(1,5),vn(2,5)/'incf','ac..'/
+ data vn(1,6),vn(2,6)/'rdfc','mn..'/
+ data vn(1,7),vn(2,7)/'rdfc','mx..'/
+ data vn(1,8),vn(2,8)/'tune','r1..'/
+ data vn(1,9),vn(2,9)/'tune','r2..'/
+ data vn(1,10),vn(2,10)/'tune','r3..'/
+ data vn(1,11),vn(2,11)/'tune','r4..'/
+ data vn(1,12),vn(2,12)/'tune','r5..'/
+ data vn(1,13),vn(2,13)/'afct','ol..'/
+ data vn(1,14),vn(2,14)/'rfct','ol..'/
+ data vn(1,15),vn(2,15)/'xcto','l...'/
+ data vn(1,16),vn(2,16)/'xfto','l...'/
+ data vn(1,17),vn(2,17)/'lmax','0...'/
+ data vn(1,18),vn(2,18)/'lmax','s...'/
+ data vn(1,19),vn(2,19)/'scto','l...'/
+ data vn(1,20),vn(2,20)/'dini','t...'/
+ data vn(1,21),vn(2,21)/'dtin','it..'/
+ data vn(1,22),vn(2,22)/'d0in','it..'/
+ data vn(1,23),vn(2,23)/'dfac','....'/
+ data vn(1,24),vn(2,24)/'dltf','dc..'/
+ data vn(1,25),vn(2,25)/'dltf','dj..'/
+ data vn(1,26),vn(2,26)/'delt','a0..'/
+ data vn(1,27),vn(2,27)/'fuzz','....'/
+ data vn(1,28),vn(2,28)/'rlim','it..'/
+ data vn(1,29),vn(2,29)/'cosm','in..'/
+ data vn(1,30),vn(2,30)/'hube','rc..'/
+ data vn(1,31),vn(2,31)/'rspt','ol..'/
+ data vn(1,32),vn(2,32)/'sigm','in..'/
+ data vn(1,33),vn(2,33)/'eta0','....'/
+ data vn(1,34),vn(2,34)/'bias','....'/
+c/
+c
+ data vm(1)/1.0d-3/, vm(2)/-0.99d+0/, vm(3)/1.0d-3/, vm(4)/1.0d-2/,
+ 1 vm(5)/1.2d+0/, vm(6)/1.d-2/, vm(7)/1.2d+0/, vm(8)/0.d+0/,
+ 2 vm(9)/0.d+0/, vm(10)/1.d-3/, vm(11)/-1.d+0/, vm(13)/0.d+0/,
+ 3 vm(15)/0.d+0/, vm(16)/0.d+0/, vm(19)/0.d+0/, vm(20)/-10.d+0/,
+ 4 vm(21)/0.d+0/, vm(22)/0.d+0/, vm(23)/0.d+0/, vm(27)/1.01d+0/,
+ 5 vm(28)/1.d+10/, vm(30)/0.d+0/, vm(31)/0.d+0/, vm(32)/0.d+0/,
+ 6 vm(34)/0.d+0/
+ data vx(1)/0.9d+0/, vx(2)/-1.d-3/, vx(3)/1.d+1/, vx(4)/0.8d+0/,
+ 1 vx(5)/1.d+2/, vx(6)/0.8d+0/, vx(7)/1.d+2/, vx(8)/0.5d+0/,
+ 2 vx(9)/0.5d+0/, vx(10)/1.d+0/, vx(11)/1.d+0/, vx(14)/0.1d+0/,
+ 3 vx(15)/1.d+0/, vx(16)/1.d+0/, vx(19)/1.d+0/, vx(23)/1.d+0/,
+ 4 vx(24)/1.d+0/, vx(25)/1.d+0/, vx(26)/1.d+0/, vx(27)/1.d+10/,
+ 5 vx(29)/1.d+0/, vx(31)/1.d+0/, vx(32)/1.d+0/, vx(33)/1.d+0/,
+ 6 vx(34)/1.d+0/
+c
+c/6
+c data varnm(1)/1hp/, varnm(2)/1hn/, sh(1)/1hs/, sh(2)/1hh/
+c data cngd(1),cngd(2),cngd(3)/4h---c,4hhang,4hed v/,
+c 1 dflt(1),dflt(2),dflt(3)/4hnond,4hefau,4hlt v/
+c/7
+ data varnm(1)/'p'/, varnm(2)/'n'/, sh(1)/'s'/, sh(2)/'h'/
+ data cngd(1),cngd(2),cngd(3)/'---c','hang','ed v'/,
+ 1 dflt(1),dflt(2),dflt(3)/'nond','efau','lt v'/
+c/
+ data ijmp/33/, jlim(1)/0/, jlim(2)/24/, ndflt(1)/32/, ndflt(2)/25/
+ data miniv(1)/80/, miniv(2)/59/
+c
+c............................... body ................................
+c
+ pu = 0
+ if (prunit .le. liv) pu = iv(prunit)
+ if (alg .lt. 1 .or. alg .gt. 2) go to 340
+ if (iv(1) .eq. 0) call deflt(alg, iv, liv, lv, v)
+ iv1 = iv(1)
+ if (iv1 .ne. 13 .and. iv1 .ne. 12) go to 10
+ miv1 = miniv(alg)
+ if (perm .le. liv) miv1 = max0(miv1, iv(perm) - 1)
+ if (ivneed .le. liv) miv2 = miv1 + max0(iv(ivneed), 0)
+ if (lastiv .le. liv) iv(lastiv) = miv2
+ if (liv .lt. miv1) go to 300
+ iv(ivneed) = 0
+ iv(lastv) = max0(iv(vneed), 0) + iv(lmat) - 1
+ iv(vneed) = 0
+ if (liv .lt. miv2) go to 300
+ if (lv .lt. iv(lastv)) go to 320
+ 10 if (alg .eq. iv(algsav)) go to 30
+ if (pu .ne. 0) write(pu,20) alg, iv(algsav)
+ 20 format(/39h the first parameter to deflt should be,i3,
+ 1 12h rather than,i3)
+ iv(1) = 82
+ go to 999
+ 30 if (iv1 .lt. 12 .or. iv1 .gt. 14) go to 60
+ if (n .ge. 1) go to 50
+ iv(1) = 81
+ if (pu .eq. 0) go to 999
+ write(pu,40) varnm(alg), n
+ 40 format(/8h /// bad,a1,2h =,i5)
+ go to 999
+ 50 if (iv1 .ne. 14) iv(nextiv) = iv(perm)
+ if (iv1 .ne. 14) iv(nextv) = iv(lmat)
+ if (iv1 .eq. 13) go to 999
+ k = iv(parsav) - epslon
+ call vdflt(alg, lv-k, v(k+1))
+ iv(dtype0) = 2 - alg
+ iv(oldn) = n
+ which(1) = dflt(1)
+ which(2) = dflt(2)
+ which(3) = dflt(3)
+ go to 110
+ 60 if (n .eq. iv(oldn)) go to 80
+ iv(1) = 17
+ if (pu .eq. 0) go to 999
+ write(pu,70) varnm(alg), iv(oldn), n
+ 70 format(/5h /// ,1a1,14h changed from ,i5,4h to ,i5)
+ go to 999
+c
+ 80 if (iv1 .le. 11 .and. iv1 .ge. 1) go to 100
+ iv(1) = 80
+ if (pu .ne. 0) write(pu,90) iv1
+ 90 format(/13h /// iv(1) =,i5,28h should be between 0 and 14.)
+ go to 999
+c
+ 100 which(1) = cngd(1)
+ which(2) = cngd(2)
+ which(3) = cngd(3)
+c
+ 110 if (iv1 .eq. 14) iv1 = 12
+ if (big .gt. tiny) go to 120
+ tiny = rmdcon(1)
+ machep = rmdcon(3)
+ big = rmdcon(6)
+ vm(12) = machep
+ vx(12) = big
+ vx(13) = big
+ vm(14) = machep
+ vm(17) = tiny
+ vx(17) = big
+ vm(18) = tiny
+ vx(18) = big
+ vx(20) = big
+ vx(21) = big
+ vx(22) = big
+ vm(24) = machep
+ vm(25) = machep
+ vm(26) = machep
+ vx(28) = rmdcon(5)
+ vm(29) = machep
+ vx(30) = big
+ vm(33) = machep
+ 120 m = 0
+ i = 1
+ j = jlim(alg)
+ k = epslon
+ ndfalt = ndflt(alg)
+ do 150 l = 1, ndfalt
+ vk = v(k)
+ if (vk .ge. vm(i) .and. vk .le. vx(i)) go to 140
+ m = k
+ if (pu .ne. 0) write(pu,130) vn(1,i), vn(2,i), k, vk,
+ 1 vm(i), vx(i)
+ 130 format(/6h /// ,2a4,5h.. v(,i2,3h) =,d11.3,7h should,
+ 1 11h be between,d11.3,4h and,d11.3)
+ 140 k = k + 1
+ i = i + 1
+ if (i .eq. j) i = ijmp
+ 150 continue
+c
+ if (iv(nvdflt) .eq. ndfalt) go to 170
+ iv(1) = 51
+ if (pu .eq. 0) go to 999
+ write(pu,160) iv(nvdflt), ndfalt
+ 160 format(/13h iv(nvdflt) =,i5,13h rather than ,i5)
+ go to 999
+ 170 if ((iv(dtype) .gt. 0 .or. v(dinit) .gt. zero) .and. iv1 .eq. 12)
+ 1 go to 200
+ do 190 i = 1, n
+ if (d(i) .gt. zero) go to 190
+ m = 18
+ if (pu .ne. 0) write(pu,180) i, d(i)
+ 180 format(/8h /// d(,i3,3h) =,d11.3,19h should be positive)
+ 190 continue
+ 200 if (m .eq. 0) go to 210
+ iv(1) = m
+ go to 999
+c
+ 210 if (pu .eq. 0 .or. iv(parprt) .eq. 0) go to 999
+ if (iv1 .ne. 12 .or. iv(inits) .eq. alg-1) go to 230
+ m = 1
+ write(pu,220) sh(alg), iv(inits)
+ 220 format(/22h nondefault values..../5h init,a1,14h..... iv(25) =,
+ 1 i3)
+ 230 if (iv(dtype) .eq. iv(dtype0)) go to 250
+ if (m .eq. 0) write(pu,260) which
+ m = 1
+ write(pu,240) iv(dtype)
+ 240 format(20h dtype..... iv(16) =,i3)
+ 250 i = 1
+ j = jlim(alg)
+ k = epslon
+ l = iv(parsav)
+ ndfalt = ndflt(alg)
+ do 290 ii = 1, ndfalt
+ if (v(k) .eq. v(l)) go to 280
+ if (m .eq. 0) write(pu,260) which
+ 260 format(/1h ,3a4,9halues..../)
+ m = 1
+ write(pu,270) vn(1,i), vn(2,i), k, v(k)
+ 270 format(1x,2a4,5h.. v(,i2,3h) =,d15.7)
+ 280 k = k + 1
+ l = l + 1
+ i = i + 1
+ if (i .eq. j) i = ijmp
+ 290 continue
+c
+ iv(dtype0) = iv(dtype)
+ parsv1 = iv(parsav)
+ call vcopy(iv(nvdflt), v(parsv1), v(epslon))
+ go to 999
+c
+ 300 iv(1) = 15
+ if (pu .eq. 0) go to 999
+ write(pu,310) liv, miv2
+ 310 format(/10h /// liv =,i5,17h must be at least,i5)
+ if (liv .lt. miv1) go to 999
+ if (lv .lt. iv(lastv)) go to 320
+ go to 999
+c
+ 320 iv(1) = 16
+ if (pu .eq. 0) go to 999
+ write(pu,330) lv, iv(lastv)
+ 330 format(/9h /// lv =,i5,17h must be at least,i5)
+ go to 999
+c
+ 340 iv(1) = 67
+ if (pu .eq. 0) go to 999
+ write(pu,350) alg
+ 350 format(/10h /// alg =,i5,15h must be 1 or 2)
+c
+ 999 return
+c *** last card of parck follows ***
+ end
+ double precision function reldst(p, d, x, x0)
+c
+c *** compute and return relative difference between x and x0 ***
+c *** nl2sol version 2.2 ***
+c
+ integer p
+ double precision d(p), x(p), x0(p)
+c/+
+ double precision dabs
+c/
+ integer i
+ double precision emax, t, xmax, zero
+c/6
+c data zero/0.d+0/
+c/7
+ parameter (zero=0.d+0)
+c/
+c
+ emax = zero
+ xmax = zero
+ do 10 i = 1, p
+ t = dabs(d(i) * (x(i) - x0(i)))
+ if (emax .lt. t) emax = t
+ t = d(i) * (dabs(x(i)) + dabs(x0(i)))
+ if (xmax .lt. t) xmax = t
+ 10 continue
+ reldst = zero
+ if (xmax .gt. zero) reldst = emax / xmax
+ 999 return
+c *** last card of reldst follows ***
+ end
+c logical function stopx(idummy)
+c *****parameters...
+c integer idummy
+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 ..................................................................
+c
+c stopx = .false.
+c return
+c end
+ subroutine vaxpy(p, w, a, x, y)
+c
+c *** set w = a*x + y -- w, x, y = p-vectors, a = scalar ***
+c
+ integer p
+ double precision a, w(p), x(p), y(p)
+c
+ integer i
+c
+ do 10 i = 1, p
+ 10 w(i) = a*x(i) + y(i)
+ return
+ end
+ subroutine vcopy(p, y, x)
+c
+c *** set y = x, where x and y are p-vectors ***
+c
+ integer p
+ double precision x(p), y(p)
+c
+ integer i
+c
+ do 10 i = 1, p
+ 10 y(i) = x(i)
+ return
+ end
+ subroutine vdflt(alg, lv, v)
+c
+c *** supply ***sol (version 2.3) default values to v ***
+c
+c *** alg = 1 means regression constants.
+c *** alg = 2 means general unconstrained optimization constants.
+c
+ integer alg, l
+ double precision v(lv)
+c/+
+ double precision dmax1
+c/
+ external rmdcon
+ double precision rmdcon
+c rmdcon... returns machine-dependent constants
+c
+ double precision machep, mepcrt, one, sqteps, three
+c
+c *** subscripts for v ***
+c
+ integer afctol, bias, cosmin, decfac, delta0, dfac, dinit, dltfdc,
+ 1 dltfdj, dtinit, d0init, epslon, eta0, fuzz, huberc,
+ 2 incfac, lmax0, lmaxs, phmnfc, phmxfc, rdfcmn, rdfcmx,
+ 3 rfctol, rlimit, rsptol, sctol, sigmin, tuner1, tuner2,
+ 4 tuner3, tuner4, tuner5, xctol, xftol
+c
+c/6
+c data one/1.d+0/, three/3.d+0/
+c/7
+ parameter (one=1.d+0, three=3.d+0)
+c/
+c
+c *** v subscript values ***
+c
+c/6
+c data afctol/31/, bias/43/, cosmin/47/, decfac/22/, delta0/44/,
+c 1 dfac/41/, dinit/38/, dltfdc/42/, dltfdj/43/, dtinit/39/,
+c 2 d0init/40/, epslon/19/, eta0/42/, fuzz/45/, huberc/48/,
+c 3 incfac/23/, lmax0/35/, lmaxs/36/, phmnfc/20/, phmxfc/21/,
+c 4 rdfcmn/24/, rdfcmx/25/, rfctol/32/, rlimit/46/, rsptol/49/,
+c 5 sctol/37/, sigmin/50/, tuner1/26/, tuner2/27/, tuner3/28/,
+c 6 tuner4/29/, tuner5/30/, xctol/33/, xftol/34/
+c/7
+ parameter (afctol=31, bias=43, cosmin=47, decfac=22, delta0=44,
+ 1 dfac=41, dinit=38, dltfdc=42, dltfdj=43, dtinit=39,
+ 2 d0init=40, epslon=19, eta0=42, fuzz=45, huberc=48,
+ 3 incfac=23, lmax0=35, lmaxs=36, phmnfc=20, phmxfc=21,
+ 4 rdfcmn=24, rdfcmx=25, rfctol=32, rlimit=46, rsptol=49,
+ 5 sctol=37, sigmin=50, tuner1=26, tuner2=27, tuner3=28,
+ 6 tuner4=29, tuner5=30, xctol=33, xftol=34)
+c/
+c
+c------------------------------- body --------------------------------
+c
+ machep = rmdcon(3)
+ v(afctol) = 1.d-20
+ if (machep .gt. 1.d-10) v(afctol) = machep**2
+ v(decfac) = 0.5d+0
+ sqteps = rmdcon(4)
+ v(dfac) = 0.6d+0
+ v(delta0) = sqteps
+ v(dtinit) = 1.d-6
+ mepcrt = machep ** (one/three)
+ v(d0init) = 1.d+0
+ v(epslon) = 0.1d+0
+ v(incfac) = 2.d+0
+ v(lmax0) = 1.d+0
+ v(lmaxs) = 1.d+0
+ v(phmnfc) = -0.1d+0
+ v(phmxfc) = 0.1d+0
+ v(rdfcmn) = 0.1d+0
+ v(rdfcmx) = 4.d+0
+ v(rfctol) = dmax1(1.d-10, mepcrt**2)
+ v(sctol) = v(rfctol)
+ v(tuner1) = 0.1d+0
+ v(tuner2) = 1.d-4
+ v(tuner3) = 0.75d+0
+ v(tuner4) = 0.5d+0
+ v(tuner5) = 0.75d+0
+ v(xctol) = sqteps
+ v(xftol) = 1.d+2 * machep
+c
+ if (alg .ge. 2) go to 10
+c
+c *** regression values
+c
+ v(cosmin) = dmax1(1.d-6, 1.d+2 * machep)
+ v(dinit) = 0.d+0
+ v(dltfdc) = mepcrt
+ v(dltfdj) = sqteps
+ v(fuzz) = 1.5d+0
+ v(huberc) = 0.7d+0
+ v(rlimit) = rmdcon(5)
+ v(rsptol) = 1.d-3
+ v(sigmin) = 1.d-4
+ go to 999
+c
+c *** general optimization values
+c
+ 10 v(bias) = 0.8d+0
+ v(dinit) = -1.0d+0
+ v(eta0) = 1.0d+3 * machep
+c
+ 999 return
+c *** last card of vdflt follows ***
+ end
+ subroutine vscopy(p, y, s)
+c
+c *** set p-vector y to scalar s ***
+c
+ integer p
+ double precision s, y(p)
+c
+ integer i
+c
+ do 10 i = 1, p
+ 10 y(i) = s
+ return
+ end
+ double precision function v2norm(p, x)
+c
+c *** return the 2-norm of the p-vector x, taking ***
+c *** care to avoid the most likely underflows. ***
+c
+ integer p
+ double precision x(p)
+c
+ integer i, j
+ double precision one, r, scale, sqteta, t, xi, zero
+c/+
+ double precision dabs, dsqrt
+c/
+ external rmdcon
+ double precision rmdcon
+c
+c/6
+c data one/1.d+0/, zero/0.d+0/
+c/7
+ parameter (one=1.d+0, zero=0.d+0)
+ save sqteta
+c/
+ data sqteta/0.d+0/
+c
+ if (p .gt. 0) go to 10
+ v2norm = zero
+ go to 999
+ 10 do 20 i = 1, p
+ if (x(i) .ne. zero) go to 30
+ 20 continue
+ v2norm = zero
+ go to 999
+c
+ 30 scale = dabs(x(i))
+ if (i .lt. p) go to 40
+ v2norm = scale
+ go to 999
+ 40 t = one
+ if (sqteta .eq. zero) sqteta = rmdcon(2)
+c
+c *** sqteta is (slightly larger than) the square root of the
+c *** smallest positive floating point number on the machine.
+c *** the tests involving sqteta are done to prevent underflows.
+c
+ j = i + 1
+ do 60 i = j, p
+ xi = dabs(x(i))
+ if (xi .gt. scale) go to 50
+ r = xi / scale
+ if (r .gt. sqteta) t = t + r*r
+ go to 60
+ 50 r = scale / xi
+ if (r .le. sqteta) r = zero
+ t = one + t * r*r
+ scale = xi
+ 60 continue
+c
+ v2norm = scale * dsqrt(t)
+ 999 return
+c *** last card of v2norm follows ***
+ end
+ subroutine humsl(n, d, x, calcf, calcgh, iv, liv, lv, v,
+ 1 uiparm, urparm, ufparm)
+c
+c *** minimize general unconstrained objective function using ***
+c *** (analytic) gradient and hessian provided by the caller. ***
+c
+ integer liv, lv, n
+ integer iv(liv), uiparm(1)
+ double precision d(n), x(n), v(lv), urparm(1)
+c dimension v(78 + n*(n+12)), uiparm(*), urparm(*)
+ external calcf, calcgh, ufparm
+c
+c------------------------------ discussion ---------------------------
+c
+c this routine is like sumsl, except that the subroutine para-
+c meter calcg of sumsl (which computes the gradient of the objec-
+c tive function) is replaced by the subroutine parameter calcgh,
+c which computes both the gradient and (lower triangle of the)
+c hessian of the objective function. the calling sequence is...
+c call calcgh(n, x, nf, g, h, uiparm, urparm, ufparm)
+c parameters n, x, nf, g, uiparm, urparm, and ufparm are the same
+c as for sumsl, while h is an array of length n*(n+1)/2 in which
+c calcgh must store the lower triangle of the hessian at x. start-
+c ing at h(1), calcgh must store the hessian entries in the order
+c (1,1), (2,1), (2,2), (3,1), (3,2), (3,3), ...
+c the value printed (by itsum) in the column labelled stppar
+c is the levenberg-marquardt used in computing the current step.
+c zero means a full newton step. if the special case described in
+c ref. 1 is detected, then stppar is negated. the value printed
+c in the column labelled npreldf is zero if the current hessian
+c is not positive definite.
+c it sometimes proves worthwhile to let d be determined from the
+c diagonal of the hessian matrix by setting iv(dtype) = 1 and
+c v(dinit) = 0. the following iv and v components are relevant...
+c
+c iv(dtol)..... iv(59) gives the starting subscript in v of the dtol
+c array used when d is updated. (iv(dtol) can be
+c initialized by calling humsl with iv(1) = 13.)
+c iv(dtype).... iv(16) tells how the scale vector d should be chosen.
+c iv(dtype) .le. 0 means that d should not be updated, and
+c iv(dtype) .ge. 1 means that d should be updated as
+c described below with v(dfac). default = 0.
+c v(dfac)..... v(41) and the dtol and d0 arrays (see v(dtinit) and
+c v(d0init)) are used in updating the scale vector d when
+c iv(dtype) .gt. 0. (d is initialized according to
+c v(dinit), described in sumsl.) let
+c d1(i) = max(sqrt(abs(h(i,i))), v(dfac)*d(i)),
+c where h(i,i) is the i-th diagonal element of the current
+c hessian. if iv(dtype) = 1, then d(i) is set to d1(i)
+c unless d1(i) .lt. dtol(i), in which case d(i) is set to
+c max(d0(i), dtol(i)).
+c if iv(dtype) .ge. 2, then d is updated during the first
+c iteration as for iv(dtype) = 1 (after any initialization
+c due to v(dinit)) and is left unchanged thereafter.
+c default = 0.6.
+c v(dtinit)... v(39), if positive, is the value to which all components
+c of the dtol array (see v(dfac)) are initialized. if
+c v(dtinit) = 0, then it is assumed that the caller has
+c stored dtol in v starting at v(iv(dtol)).
+c default = 10**-6.
+c v(d0init)... v(40), if positive, is the value to which all components
+c of the d0 vector (see v(dfac)) are initialized. if
+c v(dfac) = 0, then it is assumed that the caller has
+c stored d0 in v starting at v(iv(dtol)+n). default = 1.0.
+c
+c *** reference ***
+c
+c 1. gay, d.m. (1981), computing optimal locally constrained steps,
+c siam j. sci. statist. comput. 2, pp. 186-197.
+c.
+c *** general ***
+c
+c coded by david m. gay (winter 1980). revised sept. 1982.
+c this subroutine was written in connection with research supported
+c in part by the national science foundation under grants
+c mcs-7600324 and mcs-7906671.
+c
+c---------------------------- declarations ---------------------------
+c
+ external deflt, humit
+c
+c deflt... provides default input values for iv and v.
+c humit... reverse-communication routine that does humsl algorithm.
+c
+ integer g1, h1, iv1, lh, nf
+ double precision f
+c
+c *** subscripts for iv ***
+c
+ integer g, h, nextv, nfcall, nfgcal, toobig, vneed
+c
+c/6
+c data nextv/47/, nfcall/6/, nfgcal/7/, g/28/, h/56/, toobig/2/,
+c 1 vneed/4/
+c/7
+ parameter (nextv=47, nfcall=6, nfgcal=7, g=28, h=56, toobig=2,
+ 1 vneed=4)
+c/
+c
+c+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++
+c
+ lh = n * (n + 1) / 2
+ if (iv(1) .eq. 0) call deflt(2, iv, liv, lv, v)
+ if (iv(1) .eq. 12 .or. iv(1) .eq. 13)
+ 1 iv(vneed) = iv(vneed) + n*(n+3)/2
+ iv1 = iv(1)
+ if (iv1 .eq. 14) go to 10
+ if (iv1 .gt. 2 .and. iv1 .lt. 12) go to 10
+ g1 = 1
+ h1 = 1
+ if (iv1 .eq. 12) iv(1) = 13
+ go to 20
+c
+ 10 g1 = iv(g)
+ h1 = iv(h)
+c
+ 20 call humit(d, f, v(g1), v(h1), iv, lh, liv, lv, n, v, x)
+ if (iv(1) - 2) 30, 40, 50
+c
+ 30 nf = iv(nfcall)
+ call calcf(n, x, nf, f, uiparm, urparm, ufparm)
+ if (nf .le. 0) iv(toobig) = 1
+ go to 20
+c
+ 40 call calcgh(n, x, iv(nfgcal), v(g1), v(h1), uiparm, urparm,
+ 1 ufparm)
+ go to 20
+c
+ 50 if (iv(1) .ne. 14) go to 999
+c
+c *** storage allocation
+c
+ iv(g) = iv(nextv)
+ iv(h) = iv(g) + n
+ iv(nextv) = iv(h) + n*(n+1)/2
+ if (iv1 .ne. 13) go to 10
+c
+ 999 return
+c *** last card of humsl follows ***
+ end
+ subroutine humit(d, fx, g, h, iv, lh, liv, lv, n, v, x)
+c
+c *** carry out humsl (unconstrained minimization) iterations, using
+c *** hessian matrix provided by the caller.
+c
+c *** parameter declarations ***
+c
+ integer lh, liv, lv, n
+ integer iv(liv)
+ double precision d(n), fx, g(n), h(lh), v(lv), x(n)
+c
+c-------------------------- parameter usage --------------------------
+c
+c d.... scale vector.
+c fx... function value.
+c g.... gradient vector.
+c h.... lower triangle of the hessian, stored rowwise.
+c iv... integer value array.
+c lh... length of h = p*(p+1)/2.
+c liv.. length of iv (at least 60).
+c lv... length of v (at least 78 + n*(n+21)/2).
+c n.... number of variables (components in x and g).
+c v.... floating-point value array.
+c x.... parameter vector.
+c
+c *** discussion ***
+c
+c parameters iv, n, v, and x are the same as the corresponding
+c ones to humsl (which see), except that v can be shorter (since
+c the part of v that humsl uses for storing g and h is not needed).
+c moreover, compared with humsl, iv(1) may have the two additional
+c output values 1 and 2, which are explained below, as is the use
+c of iv(toobig) and iv(nfgcal). the value iv(g), which is an
+c output value from humsl, is not referenced by humit or the
+c subroutines it calls.
+c
+c iv(1) = 1 means the caller should set fx to f(x), the function value
+c at x, and call humit again, having changed none of the
+c other parameters. an exception occurs if f(x) cannot be
+c computed (e.g. if overflow would occur), which may happen
+c because of an oversized step. in this case the caller
+c should set iv(toobig) = iv(2) to 1, which will cause
+c humit to ignore fx and try a smaller step. the para-
+c meter nf that humsl passes to calcf (for possible use by
+c calcgh) is a copy of iv(nfcall) = iv(6).
+c iv(1) = 2 means the caller should set g to g(x), the gradient of f at
+c x, and h to the lower triangle of h(x), the hessian of f
+c at x, and call humit again, having changed none of the
+c other parameters except perhaps the scale vector d.
+c the parameter nf that humsl passes to calcg is
+c iv(nfgcal) = iv(7). if g(x) and h(x) cannot be evaluated,
+c then the caller may set iv(nfgcal) to 0, in which case
+c humit will return with iv(1) = 65.
+c note -- humit overwrites h with the lower triangle
+c of diag(d)**-1 * h(x) * diag(d)**-1.
+c.
+c *** general ***
+c
+c coded by david m. gay (winter 1980). revised sept. 1982.
+c this subroutine was written in connection with research supported
+c in part by the national science foundation under grants
+c mcs-7600324 and mcs-7906671.
+c
+c (see sumsl and humsl for references.)
+c
+c+++++++++++++++++++++++++++ declarations ++++++++++++++++++++++++++++
+c
+c *** local variables ***
+c
+ integer dg1, dummy, i, j, k, l, lstgst, nn1o2, step1,
+ 1 temp1, w1, x01
+ double precision t
+c
+c *** constants ***
+c
+ double precision one, onep2, zero
+c
+c *** no intrinsic functions ***
+c
+c *** external functions and subroutines ***
+c
+ external assst, deflt, dotprd, dupdu, gqtst, itsum, parck,
+ 1 reldst, slvmul, stopx, vaxpy, vcopy, vscopy, v2norm
+ logical stopx
+ double precision dotprd, reldst, v2norm
+c
+c assst.... assesses candidate step.
+c deflt.... provides default iv and v input values.
+c dotprd... returns inner product of two vectors.
+c dupdu.... updates scale vector d.
+c gqtst.... computes optimally locally constrained step.
+c itsum.... prints iteration summary and info on initial and final x.
+c parck.... checks validity of input iv and v values.
+c reldst... computes v(reldx) = relative step size.
+c slvmul... multiplies symmetric matrix times vector, given the lower
+c triangle of the matrix.
+c stopx.... returns .true. if the break key has been pressed.
+c vaxpy.... computes scalar times one vector plus another.
+c vcopy.... copies one vector to another.
+c vscopy... sets all elements of a vector to a scalar.
+c v2norm... returns the 2-norm of a vector.
+c
+c *** subscripts for iv and v ***
+c
+ integer cnvcod, dg, dgnorm, dinit, dstnrm, dtinit, dtol,
+ 1 dtype, d0init, f, f0, fdif, gtstep, incfac, irc, kagqt,
+ 2 lmat, lmax0, lmaxs, mode, model, mxfcal, mxiter, nextv,
+ 3 nfcall, nfgcal, ngcall, niter, preduc, radfac, radinc,
+ 4 radius, rad0, reldx, restor, step, stglim, stlstg, stppar,
+ 5 toobig, tuner4, tuner5, vneed, w, xirc, x0
+c
+c *** iv subscript values ***
+c
+c/6
+c data cnvcod/55/, dg/37/, dtol/59/, dtype/16/, irc/29/, kagqt/33/,
+c 1 lmat/42/, mode/35/, model/5/, mxfcal/17/, mxiter/18/,
+c 2 nextv/47/, nfcall/6/, nfgcal/7/, ngcall/30/, niter/31/,
+c 3 radinc/8/, restor/9/, step/40/, stglim/11/, stlstg/41/,
+c 4 toobig/2/, vneed/4/, w/34/, xirc/13/, x0/43/
+c/7
+ parameter (cnvcod=55, dg=37, dtol=59, dtype=16, irc=29, kagqt=33,
+ 1 lmat=42, mode=35, model=5, mxfcal=17, mxiter=18,
+ 2 nextv=47, nfcall=6, nfgcal=7, ngcall=30, niter=31,
+ 3 radinc=8, restor=9, step=40, stglim=11, stlstg=41,
+ 4 toobig=2, vneed=4, w=34, xirc=13, x0=43)
+c/
+c
+c *** v subscript values ***
+c
+c/6
+c data dgnorm/1/, dinit/38/, dstnrm/2/, dtinit/39/, d0init/40/,
+c 1 f/10/, f0/13/, fdif/11/, gtstep/4/, incfac/23/, lmax0/35/,
+c 2 lmaxs/36/, preduc/7/, radfac/16/, radius/8/, rad0/9/,
+c 3 reldx/17/, stppar/5/, tuner4/29/, tuner5/30/
+c/7
+ parameter (dgnorm=1, dinit=38, dstnrm=2, dtinit=39, d0init=40,
+ 1 f=10, f0=13, fdif=11, gtstep=4, incfac=23, lmax0=35,
+ 2 lmaxs=36, preduc=7, radfac=16, radius=8, rad0=9,
+ 3 reldx=17, stppar=5, tuner4=29, tuner5=30)
+c/
+c
+c/6
+c data one/1.d+0/, onep2/1.2d+0/, zero/0.d+0/
+c/7
+ parameter (one=1.d+0, onep2=1.2d+0, zero=0.d+0)
+c/
+c
+c+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++
+c
+ i = iv(1)
+ if (i .eq. 1) go to 30
+ if (i .eq. 2) go to 40
+c
+c *** check validity of iv and v input values ***
+c
+ if (iv(1) .eq. 0) call deflt(2, iv, liv, lv, v)
+ if (iv(1) .eq. 12 .or. iv(1) .eq. 13)
+ 1 iv(vneed) = iv(vneed) + n*(n+21)/2 + 7
+ call parck(2, d, iv, liv, lv, n, v)
+ i = iv(1) - 2
+ if (i .gt. 12) go to 999
+ nn1o2 = n * (n + 1) / 2
+ if (lh .ge. nn1o2) go to (210,210,210,210,210,210,160,120,160,
+ 1 10,10,20), i
+ iv(1) = 66
+ go to 350
+c
+c *** storage allocation ***
+c
+ 10 iv(dtol) = iv(lmat) + nn1o2
+ iv(x0) = iv(dtol) + 2*n
+ iv(step) = iv(x0) + n
+ iv(stlstg) = iv(step) + n
+ iv(dg) = iv(stlstg) + n
+ iv(w) = iv(dg) + n
+ iv(nextv) = iv(w) + 4*n + 7
+ if (iv(1) .ne. 13) go to 20
+ iv(1) = 14
+ go to 999
+c
+c *** initialization ***
+c
+ 20 iv(niter) = 0
+ iv(nfcall) = 1
+ iv(ngcall) = 1
+ iv(nfgcal) = 1
+ iv(mode) = -1
+ iv(model) = 1
+ iv(stglim) = 1
+ iv(toobig) = 0
+ iv(cnvcod) = 0
+ iv(radinc) = 0
+ v(rad0) = zero
+ v(stppar) = zero
+ if (v(dinit) .ge. zero) call vscopy(n, d, v(dinit))
+ k = iv(dtol)
+ if (v(dtinit) .gt. zero) call vscopy(n, v(k), v(dtinit))
+ k = k + n
+ if (v(d0init) .gt. zero) call vscopy(n, v(k), v(d0init))
+ iv(1) = 1
+ go to 999
+c
+ 30 v(f) = fx
+ if (iv(mode) .ge. 0) go to 210
+ iv(1) = 2
+ if (iv(toobig) .eq. 0) go to 999
+ iv(1) = 63
+ go to 350
+c
+c *** make sure gradient could be computed ***
+c
+ 40 if (iv(nfgcal) .ne. 0) go to 50
+ iv(1) = 65
+ go to 350
+c
+c *** update the scale vector d ***
+c
+ 50 dg1 = iv(dg)
+ if (iv(dtype) .le. 0) go to 70
+ k = dg1
+ j = 0
+ do 60 i = 1, n
+ j = j + i
+ v(k) = h(j)
+ k = k + 1
+ 60 continue
+ call dupdu(d, v(dg1), iv, liv, lv, n, v)
+c
+c *** compute scaled gradient and its norm ***
+c
+ 70 dg1 = iv(dg)
+ k = dg1
+ do 80 i = 1, n
+ v(k) = g(i) / d(i)
+ k = k + 1
+ 80 continue
+ v(dgnorm) = v2norm(n, v(dg1))
+c
+c *** compute scaled hessian ***
+c
+ k = 1
+ do 100 i = 1, n
+ t = one / d(i)
+ do 90 j = 1, i
+ h(k) = t * h(k) / d(j)
+ k = k + 1
+ 90 continue
+ 100 continue
+c
+ if (iv(cnvcod) .ne. 0) go to 340
+ if (iv(mode) .eq. 0) go to 300
+c
+c *** allow first step to have scaled 2-norm at most v(lmax0) ***
+c
+ v(radius) = v(lmax0)
+c
+ iv(mode) = 0
+c
+c
+c----------------------------- main loop -----------------------------
+c
+c
+c *** print iteration summary, check iteration limit ***
+c
+ 110 call itsum(d, g, iv, liv, lv, n, v, x)
+ 120 k = iv(niter)
+ if (k .lt. iv(mxiter)) go to 130
+ iv(1) = 10
+ go to 350
+c
+ 130 iv(niter) = k + 1
+c
+c *** initialize for start of next iteration ***
+c
+ dg1 = iv(dg)
+ x01 = iv(x0)
+ v(f0) = v(f)
+ iv(irc) = 4
+ iv(kagqt) = -1
+c
+c *** copy x to x0 ***
+c
+ call vcopy(n, v(x01), x)
+c
+c *** update radius ***
+c
+ if (k .eq. 0) go to 150
+ step1 = iv(step)
+ k = step1
+ do 140 i = 1, n
+ v(k) = d(i) * v(k)
+ k = k + 1
+ 140 continue
+ v(radius) = v(radfac) * v2norm(n, v(step1))
+c
+c *** check stopx and function evaluation limit ***
+c
+C AL 4/30/95
+ dummy=iv(nfcall)
+ 150 if (.not. stopx(dummy)) go to 170
+ iv(1) = 11
+ go to 180
+c
+c *** come here when restarting after func. eval. limit or stopx.
+c
+ 160 if (v(f) .ge. v(f0)) go to 170
+ v(radfac) = one
+ k = iv(niter)
+ go to 130
+c
+ 170 if (iv(nfcall) .lt. iv(mxfcal)) go to 190
+ iv(1) = 9
+ 180 if (v(f) .ge. v(f0)) go to 350
+c
+c *** in case of stopx or function evaluation limit with
+c *** improved v(f), evaluate the gradient at x.
+c
+ iv(cnvcod) = iv(1)
+ go to 290
+c
+c. . . . . . . . . . . . . compute candidate step . . . . . . . . . .
+c
+ 190 step1 = iv(step)
+ dg1 = iv(dg)
+ l = iv(lmat)
+ w1 = iv(w)
+ call gqtst(d, v(dg1), h, iv(kagqt), v(l), n, v(step1), v, v(w1))
+ if (iv(irc) .eq. 6) go to 210
+c
+c *** check whether evaluating f(x0 + step) looks worthwhile ***
+c
+ if (v(dstnrm) .le. zero) go to 210
+ if (iv(irc) .ne. 5) go to 200
+ if (v(radfac) .le. one) go to 200
+ if (v(preduc) .le. onep2 * v(fdif)) go to 210
+c
+c *** compute f(x0 + step) ***
+c
+ 200 x01 = iv(x0)
+ step1 = iv(step)
+ call vaxpy(n, x, one, v(step1), v(x01))
+ iv(nfcall) = iv(nfcall) + 1
+ iv(1) = 1
+ iv(toobig) = 0
+ go to 999
+c
+c. . . . . . . . . . . . . assess candidate step . . . . . . . . . . .
+c
+ 210 x01 = iv(x0)
+ v(reldx) = reldst(n, d, x, v(x01))
+ call assst(iv, liv, lv, v)
+ step1 = iv(step)
+ lstgst = iv(stlstg)
+ if (iv(restor) .eq. 1) call vcopy(n, x, v(x01))
+ if (iv(restor) .eq. 2) call vcopy(n, v(lstgst), v(step1))
+ if (iv(restor) .ne. 3) go to 220
+ call vcopy(n, v(step1), v(lstgst))
+ call vaxpy(n, x, one, v(step1), v(x01))
+ v(reldx) = reldst(n, d, x, v(x01))
+c
+ 220 k = iv(irc)
+ go to (230,260,260,260,230,240,250,250,250,250,250,250,330,300), k
+c
+c *** recompute step with new radius ***
+c
+ 230 v(radius) = v(radfac) * v(dstnrm)
+ go to 150
+c
+c *** compute step of length v(lmaxs) for singular convergence test.
+c
+ 240 v(radius) = v(lmaxs)
+ go to 190
+c
+c *** convergence or false convergence ***
+c
+ 250 iv(cnvcod) = k - 4
+ if (v(f) .ge. v(f0)) go to 340
+ if (iv(xirc) .eq. 14) go to 340
+ iv(xirc) = 14
+c
+c. . . . . . . . . . . . process acceptable step . . . . . . . . . . .
+c
+ 260 if (iv(irc) .ne. 3) go to 290
+ temp1 = lstgst
+c
+c *** prepare for gradient tests ***
+c *** set temp1 = hessian * step + g(x0)
+c *** = diag(d) * (h * step + g(x0))
+c
+c use x0 vector as temporary.
+ k = x01
+ do 270 i = 1, n
+ v(k) = d(i) * v(step1)
+ k = k + 1
+ step1 = step1 + 1
+ 270 continue
+ call slvmul(n, v(temp1), h, v(x01))
+ do 280 i = 1, n
+ v(temp1) = d(i) * v(temp1) + g(i)
+ temp1 = temp1 + 1
+ 280 continue
+c
+c *** compute gradient and hessian ***
+c
+ 290 iv(ngcall) = iv(ngcall) + 1
+ iv(1) = 2
+ go to 999
+c
+ 300 iv(1) = 2
+ if (iv(irc) .ne. 3) go to 110
+c
+c *** set v(radfac) by gradient tests ***
+c
+ temp1 = iv(stlstg)
+ step1 = iv(step)
+c
+c *** set temp1 = diag(d)**-1 * (hessian*step + (g(x0)-g(x))) ***
+c
+ k = temp1
+ do 310 i = 1, n
+ v(k) = (v(k) - g(i)) / d(i)
+ k = k + 1
+ 310 continue
+c
+c *** do gradient tests ***
+c
+ if (v2norm(n, v(temp1)) .le. v(dgnorm) * v(tuner4)) go to 320
+ if (dotprd(n, g, v(step1))
+ 1 .ge. v(gtstep) * v(tuner5)) go to 110
+ 320 v(radfac) = v(incfac)
+ go to 110
+c
+c. . . . . . . . . . . . . . misc. details . . . . . . . . . . . . . .
+c
+c *** bad parameters to assess ***
+c
+ 330 iv(1) = 64
+ go to 350
+c
+c *** print summary of final iteration and other requested items ***
+c
+ 340 iv(1) = iv(cnvcod)
+ iv(cnvcod) = 0
+ 350 call itsum(d, g, iv, liv, lv, n, v, x)
+c
+ 999 return
+c
+c *** last card of humit follows ***
+ end
+ subroutine dupdu(d, hdiag, iv, liv, lv, n, v)
+c
+c *** update scale vector d for humsl ***
+c
+c *** parameter declarations ***
+c
+ integer liv, lv, n
+ integer iv(liv)
+ double precision d(n), hdiag(n), v(lv)
+c
+c *** local variables ***
+c
+ integer dtoli, d0i, i
+ double precision t, vdfac
+c
+c *** intrinsic functions ***
+c/+
+ double precision dabs, dmax1, dsqrt
+c/
+c *** subscripts for iv and v ***
+c
+ integer dfac, dtol, dtype, niter
+c/6
+c data dfac/41/, dtol/59/, dtype/16/, niter/31/
+c/7
+ parameter (dfac=41, dtol=59, dtype=16, niter=31)
+c/
+c
+c------------------------------- body --------------------------------
+c
+ i = iv(dtype)
+ if (i .eq. 1) go to 10
+ if (iv(niter) .gt. 0) go to 999
+c
+ 10 dtoli = iv(dtol)
+ d0i = dtoli + n
+ vdfac = v(dfac)
+ do 20 i = 1, n
+ t = dmax1(dsqrt(dabs(hdiag(i))), vdfac*d(i))
+ if (t .lt. v(dtoli)) t = dmax1(v(dtoli), v(d0i))
+ d(i) = t
+ dtoli = dtoli + 1
+ d0i = d0i + 1
+ 20 continue
+c
+ 999 return
+c *** last card of dupdu follows ***
+ end
+ subroutine gqtst(d, dig, dihdi, ka, l, p, step, v, w)
+c
+c *** compute goldfeld-quandt-trotter step by more-hebden technique ***
+c *** (nl2sol version 2.2), modified a la more and sorensen ***
+c
+c *** parameter declarations ***
+c
+ integer ka, p
+cal double precision d(p), dig(p), dihdi(1), l(1), v(21), step(p),
+cal 1 w(1)
+ double precision d(p), dig(p), dihdi(p*(p+1)/2), l(p*(p+1)/2),
+ 1 v(21), step(p),w(4*p+7)
+c dimension dihdi(p*(p+1)/2), l(p*(p+1)/2), w(4*p+7)
+c
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c
+c *** purpose ***
+c
+c given the (compactly stored) lower triangle of a scaled
+c hessian (approximation) and a nonzero scaled gradient vector,
+c this subroutine computes a goldfeld-quandt-trotter step of
+c approximate length v(radius) by the more-hebden technique. in
+c other words, step is computed to (approximately) minimize
+c psi(step) = (g**t)*step + 0.5*(step**t)*h*step such that the
+c 2-norm of d*step is at most (approximately) v(radius), where
+c g is the gradient, h is the hessian, and d is a diagonal
+c scale matrix whose diagonal is stored in the parameter d.
+c (gqtst assumes dig = d**-1 * g and dihdi = d**-1 * h * d**-1.)
+c
+c *** parameter description ***
+c
+c d (in) = the scale vector, i.e. the diagonal of the scale
+c matrix d mentioned above under purpose.
+c dig (in) = the scaled gradient vector, d**-1 * g. if g = 0, then
+c step = 0 and v(stppar) = 0 are returned.
+c dihdi (in) = lower triangle of the scaled hessian (approximation),
+c i.e., d**-1 * h * d**-1, stored compactly by rows., i.e.,
+c in the order (1,1), (2,1), (2,2), (3,1), (3,2), etc.
+c ka (i/o) = the number of hebden iterations (so far) taken to deter-
+c mine step. ka .lt. 0 on input means this is the first
+c attempt to determine step (for the present dig and dihdi)
+c -- ka is initialized to 0 in this case. output with
+c ka = 0 (or v(stppar) = 0) means step = -(h**-1)*g.
+c l (i/o) = workspace of length p*(p+1)/2 for cholesky factors.
+c p (in) = number of parameters -- the hessian is a p x p matrix.
+c step (i/o) = the step computed.
+c v (i/o) contains various constants and variables described below.
+c w (i/o) = workspace of length 4*p + 6.
+c
+c *** entries in v ***
+c
+c v(dgnorm) (i/o) = 2-norm of (d**-1)*g.
+c v(dstnrm) (output) = 2-norm of d*step.
+c v(dst0) (i/o) = 2-norm of d*(h**-1)*g (for pos. def. h only), or
+c overestimate of smallest eigenvalue of (d**-1)*h*(d**-1).
+c v(epslon) (in) = max. rel. error allowed for psi(step). for the
+c step returned, psi(step) will exceed its optimal value
+c by less than -v(epslon)*psi(step). suggested value = 0.1.
+c v(gtstep) (out) = inner product between g and step.
+c v(nreduc) (out) = psi(-(h**-1)*g) = psi(newton step) (for pos. def.
+c h only -- v(nreduc) is set to zero otherwise).
+c v(phmnfc) (in) = tol. (together with v(phmxfc)) for accepting step
+c (more*s sigma). the error v(dstnrm) - v(radius) must lie
+c between v(phmnfc)*v(radius) and v(phmxfc)*v(radius).
+c v(phmxfc) (in) (see v(phmnfc).)
+c suggested values -- v(phmnfc) = -0.25, v(phmxfc) = 0.5.
+c v(preduc) (out) = psi(step) = predicted obj. func. reduction for step.
+c v(radius) (in) = radius of current (scaled) trust region.
+c v(rad0) (i/o) = value of v(radius) from previous call.
+c v(stppar) (i/o) is normally the marquardt parameter, i.e. the alpha
+c described below under algorithm notes. if h + alpha*d**2
+c (see algorithm notes) is (nearly) singular, however,
+c then v(stppar) = -alpha.
+c
+c *** usage notes ***
+c
+c if it is desired to recompute step using a different value of
+c v(radius), then this routine may be restarted by calling it
+c with all parameters unchanged except v(radius). (this explains
+c why step and w are listed as i/o). on an initial call (one with
+c ka .lt. 0), step and w need not be initialized and only compo-
+c nents v(epslon), v(stppar), v(phmnfc), v(phmxfc), v(radius), and
+c v(rad0) of v must be initialized.
+c
+c *** algorithm notes ***
+c
+c the desired g-q-t step (ref. 2, 3, 4, 6) satisfies
+c (h + alpha*d**2)*step = -g for some nonnegative alpha such that
+c h + alpha*d**2 is positive semidefinite. alpha and step are
+c computed by a scheme analogous to the one described in ref. 5.
+c estimates of the smallest and largest eigenvalues of the hessian
+c are obtained from the gerschgorin circle theorem enhanced by a
+c simple form of the scaling described in ref. 7. cases in which
+c h + alpha*d**2 is nearly (or exactly) singular are handled by
+c the technique discussed in ref. 2. in these cases, a step of
+c (exact) length v(radius) is returned for which psi(step) exceeds
+c its optimal value by less than -v(epslon)*psi(step). the test
+c suggested in ref. 6 for detecting the special case is performed
+c once two matrix factorizations have been done -- doing so sooner
+c seems to degrade the performance of optimization routines that
+c call this routine.
+c
+c *** functions and subroutines called ***
+c
+c dotprd - returns inner product of two vectors.
+c litvmu - applies inverse-transpose of compact lower triang. matrix.
+c livmul - applies inverse of compact lower triang. matrix.
+c lsqrt - finds cholesky factor (of compactly stored lower triang.).
+c lsvmin - returns approx. to min. sing. value of lower triang. matrix.
+c rmdcon - returns machine-dependent constants.
+c v2norm - returns 2-norm of a vector.
+c
+c *** references ***
+c
+c 1. dennis, j.e., gay, d.m., and welsch, r.e. (1981), an adaptive
+c nonlinear least-squares algorithm, acm trans. math.
+c software, vol. 7, no. 3.
+c 2. gay, d.m. (1981), computing optimal locally constrained steps,
+c siam j. sci. statist. computing, vol. 2, no. 2, pp.
+c 186-197.
+c 3. goldfeld, s.m., quandt, r.e., and trotter, h.f. (1966),
+c maximization by quadratic hill-climbing, econometrica 34,
+c pp. 541-551.
+c 4. hebden, m.d. (1973), an algorithm for minimization using exact
+c second derivatives, report t.p. 515, theoretical physics
+c div., a.e.r.e. harwell, oxon., england.
+c 5. more, j.j. (1978), the levenberg-marquardt algorithm, implemen-
+c tation and theory, pp.105-116 of springer lecture notes
+c in mathematics no. 630, edited by g.a. watson, springer-
+c verlag, berlin and new york.
+c 6. more, j.j., and sorensen, d.c. (1981), computing a trust region
+c step, technical report anl-81-83, argonne national lab.
+c 7. varga, r.s. (1965), minimal gerschgorin sets, pacific j. math. 15,
+c pp. 719-729.
+c
+c *** general ***
+c
+c coded by david m. gay.
+c this subroutine was written in connection with research
+c supported by the national science foundation under grants
+c mcs-7600324, dcr75-10143, 76-14311dss, mcs76-11989, and
+c mcs-7906671.
+c
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c
+c *** local variables ***
+c
+ logical restrt
+ integer dggdmx, diag, diag0, dstsav, emax, emin, i, im1, inc, irc,
+ 1 j, k, kalim, kamin, k1, lk0, phipin, q, q0, uk0, x
+ double precision alphak, aki, akk, delta, dst, eps, gtsta, lk,
+ 1 oldphi, phi, phimax, phimin, psifac, rad, radsq,
+ 2 root, si, sk, sw, t, twopsi, t1, t2, uk, wi
+c
+c *** constants ***
+ double precision big, dgxfac, epsfac, four, half, kappa, negone,
+ 1 one, p001, six, three, two, zero
+c
+c *** intrinsic functions ***
+c/+
+ double precision dabs, dmax1, dmin1, dsqrt
+c/
+c *** external functions and subroutines ***
+c
+ external dotprd, litvmu, livmul, lsqrt, lsvmin, rmdcon, v2norm
+ double precision dotprd, lsvmin, rmdcon, v2norm
+c
+c *** subscripts for v ***
+c
+ integer dgnorm, dstnrm, dst0, epslon, gtstep, stppar, nreduc,
+ 1 phmnfc, phmxfc, preduc, radius, rad0
+c/6
+c data dgnorm/1/, dstnrm/2/, dst0/3/, epslon/19/, gtstep/4/,
+c 1 nreduc/6/, phmnfc/20/, phmxfc/21/, preduc/7/, radius/8/,
+c 2 rad0/9/, stppar/5/
+c/7
+ parameter (dgnorm=1, dstnrm=2, dst0=3, epslon=19, gtstep=4,
+ 1 nreduc=6, phmnfc=20, phmxfc=21, preduc=7, radius=8,
+ 2 rad0=9, stppar=5)
+c/
+c
+c/6
+c data epsfac/50.0d+0/, four/4.0d+0/, half/0.5d+0/,
+c 1 kappa/2.0d+0/, negone/-1.0d+0/, one/1.0d+0/, p001/1.0d-3/,
+c 2 six/6.0d+0/, three/3.0d+0/, two/2.0d+0/, zero/0.0d+0/
+c/7
+ parameter (epsfac=50.0d+0, four=4.0d+0, half=0.5d+0,
+ 1 kappa=2.0d+0, negone=-1.0d+0, one=1.0d+0, p001=1.0d-3,
+ 2 six=6.0d+0, three=3.0d+0, two=2.0d+0, zero=0.0d+0)
+ save dgxfac
+c/
+ data big/0.d+0/, dgxfac/0.d+0/
+c
+c *** body ***
+c
+c *** store largest abs. entry in (d**-1)*h*(d**-1) at w(dggdmx).
+ dggdmx = p + 1
+c *** store gerschgorin over- and underestimates of the largest
+c *** and smallest eigenvalues of (d**-1)*h*(d**-1) at w(emax)
+c *** and w(emin) respectively.
+ emax = dggdmx + 1
+ emin = emax + 1
+c *** for use in recomputing step, the final values of lk, uk, dst,
+c *** and the inverse derivative of more*s phi at 0 (for pos. def.
+c *** h) are stored in w(lk0), w(uk0), w(dstsav), and w(phipin)
+c *** respectively.
+ lk0 = emin + 1
+ phipin = lk0 + 1
+ uk0 = phipin + 1
+ dstsav = uk0 + 1
+c *** store diag of (d**-1)*h*(d**-1) in w(diag),...,w(diag0+p).
+ diag0 = dstsav
+ diag = diag0 + 1
+c *** store -d*step in w(q),...,w(q0+p).
+ q0 = diag0 + p
+ q = q0 + 1
+c *** allocate storage for scratch vector x ***
+ x = q + p
+ rad = v(radius)
+ radsq = rad**2
+c *** phitol = max. error allowed in dst = v(dstnrm) = 2-norm of
+c *** d*step.
+ phimax = v(phmxfc) * rad
+ phimin = v(phmnfc) * rad
+ psifac = two * v(epslon) / (three * (four * (v(phmnfc) + one) *
+ 1 (kappa + one) + kappa + two) * rad**2)
+c *** oldphi is used to detect limits of numerical accuracy. if
+c *** we recompute step and it does not change, then we accept it.
+ oldphi = zero
+ eps = v(epslon)
+ irc = 0
+ restrt = .false.
+ kalim = ka + 50
+c
+c *** start or restart, depending on ka ***
+c
+ if (ka .ge. 0) go to 290
+c
+c *** fresh start ***
+c
+ k = 0
+ uk = negone
+ ka = 0
+ kalim = 50
+ v(dgnorm) = v2norm(p, dig)
+ v(nreduc) = zero
+ v(dst0) = zero
+ kamin = 3
+ if (v(dgnorm) .eq. zero) kamin = 0
+c
+c *** store diag(dihdi) in w(diag0+1),...,w(diag0+p) ***
+c
+ j = 0
+ do 10 i = 1, p
+ j = j + i
+ k1 = diag0 + i
+ w(k1) = dihdi(j)
+ 10 continue
+c
+c *** determine w(dggdmx), the largest element of dihdi ***
+c
+ t1 = zero
+ j = p * (p + 1) / 2
+ do 20 i = 1, j
+ t = dabs(dihdi(i))
+ if (t1 .lt. t) t1 = t
+ 20 continue
+ w(dggdmx) = t1
+c
+c *** try alpha = 0 ***
+c
+ 30 call lsqrt(1, p, l, dihdi, irc)
+ if (irc .eq. 0) go to 50
+c *** indef. h -- underestimate smallest eigenvalue, use this
+c *** estimate to initialize lower bound lk on alpha.
+ j = irc*(irc+1)/2
+ t = l(j)
+ l(j) = one
+ do 40 i = 1, irc
+ 40 w(i) = zero
+ w(irc) = one
+ call litvmu(irc, w, l, w)
+ t1 = v2norm(irc, w)
+ lk = -t / t1 / t1
+ v(dst0) = -lk
+ if (restrt) go to 210
+ go to 70
+c
+c *** positive definite h -- compute unmodified newton step. ***
+ 50 lk = zero
+ t = lsvmin(p, l, w(q), w(q))
+ if (t .ge. one) go to 60
+ if (big .le. zero) big = rmdcon(6)
+ if (v(dgnorm) .ge. t*t*big) go to 70
+ 60 call livmul(p, w(q), l, dig)
+ gtsta = dotprd(p, w(q), w(q))
+ v(nreduc) = half * gtsta
+ call litvmu(p, w(q), l, w(q))
+ dst = v2norm(p, w(q))
+ v(dst0) = dst
+ phi = dst - rad
+ if (phi .le. phimax) go to 260
+ if (restrt) go to 210
+c
+c *** prepare to compute gerschgorin estimates of largest (and
+c *** smallest) eigenvalues. ***
+c
+ 70 k = 0
+ do 100 i = 1, p
+ wi = zero
+ if (i .eq. 1) go to 90
+ im1 = i - 1
+ do 80 j = 1, im1
+ k = k + 1
+ t = dabs(dihdi(k))
+ wi = wi + t
+ w(j) = w(j) + t
+ 80 continue
+ 90 w(i) = wi
+ k = k + 1
+ 100 continue
+c
+c *** (under-)estimate smallest eigenvalue of (d**-1)*h*(d**-1) ***
+c
+ k = 1
+ t1 = w(diag) - w(1)
+ if (p .le. 1) go to 120
+ do 110 i = 2, p
+ j = diag0 + i
+ t = w(j) - w(i)
+ if (t .ge. t1) go to 110
+ t1 = t
+ k = i
+ 110 continue
+c
+ 120 sk = w(k)
+ j = diag0 + k
+ akk = w(j)
+ k1 = k*(k-1)/2 + 1
+ inc = 1
+ t = zero
+ do 150 i = 1, p
+ if (i .eq. k) go to 130
+ aki = dabs(dihdi(k1))
+ si = w(i)
+ j = diag0 + i
+ t1 = half * (akk - w(j) + si - aki)
+ t1 = t1 + dsqrt(t1*t1 + sk*aki)
+ if (t .lt. t1) t = t1
+ if (i .lt. k) go to 140
+ 130 inc = i
+ 140 k1 = k1 + inc
+ 150 continue
+c
+ w(emin) = akk - t
+ uk = v(dgnorm)/rad - w(emin)
+ if (v(dgnorm) .eq. zero) uk = uk + p001 + p001*uk
+ if (uk .le. zero) uk = p001
+c
+c *** compute gerschgorin (over-)estimate of largest eigenvalue ***
+c
+ k = 1
+ t1 = w(diag) + w(1)
+ if (p .le. 1) go to 170
+ do 160 i = 2, p
+ j = diag0 + i
+ t = w(j) + w(i)
+ if (t .le. t1) go to 160
+ t1 = t
+ k = i
+ 160 continue
+c
+ 170 sk = w(k)
+ j = diag0 + k
+ akk = w(j)
+ k1 = k*(k-1)/2 + 1
+ inc = 1
+ t = zero
+ do 200 i = 1, p
+ if (i .eq. k) go to 180
+ aki = dabs(dihdi(k1))
+ si = w(i)
+ j = diag0 + i
+ t1 = half * (w(j) + si - aki - akk)
+ t1 = t1 + dsqrt(t1*t1 + sk*aki)
+ if (t .lt. t1) t = t1
+ if (i .lt. k) go to 190
+ 180 inc = i
+ 190 k1 = k1 + inc
+ 200 continue
+c
+ w(emax) = akk + t
+ lk = dmax1(lk, v(dgnorm)/rad - w(emax))
+c
+c *** alphak = current value of alpha (see alg. notes above). we
+c *** use more*s scheme for initializing it.
+ alphak = dabs(v(stppar)) * v(rad0)/rad
+c
+ if (irc .ne. 0) go to 210
+c
+c *** compute l0 for positive definite h ***
+c
+ call livmul(p, w, l, w(q))
+ t = v2norm(p, w)
+ w(phipin) = dst / t / t
+ lk = dmax1(lk, phi*w(phipin))
+c
+c *** safeguard alphak and add alphak*i to (d**-1)*h*(d**-1) ***
+c
+ 210 ka = ka + 1
+ if (-v(dst0) .ge. alphak .or. alphak .lt. lk .or. alphak .ge. uk)
+ 1 alphak = uk * dmax1(p001, dsqrt(lk/uk))
+ if (alphak .le. zero) alphak = half * uk
+ if (alphak .le. zero) alphak = uk
+ k = 0
+ do 220 i = 1, p
+ k = k + i
+ j = diag0 + i
+ dihdi(k) = w(j) + alphak
+ 220 continue
+c
+c *** try computing cholesky decomposition ***
+c
+ call lsqrt(1, p, l, dihdi, irc)
+ if (irc .eq. 0) go to 240
+c
+c *** (d**-1)*h*(d**-1) + alphak*i is indefinite -- overestimate
+c *** smallest eigenvalue for use in updating lk ***
+c
+ j = (irc*(irc+1))/2
+ t = l(j)
+ l(j) = one
+ do 230 i = 1, irc
+ 230 w(i) = zero
+ w(irc) = one
+ call litvmu(irc, w, l, w)
+ t1 = v2norm(irc, w)
+ lk = alphak - t/t1/t1
+ v(dst0) = -lk
+ go to 210
+c
+c *** alphak makes (d**-1)*h*(d**-1) positive definite.
+c *** compute q = -d*step, check for convergence. ***
+c
+ 240 call livmul(p, w(q), l, dig)
+ gtsta = dotprd(p, w(q), w(q))
+ call litvmu(p, w(q), l, w(q))
+ dst = v2norm(p, w(q))
+ phi = dst - rad
+ if (phi .le. phimax .and. phi .ge. phimin) go to 270
+ if (phi .eq. oldphi) go to 270
+ oldphi = phi
+ if (phi .lt. zero) go to 330
+c
+c *** unacceptable alphak -- update lk, uk, alphak ***
+c
+ 250 if (ka .ge. kalim) go to 270
+c *** the following dmin1 is necessary because of restarts ***
+ if (phi .lt. zero) uk = dmin1(uk, alphak)
+c *** kamin = 0 only iff the gradient vanishes ***
+ if (kamin .eq. 0) go to 210
+ call livmul(p, w, l, w(q))
+ t1 = v2norm(p, w)
+ alphak = alphak + (phi/t1) * (dst/t1) * (dst/rad)
+ lk = dmax1(lk, alphak)
+ go to 210
+c
+c *** acceptable step on first try ***
+c
+ 260 alphak = zero
+c
+c *** successful step in general. compute step = -(d**-1)*q ***
+c
+ 270 do 280 i = 1, p
+ j = q0 + i
+ step(i) = -w(j)/d(i)
+ 280 continue
+ v(gtstep) = -gtsta
+ v(preduc) = half * (dabs(alphak)*dst*dst + gtsta)
+ go to 410
+c
+c
+c *** restart with new radius ***
+c
+ 290 if (v(dst0) .le. zero .or. v(dst0) - rad .gt. phimax) go to 310
+c
+c *** prepare to return newton step ***
+c
+ restrt = .true.
+ ka = ka + 1
+ k = 0
+ do 300 i = 1, p
+ k = k + i
+ j = diag0 + i
+ dihdi(k) = w(j)
+ 300 continue
+ uk = negone
+ go to 30
+c
+ 310 kamin = ka + 3
+ if (v(dgnorm) .eq. zero) kamin = 0
+ if (ka .eq. 0) go to 50
+c
+ dst = w(dstsav)
+ alphak = dabs(v(stppar))
+ phi = dst - rad
+ t = v(dgnorm)/rad
+ uk = t - w(emin)
+ if (v(dgnorm) .eq. zero) uk = uk + p001 + p001*uk
+ if (uk .le. zero) uk = p001
+ if (rad .gt. v(rad0)) go to 320
+c
+c *** smaller radius ***
+ lk = zero
+ if (alphak .gt. zero) lk = w(lk0)
+ lk = dmax1(lk, t - w(emax))
+ if (v(dst0) .gt. zero) lk = dmax1(lk, (v(dst0)-rad)*w(phipin))
+ go to 250
+c
+c *** bigger radius ***
+ 320 if (alphak .gt. zero) uk = dmin1(uk, w(uk0))
+ lk = dmax1(zero, -v(dst0), t - w(emax))
+ if (v(dst0) .gt. zero) lk = dmax1(lk, (v(dst0)-rad)*w(phipin))
+ go to 250
+c
+c *** decide whether to check for special case... in practice (from
+c *** the standpoint of the calling optimization code) it seems best
+c *** not to check until a few iterations have failed -- hence the
+c *** test on kamin below.
+c
+ 330 delta = alphak + dmin1(zero, v(dst0))
+ twopsi = alphak*dst*dst + gtsta
+ if (ka .ge. kamin) go to 340
+c *** if the test in ref. 2 is satisfied, fall through to handle
+c *** the special case (as soon as the more-sorensen test detects
+c *** it).
+ if (delta .ge. psifac*twopsi) go to 370
+c
+c *** check for the special case of h + alpha*d**2 (nearly)
+c *** singular. use one step of inverse power method with start
+c *** from lsvmin to obtain approximate eigenvector corresponding
+c *** to smallest eigenvalue of (d**-1)*h*(d**-1). lsvmin returns
+c *** x and w with l*w = x.
+c
+ 340 t = lsvmin(p, l, w(x), w)
+c
+c *** normalize w ***
+ do 350 i = 1, p
+ 350 w(i) = t*w(i)
+c *** complete current inv. power iter. -- replace w by (l**-t)*w.
+ call litvmu(p, w, l, w)
+ t2 = one/v2norm(p, w)
+ do 360 i = 1, p
+ 360 w(i) = t2*w(i)
+ t = t2 * t
+c
+c *** now w is the desired approximate (unit) eigenvector and
+c *** t*x = ((d**-1)*h*(d**-1) + alphak*i)*w.
+c
+ sw = dotprd(p, w(q), w)
+ t1 = (rad + dst) * (rad - dst)
+ root = dsqrt(sw*sw + t1)
+ if (sw .lt. zero) root = -root
+ si = t1 / (sw + root)
+c
+c *** the actual test for the special case...
+c
+ if ((t2*si)**2 .le. eps*(dst**2 + alphak*radsq)) go to 380
+c
+c *** update upper bound on smallest eigenvalue (when not positive)
+c *** (as recommended by more and sorensen) and continue...
+c
+ if (v(dst0) .le. zero) v(dst0) = dmin1(v(dst0), t2**2 - alphak)
+ lk = dmax1(lk, -v(dst0))
+c
+c *** check whether we can hope to detect the special case in
+c *** the available arithmetic. accept step as it is if not.
+c
+c *** if not yet available, obtain machine dependent value dgxfac.
+ 370 if (dgxfac .eq. zero) dgxfac = epsfac * rmdcon(3)
+c
+ if (delta .gt. dgxfac*w(dggdmx)) go to 250
+ go to 270
+c
+c *** special case detected... negate alphak to indicate special case
+c
+ 380 alphak = -alphak
+ v(preduc) = half * twopsi
+c
+c *** accept current step if adding si*w would lead to a
+c *** further relative reduction in psi of less than v(epslon)/3.
+c
+ t1 = zero
+ t = si*(alphak*sw - half*si*(alphak + t*dotprd(p,w(x),w)))
+ if (t .lt. eps*twopsi/six) go to 390
+ v(preduc) = v(preduc) + t
+ dst = rad
+ t1 = -si
+ 390 do 400 i = 1, p
+ j = q0 + i
+ w(j) = t1*w(i) - w(j)
+ step(i) = w(j) / d(i)
+ 400 continue
+ v(gtstep) = dotprd(p, dig, w(q))
+c
+c *** save values for use in a possible restart ***
+c
+ 410 v(dstnrm) = dst
+ v(stppar) = alphak
+ w(lk0) = lk
+ w(uk0) = uk
+ v(rad0) = rad
+ w(dstsav) = dst
+c
+c *** restore diagonal of dihdi ***
+c
+ j = 0
+ do 420 i = 1, p
+ j = j + i
+ k = diag0 + i
+ dihdi(j) = w(k)
+ 420 continue
+c
+ 999 return
+c
+c *** last card of gqtst follows ***
+ end
+ subroutine lsqrt(n1, n, l, a, irc)
+c
+c *** compute rows n1 through n of the cholesky factor l of
+c *** a = l*(l**t), where l and the lower triangle of a are both
+c *** stored compactly by rows (and may occupy the same storage).
+c *** irc = 0 means all went well. irc = j means the leading
+c *** principal j x j submatrix of a is not positive definite --
+c *** and l(j*(j+1)/2) contains the (nonpos.) reduced j-th diagonal.
+c
+c *** parameters ***
+c
+ integer n1, n, irc
+cal double precision l(1), a(1)
+ double precision l(n*(n+1)/2), a(n*(n+1)/2)
+c dimension l(n*(n+1)/2), a(n*(n+1)/2)
+c
+c *** local variables ***
+c
+ integer i, ij, ik, im1, i0, j, jk, jm1, j0, k
+ double precision t, td, zero
+c
+c *** intrinsic functions ***
+c/+
+ double precision dsqrt
+c/
+c/6
+c data zero/0.d+0/
+c/7
+ parameter (zero=0.d+0)
+c/
+c
+c *** body ***
+c
+ i0 = n1 * (n1 - 1) / 2
+ do 50 i = n1, n
+ td = zero
+ if (i .eq. 1) go to 40
+ j0 = 0
+ im1 = i - 1
+ do 30 j = 1, im1
+ t = zero
+ if (j .eq. 1) go to 20
+ jm1 = j - 1
+ do 10 k = 1, jm1
+ ik = i0 + k
+ jk = j0 + k
+ t = t + l(ik)*l(jk)
+ 10 continue
+ 20 ij = i0 + j
+ j0 = j0 + j
+ t = (a(ij) - t) / l(j0)
+ l(ij) = t
+ td = td + t*t
+ 30 continue
+ 40 i0 = i0 + i
+ t = a(i0) - td
+ if (t .le. zero) go to 60
+ l(i0) = dsqrt(t)
+ 50 continue
+c
+ irc = 0
+ go to 999
+c
+ 60 l(i0) = t
+ irc = i
+c
+ 999 return
+c
+c *** last card of lsqrt ***
+ end
+ double precision function lsvmin(p, l, x, y)
+c
+c *** estimate smallest sing. value of packed lower triang. matrix l
+c
+c *** parameter declarations ***
+c
+ integer p
+cal double precision l(1), x(p), y(p)
+ double precision l(p*(p+1)/2), x(p), y(p)
+c dimension l(p*(p+1)/2)
+c
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c
+c *** purpose ***
+c
+c this function returns a good over-estimate of the smallest
+c singular value of the packed lower triangular matrix l.
+c
+c *** parameter description ***
+c
+c p (in) = the order of l. l is a p x p lower triangular matrix.
+c l (in) = array holding the elements of l in row order, i.e.
+c l(1,1), l(2,1), l(2,2), l(3,1), l(3,2), l(3,3), etc.
+c x (out) if lsvmin returns a positive value, then x is a normalized
+c approximate left singular vector corresponding to the
+c smallest singular value. this approximation may be very
+c crude. if lsvmin returns zero, then some components of x
+c are zero and the rest retain their input values.
+c y (out) if lsvmin returns a positive value, then y = (l**-1)*x is an
+c unnormalized approximate right singular vector correspond-
+c ing to the smallest singular value. this approximation
+c may be crude. if lsvmin returns zero, then y retains its
+c input value. the caller may pass the same vector for x
+c and y (nonstandard fortran usage), in which case y over-
+c writes x (for nonzero lsvmin returns).
+c
+c *** algorithm notes ***
+c
+c the algorithm is based on (1), with the additional provision that
+c lsvmin = 0 is returned if the smallest diagonal element of l
+c (in magnitude) is not more than the unit roundoff times the
+c largest. the algorithm uses a random number generator proposed
+c in (4), which passes the spectral test with flying colors -- see
+c (2) and (3).
+c
+c *** subroutines and functions called ***
+c
+c v2norm - function, returns the 2-norm of a vector.
+c
+c *** references ***
+c
+c (1) cline, a., moler, c., stewart, g., and wilkinson, j.h.(1977),
+c an estimate for the condition number of a matrix, report
+c tm-310, applied math. div., argonne national laboratory.
+c
+c (2) hoaglin, d.c. (1976), theoretical properties of congruential
+c random-number generators -- an empirical view,
+c memorandum ns-340, dept. of statistics, harvard univ.
+c
+c (3) knuth, d.e. (1969), the art of computer programming, vol. 2
+c (seminumerical algorithms), addison-wesley, reading, mass.
+c
+c (4) smith, c.s. (1971), multiplicative pseudo-random number
+c generators with prime modulus, j. assoc. comput. mach. 18,
+c pp. 586-593.
+c
+c *** history ***
+c
+c designed and coded by david m. gay (winter 1977/summer 1978).
+c
+c *** general ***
+c
+c this subroutine was written in connection with research
+c supported by the national science foundation under grants
+c mcs-7600324, dcr75-10143, 76-14311dss, and mcs76-11989.
+c
+c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c
+c *** local variables ***
+c
+ integer i, ii, ix, j, ji, jj, jjj, jm1, j0, pm1
+ double precision b, sminus, splus, t, xminus, xplus
+c
+c *** constants ***
+c
+ double precision half, one, r9973, zero
+c
+c *** intrinsic functions ***
+c/+
+ integer mod
+ real float
+ double precision dabs
+c/
+c *** external functions and subroutines ***
+c
+ external dotprd, v2norm, vaxpy
+ double precision dotprd, v2norm
+c
+c/6
+c data half/0.5d+0/, one/1.d+0/, r9973/9973.d+0/, zero/0.d+0/
+c/7
+ parameter (half=0.5d+0, one=1.d+0, r9973=9973.d+0, zero=0.d+0)
+c/
+c
+c *** body ***
+c
+ ix = 2
+ pm1 = p - 1
+c
+c *** first check whether to return lsvmin = 0 and initialize x ***
+c
+ ii = 0
+ j0 = p*pm1/2
+ jj = j0 + p
+ if (l(jj) .eq. zero) go to 110
+ ix = mod(3432*ix, 9973)
+ b = half*(one + float(ix)/r9973)
+ xplus = b / l(jj)
+ x(p) = xplus
+ if (p .le. 1) go to 60
+ do 10 i = 1, pm1
+ ii = ii + i
+ if (l(ii) .eq. zero) go to 110
+ ji = j0 + i
+ x(i) = xplus * l(ji)
+ 10 continue
+c
+c *** solve (l**t)*x = b, where the components of b have randomly
+c *** chosen magnitudes in (.5,1) with signs chosen to make x large.
+c
+c do j = p-1 to 1 by -1...
+ do 50 jjj = 1, pm1
+ j = p - jjj
+c *** determine x(j) in this iteration. note for i = 1,2,...,j
+c *** that x(i) holds the current partial sum for row i.
+ ix = mod(3432*ix, 9973)
+ b = half*(one + float(ix)/r9973)
+ xplus = (b - x(j))
+ xminus = (-b - x(j))
+ splus = dabs(xplus)
+ sminus = dabs(xminus)
+ jm1 = j - 1
+ j0 = j*jm1/2
+ jj = j0 + j
+ xplus = xplus/l(jj)
+ xminus = xminus/l(jj)
+ if (jm1 .eq. 0) go to 30
+ do 20 i = 1, jm1
+ ji = j0 + i
+ splus = splus + dabs(x(i) + l(ji)*xplus)
+ sminus = sminus + dabs(x(i) + l(ji)*xminus)
+ 20 continue
+ 30 if (sminus .gt. splus) xplus = xminus
+ x(j) = xplus
+c *** update partial sums ***
+ if (jm1 .gt. 0) call vaxpy(jm1, x, xplus, l(j0+1), x)
+ 50 continue
+c
+c *** normalize x ***
+c
+ 60 t = one/v2norm(p, x)
+ do 70 i = 1, p
+ 70 x(i) = t*x(i)
+c
+c *** solve l*y = x and return lsvmin = 1/twonorm(y) ***
+c
+ do 100 j = 1, p
+ jm1 = j - 1
+ j0 = j*jm1/2
+ jj = j0 + j
+ t = zero
+ if (jm1 .gt. 0) t = dotprd(jm1, l(j0+1), y)
+ y(j) = (x(j) - t) / l(jj)
+ 100 continue
+c
+ lsvmin = one/v2norm(p, y)
+ go to 999
+c
+ 110 lsvmin = zero
+ 999 return
+c *** last card of lsvmin follows ***
+ end
+ subroutine slvmul(p, y, s, x)
+c
+c *** set y = s * x, s = p x p symmetric matrix. ***
+c *** lower triangle of s stored rowwise. ***
+c
+c *** parameter declarations ***
+c
+ integer p
+cal double precision s(1), x(p), y(p)
+ double precision s(p*(p+1)/2), x(p), y(p)
+c dimension s(p*(p+1)/2)
+c
+c *** local variables ***
+c
+ integer i, im1, j, k
+ double precision xi
+c
+c *** no intrinsic functions ***
+c
+c *** external function ***
+c
+ external dotprd
+ double precision dotprd
+c
+c-----------------------------------------------------------------------
+c
+ j = 1
+ do 10 i = 1, p
+ y(i) = dotprd(i, s(j), x)
+ j = j + i
+ 10 continue
+c
+ if (p .le. 1) go to 999
+ j = 1
+ do 40 i = 2, p
+ xi = x(i)
+ im1 = i - 1
+ j = j + 1
+ do 30 k = 1, im1
+ y(k) = y(k) + s(j)*xi
+ j = j + 1
+ 30 continue
+ 40 continue
+c
+ 999 return
+c *** last card of slvmul follows ***
+ end
--- /dev/null
+ subroutine secstrp2dihc
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.BOUNDS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.TORCNSTR'
+ include 'COMMON.IOUNITS'
+ character*1 secstruc(maxres)
+ COMMON/SECONDARYS/secstruc
+ character*80 line
+ logical errflag
+ external ilen
+
+cdr call getenv_loc('SECPREDFIL',secpred)
+ lenpre=ilen(prefix)
+ secpred=prefix(:lenpre)//'.spred'
+
+#if defined(WINIFL) || defined(WINPGI)
+ open(isecpred,file=secpred,status='old',readonly,shared)
+#elif (defined CRAY) || (defined AIX)
+ open(isecpred,file=secpred,status='old',action='read')
+#elif (defined G77)
+ open(isecpred,file=secpred,status='old')
+#else
+ open(isecpred,file=secpred,status='old',action='read')
+#endif
+C read secondary structure prediction from JPRED here!
+! read(isecpred,'(A80)',err=100,end=100) line
+! read(line,'(f10.3)',err=110) ftors
+ read(isecpred,'(f10.3)',err=110) ftors
+
+ write (iout,*) 'FTORS factor =',ftors
+! initialize secstruc to any
+ do i=1,nres
+ secstruc(i) ='-'
+ enddo
+ ndih_constr=0
+ ndih_nconstr=0
+
+ call read_secstr_pred(isecpred,iout,errflag)
+ if (errflag) then
+ write(iout,*)'There is a problem with the list of secondary-',
+ & 'structure prediction'
+ goto 100
+ endif
+C 8/13/98 Set limits to generating the dihedral angles
+ do i=1,nres
+ phibound(1,i)=-pi
+ phibound(2,i)=pi
+ enddo
+
+ ii=0
+ do i=1,nres
+ if ( secstruc(i) .eq. 'H') then
+C Helix restraints for this residue
+ ii=ii+1
+ idih_constr(ii)=i
+ phi0(ii) = 45.0D0*deg2rad
+ drange(ii)= 5.0D0*deg2rad
+ phibound(1,i) = phi0(ii)-drange(ii)
+ phibound(2,i) = phi0(ii)+drange(ii)
+ else if (secstruc(i) .eq. 'E') then
+C strand restraints for this residue
+ ii=ii+1
+ idih_constr(ii)=i
+ phi0(ii) = 180.0D0*deg2rad
+ drange(ii)= 5.0D0*deg2rad
+ phibound(1,i) = phi0(ii)-drange(ii)
+ phibound(2,i) = phi0(ii)+drange(ii)
+ else
+C no restraints for this residue
+ ndih_nconstr=ndih_nconstr+1
+ idih_nconstr(ndih_nconstr)=i
+ endif
+ enddo
+ ndih_constr=ii
+ return
+100 continue
+ write(iout,'(A30,A80)')'Error reading file SECPRED',secpred
+ return
+ 110 continue
+ write(iout,'(A20)')'Error reading FTORS'
+ return
+ end
+
+ subroutine read_secstr_pred(jin,jout,errors)
+
+ implicit real*8 (a-h,o-z)
+ INCLUDE 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ character*1 secstruc(maxres)
+ COMMON/SECONDARYS/secstruc
+ EXTERNAL ILEN
+ character*80 line,line1,ucase
+ logical errflag,errors,blankline
+
+ errors=.false.
+ read (jin,'(a)') line
+ write (jout,'(2a)') '> ',line(1:78)
+ line1=ucase(line)
+C Remember that we number full residues starting from 2, then, iseq=1 and iseq=nres
+C correspond to the end-groups. ADD to the secondary structure prediction "-" for the
+C end-groups in the input file "*.spred"
+
+ iseq=1
+ do while (index(line1,'$END').eq.0)
+* Override commented lines.
+ ipos=1
+ blankline=.false.
+ do while (.not.blankline)
+ line1=' '
+ call mykey(line,line1,ipos,blankline,errflag)
+ if (errflag) write (jout,'(2a)')
+ & 'Error when reading sequence in line: ',line
+ errors=errors .or. errflag
+ if (.not. blankline .and. .not. errflag) then
+ ipos1=2
+ iend=ilen(line1)
+ if (iseq.le.maxres) then
+ if (line1(1:1).eq.'-' ) then
+ secstruc(iseq)=line1(1:1)
+ else if ( ( ucase(line1(1:1)).eq.'E' ) .or.
+ & ( ucase(line1(1:1)).eq.'H' ) ) then
+ secstruc(iseq)=ucase(line1(1:1))
+ else
+ errors=.true.
+ write (jout,1010) line1(1:1), iseq
+ goto 80
+ endif
+ else
+ errors=.true.
+ write (jout,1000) iseq,maxres
+ goto 80
+ endif
+ do while (ipos1.le.iend)
+
+ iseq=iseq+1
+ il=1
+ ipos1=ipos1+1
+ if (iseq.le.maxres) then
+ if (line1(ipos1-1:ipos1-1).eq.'-' ) then
+ secstruc(iseq)=line1(ipos1-1:ipos1-1)
+ else if((ucase(line1(ipos1-1:ipos1-1)).eq.'E').or.
+ & (ucase(line1(ipos1-1:ipos1-1)).eq.'H') ) then
+ secstruc(iseq)=ucase(line1(ipos1-1:ipos1-1))
+ else
+ errors=.true.
+ write (jout,1010) line1(ipos1-1:ipos1-1), iseq
+ goto 80
+ endif
+ else
+ errors=.true.
+ write (jout,1000) iseq,maxres
+ goto 80
+ endif
+ enddo
+ iseq=iseq+1
+ endif
+ enddo
+ read (jin,'(a)') line
+ write (jout,'(2a)') '> ',line(1:78)
+ line1=ucase(line)
+ enddo
+
+cd write (jout,'(10a8)') (sequence(i),i=1,iseq-1)
+
+cd check whether the found length of the chain is correct.
+ length_of_chain=iseq-1
+ if (length_of_chain .ne. nres) then
+! errors=.true.
+ write (jout,'(a,i4,a,i4,a)')
+ & 'Error: the number of labels specified in $SEC_STRUC_PRED ('
+ & ,length_of_chain,') does not match with the number of residues ('
+ & ,nres,').'
+ endif
+ 80 continue
+
+ 1000 format('Error - the number of residues (',i4,
+ & ') has exceeded maximum (',i4,').')
+ 1010 format ('Error - unrecognized secondary structure label',a4,
+ & ' in position',i4)
+ return
+ end
--- /dev/null
+ SUBROUTINE DJACOB(N,NMAX,MAXJAC,E,A,C,AII)
+ IMPLICIT REAL*8 (A-H,O-Z)
+C THE JACOBI DIAGONALIZATION PROCEDURE
+ COMMON INP,IOUT,IPN
+ DIMENSION A(NMAX,N),C(NMAX,N),AII(150),AJJ(150)
+ SIN45 = .70710678
+ COS45 = .70710678
+ S45SQ = 0.50
+ C45SQ = 0.50
+C UNIT EIGENVECTOR MATRIX
+ DO 70 I = 1,N
+ DO 7 J = I,N
+ A(J,I)=A(I,J)
+ C(I,J) = 0.0
+ 7 C(J,I) = 0.0
+ 70 C(I,I) = 1.0
+C DETERMINATION OF SEARCH ARGUMENT, TEST
+ AMAX = 0.0
+ DO 1 I = 1,N
+ DO 1 J = 1,I
+ TEMPA=DABS(A(I,J))
+ IF (AMAX-TEMPA) 2,1,1
+ 2 AMAX = TEMPA
+ 1 CONTINUE
+ TEST = AMAX*E
+C SEARCH FOR LARGEST OFF DIAGONAL ELEMENT
+ DO 72 IJAC=1,MAXJAC
+ AIJMAX = 0.0
+ DO 3 I = 2,N
+ LIM = I-1
+ DO 3 J = 1,LIM
+ TAIJ=DABS(A(I,J))
+ IF (AIJMAX-TAIJ) 4,3,3
+ 4 AIJMAX = TAIJ
+ IPIV = I
+ JPIV = J
+ 3 CONTINUE
+ IF(AIJMAX-TEST)300,300,5
+C PARAMETERS FOR ROTATION
+ 5 TAII = A(IPIV,IPIV)
+ TAJJ = A(JPIV,JPIV)
+ TAIJ = A(IPIV,JPIV)
+ TMT = TAII-TAJJ
+ IF(DABS(TMT/TAIJ)-1.0D-12) 60,60,6
+ 60 IF(TAIJ) 10,10,11
+ 6 ZAMMA=TAIJ/(2.0*TMT)
+ 90 IF(DABS(ZAMMA)-0.38268)8,8,9
+ 9 IF(ZAMMA)10,10,11
+ 10 SINT = -SIN45
+ GO TO 12
+ 11 SINT = SIN45
+ 12 COST = COS45
+ SINSQ = S45SQ
+ COSSQ = C45SQ
+ GO TO 120
+ 8 GAMSQ=ZAMMA*ZAMMA
+ SINT=2.0*ZAMMA/(1.0+GAMSQ)
+ COST = (1.0-GAMSQ)/(1.0+GAMSQ)
+ SINSQ=SINT*SINT
+ COSSQ=COST*COST
+C ROTATION
+ 120 DO 13 K = 1,N
+ TAIK = A(IPIV,K)
+ TAJK = A(JPIV,K)
+ A(IPIV,K) = TAIK*COST+TAJK*SINT
+ A(JPIV,K) = TAJK*COST-TAIK*SINT
+ TCIK = C(IPIV,K)
+ TCJK = C(JPIV,K)
+ C(IPIV,K) = TCIK*COST+TCJK*SINT
+ 13 C(JPIV,K) = TCJK*COST-TCIK*SINT
+ A(IPIV,IPIV) = TAII*COSSQ+TAJJ*SINSQ+2.0*TAIJ*SINT*COST
+ A(JPIV,JPIV) = TAII*SINSQ+TAJJ*COSSQ-2.0*TAIJ*SINT*COST
+ A(IPIV,JPIV) = TAIJ*(COSSQ-SINSQ)-SINT*COST*TMT
+ A(JPIV,IPIV) = A(IPIV,JPIV)
+ DO 30 K = 1,N
+ A(K,IPIV) = A(IPIV,K)
+ 30 A(K,JPIV) = A(JPIV,K)
+ 72 CONTINUE
+ WRITE (IOUT,1000) AIJMAX
+ 1000 FORMAT (/1X,'NONCONVERGENT JACOBI. LARGEST OFF-DIAGONAL ELE',
+ 1 'MENT = ',1PE14.7)
+C ARRANGEMENT OF EIGENVALUES IN ASCENDING ORDER
+ 300 DO 14 I=1,N
+ 14 AJJ(I)=A(I,I)
+ LT=N+1
+ DO15 L=1,N
+ LT=LT-1
+ AIIMIN=1.0E+30
+ DO16 I=1,N
+ IF(AJJ(I)-AIIMIN)17,16,16
+ 17 AIIMIN=AJJ(I)
+ IT=I
+ 16 CONTINUE
+ IN=L
+ AII(IN)=AIIMIN
+ AJJ(IT)=1.0E+30
+ DO15 K=1,N
+ 15 A(IN,K)=C(IT,K)
+ DO 18 I=1,N
+ IF(A(I,1))19,22,22
+ 19 T=-1.0
+ GO TO 91
+ 22 T=1.0
+ 91 DO 18 J=1,N
+ 18 C(J,I)=T*A(I,J)
+ RETURN
+ END
--- /dev/null
+ subroutine Econstr_back
+c MD with umbrella_sampling using Wolyne's distance measure as a constraint
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+#ifndef LANG0
+ include 'COMMON.LANGEVIN'
+#else
+ include 'COMMON.LANGEVIN.lang0'
+#endif
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ include 'COMMON.TIME1'
+ Uconst_back=0.0d0
+ do i=1,nres
+ dutheta(i)=0.0d0
+ dugamma(i)=0.0d0
+ do j=1,3
+ duscdiff(j,i)=0.0d0
+ duscdiffx(j,i)=0.0d0
+ enddo
+ enddo
+ do i=1,nfrag_back
+ ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
+c
+c Deviations from theta angles
+c
+ utheta_i=0.0d0
+ do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
+ dtheta_i=theta(j)-thetaref(j)
+ utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
+ dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
+ enddo
+ utheta(i)=utheta_i/(ii-1)
+c
+c Deviations from gamma angles
+c
+ ugamma_i=0.0d0
+ do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
+ dgamma_i=pinorm(phi(j)-phiref(j))
+c write (iout,*) j,phi(j),phi(j)-phiref(j)
+ ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
+ dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
+c write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
+ enddo
+ ugamma(i)=ugamma_i/(ii-2)
+c
+c Deviations from local SC geometry
+c
+ uscdiff(i)=0.0d0
+ do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
+ dxx=xxtab(j)-xxref(j)
+ dyy=yytab(j)-yyref(j)
+ dzz=zztab(j)-zzref(j)
+ uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
+ do k=1,3
+ duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)*
+ & (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/
+ & (ii-1)
+ duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)*
+ & (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/
+ & (ii-1)
+ duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)*
+ & (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz)
+ & /(ii-1)
+ enddo
+c write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
+c & xxref(j),yyref(j),zzref(j)
+ enddo
+ uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
+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)+
+ & wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
+c write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
+c & " uconst_back",uconst_back
+ utheta(i)=dsqrt(utheta(i))
+ ugamma(i)=dsqrt(ugamma(i))
+ uscdiff(i)=dsqrt(uscdiff(i))
+ enddo
+ return
+ end
--- /dev/null
+C 10 AUG 94 - MWS - INCREASE NUMBER OF DAF RECORDS
+C 31 MAR 94 - MWS - ADD A VARIABLE TO END OF MACHSW COMMON
+C 26 JUN 93 - MWS - ETRED3: ADD RETURN FOR SPECIAL CASE N=1
+C 4 JAN 92 - TLW - MAKE WRITES PARALLEL;ADD COMMON PAR
+C 30 AUG 91 - MWS - JACDIA: LIMIT ITERATIONS, USE EPSLON IN TEST.
+C 14 JUL 91 - MWS - JACOBI DIAGONALIZATION ALLOWS FOR LDVEC.NE.N
+C 29 JAN 91 - TLW - GLDIAG: CHANGED COMMON DIAGSW TO MACHSW
+C 29 OCT 90 - STE - FIX JACDIA UNDEFINED VARIABLE BUG
+C 14 SEP 90 - MK - NEW JACOBI DIAGONALIZATION (KDIAG=3)
+C 27 MAR 88 - MWS - ALLOW FOR VECTOR ROUTINE IN GLDIAG
+C 11 AUG 87 - MWS - SANITIZE CONSTANTS IN EQLRAT
+C 15 FEB 87 - STE - FIX EINVIT SUB-MATRIX LOOP LIMIT
+C SCRATCH ARRAYS ARE N*8 REAL AND N INTEGER
+C 8 DEC 86 - STE - USE PERF INDEX FROM ESTPI1 TO JUDGE EINVIT FAILURE
+C 30 NOV 86 - STE - DELETE LIGENB, MAKE EVVRSP DEFAULT
+C (GIVEIS FAILS ON CRAY FOR BENCHMC AND BENCHCI)
+C 7 JUL 86 - JAB - SANITIZE FLOATING POINT CONSTANTS
+C 11 OCT 85 - STE - LIGENB,TQL2: USE DROT,DSWAP; TINVTB: SCALE VECTOR
+C BEFORE NORMALIZING; GENERIC FUNCTIONS
+C 24 FEB 84 - STE - INITIALIZE INDEX ARRAY FOR LIGENB IN GLDIAG
+C 1 DEC 83 - STE - CHANGE MACHEP FROM 2**-54 TO 2**-50
+C 28 SEP 82 - MWS - CONVERT TO IBM
+C
+C*MODULE EIGEN *DECK EINVIT
+ SUBROUTINE EINVIT(NM,N,D,E,E2,M,W,IND,Z,IERR,RV1,RV2,RV3,RV4,RV6)
+C*
+C* AUTHORS-
+C* THIS IS A MODIFICATION OF TINVIT FROM EISPACK EDITION 3
+C* DATED AUGUST 1983.
+C* TINVIT IS A TRANSLATION OF THE INVERSE ITERATION TECHNIQUE
+C* IN THE ALGOL PROCEDURE TRISTURM BY PETERS AND WILKINSON.
+C* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971).
+C* THIS VERSION IS BY S. T. ELBERT (AMES LABORATORY-USDOE)
+C*
+C* PURPOSE -
+C* THIS ROUTINE FINDS THOSE EIGENVECTORS OF A TRIDIAGONAL
+C* SYMMETRIC MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES.
+C*
+C* METHOD -
+C* INVERSE ITERATION.
+C*
+C* ON ENTRY -
+C* NM - INTEGER
+C* MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
+C* ARRAY PARAMETERS AS DECLARED IN THE CALLING ROUTINE
+C* DIMENSION STATEMENT.
+C* N - INTEGER
+C* D - W.P. REAL (N)
+C* CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
+C* E - W.P. REAL (N)
+C* CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
+C* IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY.
+C* E2 - W.P. REAL (N)
+C* CONTAINS THE SQUARES OF CORRESPONDING ELEMENTS OF E,
+C* WITH ZEROS CORRESPONDING TO NEGLIGIBLE ELEMENTS OF E.
+C* E(I) IS CONSIDERED NEGLIGIBLE IF IT IS NOT LARGER THAN
+C* THE PRODUCT OF THE RELATIVE MACHINE PRECISION AND THE
+C* SUM OF THE MAGNITUDES OF D(I) AND D(I-1). E2(1) MUST
+C* CONTAIN 0.0 IF THE EIGENVALUES ARE IN ASCENDING ORDER,
+C* OR 2.0 IF THE EIGENVALUES ARE IN DESCENDING ORDER.
+C* IF TQLRAT, BISECT, TRIDIB, OR IMTQLV
+C* HAS BEEN USED TO FIND THE EIGENVALUES, THEIR
+C* OUTPUT E2 ARRAY IS EXACTLY WHAT IS EXPECTED HERE.
+C* M - INTEGER
+C* THE NUMBER OF SPECIFIED EIGENVECTORS.
+C* W - W.P. REAL (M)
+C* CONTAINS THE M EIGENVALUES IN ASCENDING
+C* OR DESCENDING ORDER.
+C* IND - INTEGER (M)
+C* CONTAINS IN FIRST M POSITIONS THE SUBMATRIX INDICES
+C* ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W --
+C* 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX
+C* FROM THE TOP, 2 FOR THOSE BELONGING TO THE SECOND
+C* SUBMATRIX, ETC.
+C* IERR - INTEGER (LOGICAL UNIT NUMBER)
+C* LOGICAL UNIT FOR ERROR MESSAGES
+C*
+C* ON EXIT -
+C* ALL INPUT ARRAYS ARE UNALTERED.
+C* Z - W.P. REAL (NM,M)
+C* CONTAINS THE ASSOCIATED SET OF ORTHONORMAL
+C* EIGENVECTORS. ANY VECTOR WHICH WHICH FAILS TO CONVERGE
+C* IS LEFT AS IS (BUT NORMALIZED) WHEN ITERATING STOPPED.
+C* IERR - INTEGER
+C* SET TO
+C* ZERO FOR NORMAL RETURN,
+C* -R IF THE EIGENVECTOR CORRESPONDING TO THE R-TH
+C* EIGENVALUE FAILS TO CONVERGE IN 5 ITERATIONS.
+C* (ONLY LAST FAILURE TO CONVERGE IS REPORTED)
+C*
+C* RV1, RV2, RV3, RV4, AND RV6 ARE TEMPORARY STORAGE ARRAYS.
+C*
+C* RV1 - W.P. REAL (N)
+C* DIAGONAL ELEMENTS OF U FROM LU DECOMPOSITION
+C* RV2 - W.P. REAL (N)
+C* SUPER(1)-DIAGONAL ELEMENTS OF U FROM LU DECOMPOSITION
+C* RV3 - W.P. REAL (N)
+C* SUPER(2)-DIAGONAL ELEMENTS OF U FROM LU DECOMPOSITION
+C* RV4 - W.P. REAL (N)
+C* ELEMENTS DEFINING L IN LU DECOMPOSITION
+C* RV6 - W.P. REAL (N)
+C* APPROXIMATE EIGENVECTOR
+C*
+C* DIFFERENCES FROM EISPACK 3 -
+C* EPS3 IS SCALED BY EPSCAL (ENHANCES CONVERGENCE, BUT
+C* LOWERS ACCURACY)!
+C* ONE MORE ITERATION (MINIMUM 2) IS PERFORMED AFTER CONVERGENCE
+C* (ENHANCES ACCURACY)!
+C* REPLACE LOOP WITH PYTHAG WITH SINGLE CALL TO DNRM2!
+C* IF NOT CONVERGED, USE PERFORMANCE INDEX TO DECIDE ON ERROR
+C* VALUE SETTING, BUT DO NOT STOP!
+C* L.U. FOR ERROR MESSAGES PASSED THROUGH IERR
+C* USE PARAMETER STATEMENTS AND GENERIC INTRINSIC FUNCTIONS
+C* USE LEVEL 1 BLAS
+C* USE IF-THEN-ELSE TO CLARIFY LOGIC
+C* LOOP OVER SUBSPACES MADE INTO DO LOOP.
+C* LOOP OVER INVERSE ITERATIONS MADE INTO DO LOOP
+C* ZERO ONLY REQUIRED PORTIONS OF OUTPUT VECTOR
+C*
+C* NOTE -
+C* QUESTIONS AND COMMENTS CONCERNING EISPACK SHOULD BE DIRECTED TO
+C* B. S. GARBOW, APPLIED MATH. DIVISION, ARGONNE NATIONAL LAB.
+C*
+C
+ LOGICAL CONVGD,GOPARR,DSKWRK,MASWRK
+C
+ INTEGER GROUP,I,IERR,ITS,J,JJ,M,N,NM,P,Q,R,S,SUBMAT,TAG
+ INTEGER IND(M)
+C
+ DOUBLE PRECISION D(N),E(N),E2(N),W(M),Z(NM,M)
+ DOUBLE PRECISION RV1(N),RV2(N),RV3(N),RV4(N),RV6(N)
+ DOUBLE PRECISION ANORM,EPS2,EPS3,EPS4,NORM,ORDER,RHO,U,UK,V
+ DOUBLE PRECISION X0,X1,XU
+ DOUBLE PRECISION EPSCAL,GRPTOL,HUNDRD,ONE,TEN,ZERO
+ DOUBLE PRECISION EPSLON, ESTPI1, DASUM, DDOT, DNRM2
+C
+ COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
+C
+ PARAMETER (ZERO = 0.0D+00, ONE = 1.0D+00, GRPTOL = 0.001D+00)
+ PARAMETER (EPSCAL = 0.5D+00, HUNDRD = 100.0D+00, TEN = 10.0D+00)
+C
+ 001 FORMAT(' EIGENVECTOR ROUTINE EINVIT DID NOT CONVERGE FOR VECTOR'
+ * ,I5,'. NORM =',1P,E10.2,' PERFORMANCE INDEX =',E10.2/
+ * ' (AN ERROR HALT WILL OCCUR IF THE PI IS GREATER THAN 100)')
+C
+C-----------------------------------------------------------------------
+C
+ LUEMSG = IERR
+ IERR = 0
+ X0 = ZERO
+ UK = ZERO
+ NORM = ZERO
+ EPS2 = ZERO
+ EPS3 = ZERO
+ EPS4 = ZERO
+ GROUP = 0
+ TAG = 0
+ ORDER = ONE - E2(1)
+ Q = 0
+ DO 930 SUBMAT = 1, N
+ P = Q + 1
+C
+C .......... ESTABLISH AND PROCESS NEXT SUBMATRIX ..........
+C
+ DO 120 Q = P, N-1
+ IF (E2(Q+1) .EQ. ZERO) GO TO 140
+ 120 CONTINUE
+ Q = N
+C
+C .......... FIND VECTORS BY INVERSE ITERATION ..........
+C
+ 140 CONTINUE
+ TAG = TAG + 1
+ ANORM = ZERO
+ S = 0
+C
+ DO 920 R = 1, M
+ IF (IND(R) .NE. TAG) GO TO 920
+ ITS = 1
+ X1 = W(R)
+ IF (S .NE. 0) GO TO 510
+C
+C .......... CHECK FOR ISOLATED ROOT ..........
+C
+ XU = ONE
+ IF (P .EQ. Q) THEN
+ RV6(P) = ONE
+ CONVGD = .TRUE.
+ GO TO 860
+C
+ END IF
+ NORM = ABS(D(P))
+ DO 500 I = P+1, Q
+ NORM = MAX( NORM, ABS(D(I)) + ABS(E(I)) )
+ 500 CONTINUE
+C
+C .......... EPS2 IS THE CRITERION FOR GROUPING,
+C EPS3 REPLACES ZERO PIVOTS AND EQUAL
+C ROOTS ARE MODIFIED BY EPS3,
+C EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW .........
+C
+ EPS2 = GRPTOL * NORM
+ EPS3 = EPSCAL * EPSLON(NORM)
+ UK = Q - P + 1
+ EPS4 = UK * EPS3
+ UK = EPS4 / SQRT(UK)
+ S = P
+ GROUP = 0
+ GO TO 520
+C
+C .......... LOOK FOR CLOSE OR COINCIDENT ROOTS ..........
+C
+ 510 IF (ABS(X1-X0) .GE. EPS2) THEN
+C
+C ROOTS ARE SEPERATE
+C
+ GROUP = 0
+ ELSE
+C
+C ROOTS ARE CLOSE
+C
+ GROUP = GROUP + 1
+ IF (ORDER * (X1 - X0) .LE. EPS3) X1 = X0 + ORDER * EPS3
+ END IF
+C
+C .......... ELIMINATION WITH INTERCHANGES AND
+C INITIALIZATION OF VECTOR ..........
+C
+ 520 CONTINUE
+C
+ U = D(P) - X1
+ V = E(P+1)
+ RV6(P) = UK
+ DO 550 I = P+1, Q
+ RV6(I) = UK
+ IF (ABS(E(I)) .GT. ABS(U)) THEN
+C
+C EXCHANGE ROWS BEFORE ELIMINATION
+C
+C *** WARNING -- A DIVIDE CHECK MAY OCCUR HERE IF
+C E2 ARRAY HAS NOT BEEN SPECIFIED CORRECTLY .......
+C
+ XU = U / E(I)
+ RV4(I) = XU
+ RV1(I-1) = E(I)
+ RV2(I-1) = D(I) - X1
+ RV3(I-1) = E(I+1)
+ U = V - XU * RV2(I-1)
+ V = -XU * RV3(I-1)
+C
+ ELSE
+C
+C STRAIGHT ELIMINATION
+C
+ XU = E(I) / U
+ RV4(I) = XU
+ RV1(I-1) = U
+ RV2(I-1) = V
+ RV3(I-1) = ZERO
+ U = D(I) - X1 - XU * V
+ V = E(I+1)
+ END IF
+ 550 CONTINUE
+C
+ IF (ABS(U) .LE. EPS3) U = EPS3
+ RV1(Q) = U
+ RV2(Q) = ZERO
+ RV3(Q) = ZERO
+C
+C DO INVERSE ITERATIONS
+C
+ CONVGD = .FALSE.
+ DO 800 ITS = 1, 5
+ IF (ITS .EQ. 1) GO TO 600
+C
+C .......... FORWARD SUBSTITUTION ..........
+C
+ IF (NORM .EQ. ZERO) THEN
+ RV6(S) = EPS4
+ S = S + 1
+ IF (S .GT. Q) S = P
+ ELSE
+ XU = EPS4 / NORM
+ CALL DSCAL (Q-P+1, XU, RV6(P), 1)
+ END IF
+C
+C ... ELIMINATION OPERATIONS ON NEXT VECTOR
+C
+ DO 590 I = P+1, Q
+ U = RV6(I)
+C
+C IF RV1(I-1) .EQ. E(I), A ROW INTERCHANGE
+C WAS PERFORMED EARLIER IN THE
+C TRIANGULARIZATION PROCESS ..........
+C
+ IF (RV1(I-1) .EQ. E(I)) THEN
+ U = RV6(I-1)
+ RV6(I-1) = RV6(I)
+ ELSE
+ U = RV6(I)
+ END IF
+ RV6(I) = U - RV4(I) * RV6(I-1)
+ 590 CONTINUE
+ 600 CONTINUE
+C
+C .......... BACK SUBSTITUTION
+C
+ RV6(Q) = RV6(Q) / RV1(Q)
+ V = U
+ U = RV6(Q)
+ NORM = ABS(U)
+ DO 620 I = Q-1, P, -1
+ RV6(I) = (RV6(I) - U * RV2(I) - V * RV3(I)) / RV1(I)
+ V = U
+ U = RV6(I)
+ NORM = NORM + ABS(U)
+ 620 CONTINUE
+ IF (GROUP .EQ. 0) GO TO 700
+C
+C ....... ORTHOGONALIZE WITH RESPECT TO PREVIOUS
+C MEMBERS OF GROUP ..........
+C
+ J = R
+ DO 680 JJ = 1, GROUP
+ 630 J = J - 1
+ IF (IND(J) .NE. TAG) GO TO 630
+ CALL DAXPY(Q-P+1, -DDOT(Q-P+1,RV6(P),1,Z(P,J),1),
+ * Z(P,J),1,RV6(P),1)
+ 680 CONTINUE
+ NORM = DASUM(Q-P+1, RV6(P), 1)
+ 700 CONTINUE
+C
+ IF (CONVGD) GO TO 840
+ IF (NORM .GE. ONE) CONVGD = .TRUE.
+ 800 CONTINUE
+C
+C .......... NORMALIZE SO THAT SUM OF SQUARES IS
+C 1 AND EXPAND TO FULL ORDER ..........
+C
+ 840 CONTINUE
+C
+ XU = ONE / DNRM2(Q-P+1,RV6(P),1)
+C
+ 860 CONTINUE
+ DO 870 I = 1, P-1
+ Z(I,R) = ZERO
+ 870 CONTINUE
+ DO 890 I = P,Q
+ Z(I,R) = RV6(I) * XU
+ 890 CONTINUE
+ DO 900 I = Q+1, N
+ Z(I,R) = ZERO
+ 900 CONTINUE
+C
+ IF (.NOT.CONVGD) THEN
+ RHO = ESTPI1(Q-P+1,X1,D(P),E(P),Z(P,R),ANORM)
+ IF (RHO .GE. TEN .AND. LUEMSG .GT. 0 .AND. MASWRK)
+ * WRITE(LUEMSG,001) R,NORM,RHO
+C
+C *** SET ERROR -- NON-CONVERGED EIGENVECTOR ..........
+C
+ IF (RHO .GT. HUNDRD) IERR = -R
+ END IF
+C
+ X0 = X1
+ 920 CONTINUE
+C
+ IF (Q .EQ. N) GO TO 940
+ 930 CONTINUE
+ 940 CONTINUE
+ RETURN
+ END
+C*MODULE EIGEN *DECK ELAUM
+ SUBROUTINE ELAU(HINV,L,D,A,E)
+C
+ DOUBLE PRECISION A(*)
+ DOUBLE PRECISION D(L)
+ DOUBLE PRECISION E(L)
+ DOUBLE PRECISION F
+ DOUBLE PRECISION G
+ DOUBLE PRECISION HALF
+ DOUBLE PRECISION HH
+ DOUBLE PRECISION HINV
+ DOUBLE PRECISION ZERO
+C
+ PARAMETER (ZERO = 0.0D+00, HALF = 0.5D+00)
+C
+ JL = L
+ E(1) = A(1) * D(1)
+ JK = 2
+ DO 210 J = 2, JL
+ F = D(J)
+ G = ZERO
+ JM1 = J - 1
+C
+ DO 200 K = 1, JM1
+ G = G + A(JK) * D(K)
+ E(K) = E(K) + A(JK) * F
+ JK = JK + 1
+ 200 CONTINUE
+C
+ E(J) = G + A(JK) * F
+ JK = JK + 1
+ 210 CONTINUE
+C
+C .......... FORM P ..........
+C
+ F = ZERO
+ DO 245 J = 1, L
+ E(J) = E(J) * HINV
+ F = F + E(J) * D(J)
+ 245 CONTINUE
+C
+C .......... FORM Q ..........
+C
+ HH = F * HALF * HINV
+ DO 250 J = 1, L
+ 250 E(J) = E(J) - HH * D(J)
+C
+ RETURN
+ END
+C*MODULE EIGEN *DECK EPSLON
+ DOUBLE PRECISION FUNCTION EPSLON (X)
+C*
+C* AUTHORS -
+C* THIS ROUTINE WAS TAKEN FROM EISPACK EDITION 3 DATED 4/6/83
+C* THIS VERSION IS BY S. T. ELBERT, AMES LABORATORY-USDOE NOV 1986
+C*
+C* PURPOSE -
+C* ESTIMATE UNIT ROUNDOFF IN QUANTITIES OF SIZE X.
+C*
+C* ON ENTRY -
+C* X - WORKING PRECISION REAL
+C* VALUES TO FIND EPSLON FOR
+C*
+C* ON EXIT -
+C* EPSLON - WORKING PRECISION REAL
+C* SMALLEST POSITIVE VALUE SUCH THAT X+EPSLON .NE. ZERO
+C*
+C* QUALIFICATIONS -
+C* THIS ROUTINE SHOULD PERFORM PROPERLY ON ALL SYSTEMS
+C* SATISFYING THE FOLLOWING TWO ASSUMPTIONS,
+C* 1. THE BASE USED IN REPRESENTING FLOATING POINT
+C* NUMBERS IS NOT A POWER OF THREE.
+C* 2. THE QUANTITY A IN STATEMENT 10 IS REPRESENTED TO
+C* THE ACCURACY USED IN FLOATING POINT VARIABLES
+C* THAT ARE STORED IN MEMORY.
+C* THE STATEMENT NUMBER 10 AND THE GO TO 10 ARE INTENDED TO
+C* FORCE OPTIMIZING COMPILERS TO GENERATE CODE SATISFYING
+C* ASSUMPTION 2.
+C* UNDER THESE ASSUMPTIONS, IT SHOULD BE TRUE THAT,
+C* A IS NOT EXACTLY EQUAL TO FOUR-THIRDS,
+C* B HAS A ZERO FOR ITS LAST BIT OR DIGIT,
+C* C IS NOT EXACTLY EQUAL TO ONE,
+C* EPS MEASURES THE SEPARATION OF 1.0 FROM
+C* THE NEXT LARGER FLOATING POINT NUMBER.
+C* THE DEVELOPERS OF EISPACK WOULD APPRECIATE BEING INFORMED
+C* ABOUT ANY SYSTEMS WHERE THESE ASSUMPTIONS DO NOT HOLD.
+C*
+C* DIFFERENCES FROM EISPACK 3 -
+C* USE IS MADE OF PARAMETER STATEMENTS AND INTRINSIC FUNCTIONS
+C* --NO EXECUTEABLE CODE CHANGES--
+C*
+C* NOTE -
+C* QUESTIONS AND COMMENTS CONCERNING EISPACK SHOULD BE DIRECTED TO
+C* B. S. GARBOW, APPLIED MATH. DIVISION, ARGONNE NATIONAL LAB.
+C
+ DOUBLE PRECISION A,B,C,EPS,X
+ DOUBLE PRECISION ZERO, ONE, THREE, FOUR
+C
+ PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, THREE=3.0D+00, FOUR=4.0D+00)
+C
+C-----------------------------------------------------------------------
+C
+ A = FOUR/THREE
+ 10 B = A - ONE
+ C = B + B + B
+ EPS = ABS(C - ONE)
+ IF (EPS .EQ. ZERO) GO TO 10
+ EPSLON = EPS*ABS(X)
+ RETURN
+ END
+C*MODULE EIGEN *DECK EQLRAT
+ SUBROUTINE EQLRAT(N,DIAG,E,E2IN,D,IND,IERR,E2)
+C*
+C* AUTHORS -
+C* THIS IS A MODIFICATION OF ROUTINE EQLRAT FROM EISPACK EDITION 3
+C* DATED AUGUST 1983.
+C* TQLRAT IS A TRANSLATION OF THE ALGOL PROCEDURE TQLRAT,
+C* ALGORITHM 464, COMM. ACM 16, 689(1973) BY REINSCH.
+C* THIS VERSION IS BY S. T. ELBERT (AMES LABORATORY-USDOE)
+C*
+C* PURPOSE -
+C* THIS ROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC
+C* TRIDIAGONAL MATRIX
+C*
+C* METHOD -
+C* RATIONAL QL
+C*
+C* ON ENTRY -
+C* N - INTEGER
+C* THE ORDER OF THE MATRIX.
+C* D - W.P. REAL (N)
+C* CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
+C* E2 - W.P. REAL (N)
+C* CONTAINS THE SQUARES OF THE SUBDIAGONAL ELEMENTS OF
+C* THE INPUT MATRIX IN ITS LAST N-1 POSITIONS.
+C* E2(1) IS ARBITRARY.
+C*
+C* ON EXIT -
+C* D - W.P. REAL (N)
+C* CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN
+C* ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND
+C* ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE
+C* THE SMALLEST EIGENVALUES.
+C* E2 - W.P. REAL (N)
+C* DESTROYED.
+C* IERR - INTEGER
+C* SET TO
+C* ZERO FOR NORMAL RETURN,
+C* J IF THE J-TH EIGENVALUE HAS NOT BEEN
+C* DETERMINED AFTER 30 ITERATIONS.
+C*
+C* DIFFERENCES FROM EISPACK 3 -
+C* G=G+B INSTEAD OF IF(G.EQ.0) G=B ; B=B/4
+C* F77 BACKWARD LOOPS INSTEAD OF F66 CONSTRUCT
+C* GENERIC INTRINSIC FUNCTIONS
+C* ARRARY IND ADDED FOR USE BY EINVIT
+C*
+C* NOTE -
+C* QUESTIONS AND COMMENTS CONCERNING EISPACK SHOULD BE DIRECTED TO
+C* B. S. GARBOW, APPLIED MATH. DIVISION, ARGONNE NATIONAL LAB.
+C
+ INTEGER I,J,L,M,N,II,L1,IERR
+ INTEGER IND(N)
+C
+ DOUBLE PRECISION D(N),E(N),E2(N),DIAG(N),E2IN(N)
+ DOUBLE PRECISION B,C,F,G,H,P,R,S,T,EPSLON
+ DOUBLE PRECISION SCALE,ZERO,ONE
+C
+ PARAMETER (ZERO = 0.0D+00, SCALE= 1.0D+00/64.0D+00, ONE = 1.0D+00)
+C
+C-----------------------------------------------------------------------
+ IERR = 0
+ D(1)=DIAG(1)
+ IND(1) = 1
+ K = 0
+ ITAG = 0
+ IF (N .EQ. 1) GO TO 1001
+C
+ DO 100 I = 2, N
+ D(I)=DIAG(I)
+ 100 E2(I-1) = E2IN(I)
+C
+ F = ZERO
+ T = ZERO
+ B = EPSLON(ONE)
+ C = B *B
+ B = B * SCALE
+ E2(N) = ZERO
+C
+ DO 290 L = 1, N
+ H = ABS(D(L)) + ABS(E(L))
+ IF (T .GE. H) GO TO 105
+ T = H
+ B = EPSLON(T)
+ C = B * B
+ B = B * SCALE
+ 105 CONTINUE
+C .......... LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT ..........
+ M = L - 1
+ 110 M = M + 1
+ IF (E2(M) .GT. C) GO TO 110
+C .......... E2(N) IS ALWAYS ZERO, SO THERE IS AN EXIT
+C FROM THE LOOP ..........
+C
+ IF (M .LE. K) GO TO 125
+ IF (M .NE. N) E2IN(M+1) = ZERO
+ K = M
+ ITAG = ITAG + 1
+ 125 CONTINUE
+ IF (M .EQ. L) GO TO 210
+C
+C ITERATE
+C
+ DO 205 J = 1, 30
+C .......... FORM SHIFT ..........
+ L1 = L + 1
+ S = SQRT(E2(L))
+ G = D(L)
+ P = (D(L1) - G) / (2.0D+00 * S)
+ R = SQRT(P*P+1.0D+00)
+ D(L) = S / (P + SIGN(R,P))
+ H = G - D(L)
+C
+ DO 140 I = L1, N
+ 140 D(I) = D(I) - H
+C
+ F = F + H
+C .......... RATIONAL QL TRANSFORMATION ..........
+ G = D(M) + B
+ H = G
+ S = ZERO
+ DO 200 I = M-1,L,-1
+ P = G * H
+ R = P + E2(I)
+ E2(I+1) = S * R
+ S = E2(I) / R
+ D(I+1) = H + S * (H + D(I))
+ G = D(I) - E2(I) / G + B
+ H = G * P / R
+ 200 CONTINUE
+C
+ E2(L) = S * G
+ D(L) = H
+C .......... GUARD AGAINST UNDERFLOW IN CONVERGENCE TEST
+ IF (H .EQ. ZERO) GO TO 210
+ IF (ABS(E2(L)) .LE. ABS(C/H)) GO TO 210
+ E2(L) = H * E2(L)
+ IF (E2(L) .EQ. ZERO) GO TO 210
+ 205 CONTINUE
+C .......... SET ERROR -- NO CONVERGENCE TO AN
+C EIGENVALUE AFTER 30 ITERATIONS ..........
+ IERR = L
+ GO TO 1001
+C
+C CONVERGED
+C
+ 210 P = D(L) + F
+C .......... ORDER EIGENVALUES ..........
+ I = 1
+ IF (L .EQ. 1) GO TO 250
+ IF (P .LT. D(1)) GO TO 230
+ I = L
+C .......... LOOP TO FIND ORDERED POSITION
+ 220 I = I - 1
+ IF (P .LT. D(I)) GO TO 220
+C
+ I = I + 1
+ IF (I .EQ. L) GO TO 250
+ 230 CONTINUE
+ DO 240 II = L, I+1, -1
+ D(II) = D(II-1)
+ IND(II) = IND(II-1)
+ 240 CONTINUE
+C
+ 250 CONTINUE
+ D(I) = P
+ IND(I) = ITAG
+ 290 CONTINUE
+C
+ 1001 RETURN
+ END
+C*MODULE EIGEN *DECK ESTPI1
+ DOUBLE PRECISION FUNCTION ESTPI1 (N,EVAL,D,E,X,ANORM)
+C*
+C* AUTHOR -
+C* STEPHEN T. ELBERT (AMES LABORATORY-USDOE) DATE: 5 DEC 1986
+C*
+C* PURPOSE -
+C* EVALUATE SYMMETRIC TRIDIAGONAL MATRIX PERFORMANCE INDEX
+C* * * * * *
+C* FOR 1 EIGENVECTOR
+C* *
+C*
+C* METHOD -
+C* THIS ROUTINE FORMS THE 1-NORM OF THE RESIDUAL MATRIX A*X-X*EVAL
+C* WHERE A IS A SYMMETRIC TRIDIAGONAL MATRIX STORED
+C* IN THE DIAGONAL (D) AND SUB-DIAGONAL (E) VECTORS, EVAL IS THE
+C* EIGENVALUE OF AN EIGENVECTOR OF A, NAMELY X.
+C* THIS NORM IS SCALED BY MACHINE ACCURACY FOR THE PROBLEM SIZE.
+C* ALL NORMS APPEARING IN THE COMMENTS BELOW ARE 1-NORMS.
+C*
+C* ON ENTRY -
+C* N - INTEGER
+C* THE ORDER OF THE MATRIX A.
+C* EVAL - W.P. REAL
+C* THE EIGENVALUE CORRESPONDING TO VECTOR X.
+C* D - W.P. REAL (N)
+C* THE DIAGONAL VECTOR OF A.
+C* E - W.P. REAL (N)
+C* THE SUB-DIAGONAL VECTOR OF A.
+C* X - W.P. REAL (N)
+C* AN EIGENVECTOR OF A.
+C* ANORM - W.P. REAL
+C* THE NORM OF A IF IT HAS BEEN PREVIOUSLY COMPUTED.
+C*
+C* ON EXIT -
+C* ANORM - W.P. REAL
+C* THE NORM OF A, COMPUTED IF INITIALLY ZERO.
+C* ESTPI1 - W.P. REAL
+C* !!A*X-X*EVAL!! / (EPSLON(10*N)*!!A!!*!!X!!);
+C* WHERE EPSLON(X) IS THE SMALLEST NUMBER SUCH THAT
+C* X + EPSLON(X) .NE. X
+C*
+C* ESTPI1 .LT. 1 == SATISFACTORY PERFORMANCE
+C* .GE. 1 AND .LE. 100 == MARGINAL PERFORMANCE
+C* .GT. 100 == POOR PERFORMANCE
+C* (SEE LECT. NOTES IN COMP. SCI. VOL.6 PP 124-125)
+C
+ DOUBLE PRECISION ANORM,EVAL,RNORM,SIZE,XNORM
+ DOUBLE PRECISION D(N), E(N), X(N)
+ DOUBLE PRECISION EPSLON, ONE, ZERO
+C
+ PARAMETER (ZERO = 0.0D+00, ONE = 1.0D+00)
+C
+C-----------------------------------------------------------------------
+C
+ ESTPI1 = ZERO
+ IF( N .LE. 1 ) RETURN
+ SIZE = 10 * N
+ IF (ANORM .EQ. ZERO) THEN
+C
+C COMPUTE NORM OF A
+C
+ ANORM = MAX( ABS(D(1)) + ABS(E(2))
+ * ,ABS(D(N)) + ABS(E(N)))
+ DO 110 I = 2, N-1
+ ANORM = MAX( ANORM, ABS(E(I))+ABS(D(I))+ABS(E(I+1)))
+ 110 CONTINUE
+ IF(ANORM .EQ. ZERO) ANORM = ONE
+ END IF
+C
+C COMPUTE NORMS OF RESIDUAL AND EIGENVECTOR
+C
+ XNORM = ABS(X(1)) + ABS(X(N))
+ RNORM = ABS( (D(1)-EVAL)*X(1) + E(2)*X(2))
+ * +ABS( (D(N)-EVAL)*X(N) + E(N)*X(N-1))
+ DO 120 I = 2, N-1
+ XNORM = XNORM + ABS(X(I))
+ RNORM = RNORM + ABS(E(I)*X(I-1) + (D(I)-EVAL)*X(I)
+ * + E(I+1)*X(I+1))
+ 120 CONTINUE
+C
+ ESTPI1 = RNORM / (EPSLON(SIZE)*ANORM*XNORM)
+ RETURN
+ END
+C*MODULE EIGEN *DECK ETRBK3
+ SUBROUTINE ETRBK3(NM,N,NV,A,M,Z)
+C*
+C* AUTHORS-
+C* THIS IS A MODIFICATION OF ROUTINE TRBAK3 FROM EISPACK EDITION 3
+C* DATED AUGUST 1983.
+C* EISPACK TRBAK3 IS A TRANSLATION OF THE ALGOL PROCEDURE TRBAK3,
+C* NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
+C* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
+C* THIS VERSION IS BY S. T. ELBERT (AMES LABORATORY-USDOE)
+C*
+C* PURPOSE -
+C* THIS ROUTINE FORMS THE EIGENVECTORS OF A REAL SYMMETRIC
+C* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
+C* SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY ETRED3.
+C*
+C* METHOD -
+C* THE CALCULATION IS CARRIED OUT BY FORMING THE MATRIX PRODUCT
+C* Q*Z
+C* WHERE Q IS A PRODUCT OF THE ORTHOGONAL SYMMETRIC MATRICES
+C* Q = PROD(I)[1 - U(I)*.TRANSPOSE.U(I)*H(I)]
+C* U IS THE AUGMENTED SUB-DIAGONAL ROWS OF A AND
+C* Z IS THE SET OF EIGENVECTORS OF THE TRIDIAGONAL
+C* MATRIX F WHICH WAS FORMED FROM THE ORIGINAL SYMMETRIC
+C* MATRIX C BY THE SIMILARITY TRANSFORMATION
+C* F = Q(TRANSPOSE) C Q
+C* NOTE THAT ETRBK3 PRESERVES VECTOR EUCLIDEAN NORMS.
+C*
+C*
+C* COMPLEXITY -
+C* M*N**2
+C*
+C* ON ENTRY-
+C* NM - INTEGER
+C* MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
+C* ARRAY PARAMETERS AS DECLARED IN THE CALLING ROUTINE
+C* DIMENSION STATEMENT.
+C* N - INTEGER
+C* THE ORDER OF THE MATRIX A.
+C* NV - INTEGER
+C* MUST BE SET TO THE DIMENSION OF THE ARRAY A AS
+C* DECLARED IN THE CALLING ROUTINE DIMENSION STATEMENT.
+C* A - W.P. REAL (NV)
+C* CONTAINS INFORMATION ABOUT THE ORTHOGONAL
+C* TRANSFORMATIONS USED IN THE REDUCTION BY ETRED3 IN
+C* ITS FIRST NV = N*(N+1)/2 POSITIONS.
+C* M - INTEGER
+C* THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
+C* Z - W.P REAL (NM,M)
+C* CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED
+C* IN ITS FIRST M COLUMNS.
+C*
+C* ON EXIT-
+C* Z - W.P. REAL (NM,M)
+C* CONTAINS THE TRANSFORMED EIGENVECTORS
+C* IN ITS FIRST M COLUMNS.
+C*
+C* DIFFERENCES WITH EISPACK 3 -
+C* THE TWO INNER LOOPS ARE REPLACED BY DDOT AND DAXPY.
+C* MULTIPLICATION USED INSTEAD OF DIVISION TO FIND S.
+C* OUTER LOOP RANGE CHANGED FROM 2,N TO 3,N.
+C* ADDRESS POINTERS FOR A SIMPLIFIED.
+C*
+C* NOTE -
+C* QUESTIONS AND COMMENTS CONCERNING EISPACK SHOULD BE DIRECTED TO
+C* B. S. GARBOW, APPLIED MATH. DIVISION, ARGONNE NATIONAL LAB.
+C
+ INTEGER I,II,IM1,IZ,J,M,N,NM,NV
+C
+ DOUBLE PRECISION A(NV),Z(NM,M)
+ DOUBLE PRECISION H,S,DDOT,ZERO
+C
+ PARAMETER (ZERO = 0.0D+00)
+C
+C-----------------------------------------------------------------------
+C
+ IF (M .EQ. 0) RETURN
+ IF (N .LE. 2) RETURN
+C
+ II=3
+ DO 140 I = 3, N
+ IZ=II+1
+ II=II+I
+ H = A(II)
+ IF (H .EQ. ZERO) GO TO 140
+ IM1 = I - 1
+ DO 130 J = 1, M
+ S = -( DDOT(IM1,A(IZ),1,Z(1,J),1) * H) * H
+ CALL DAXPY(IM1,S,A(IZ),1,Z(1,J),1)
+ 130 CONTINUE
+ 140 CONTINUE
+ RETURN
+ END
+C*MODULE EIGEN *DECK ETRED3
+ SUBROUTINE ETRED3(N,NV,A,D,E,E2)
+C*
+C* AUTHORS -
+C* THIS IS A MODIFICATION OF ROUTINE TRED3 FROM EISPACK EDITION 3
+C* DATED AUGUST 1983.
+C* EISPACK TRED3 IS A TRANSLATION OF THE ALGOL PROCEDURE TRED3,
+C* NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
+C* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
+C* THIS VERSION IS BY S. T. ELBERT, AMES LABORATORY-USDOE JUN 1986
+C*
+C* PURPOSE -
+C* THIS ROUTINE REDUCES A REAL SYMMETRIC (PACKED) MATRIX, STORED
+C* AS A ONE-DIMENSIONAL ARRAY, TO A SYMMETRIC TRIDIAGONAL MATRIX
+C* USING ORTHOGONAL SIMILARITY TRANSFORMATIONS, PRESERVING THE
+C* INFORMATION ABOUT THE TRANSFORMATIONS IN A.
+C*
+C* METHOD -
+C* THE TRIDIAGONAL REDUCTION IS PERFORMED IN THE FOLLOWING WAY.
+C* STARTING WITH J=N, THE ELEMENTS IN THE J-TH ROW TO THE
+C* LEFT OF THE DIAGONAL ARE FIRST SCALED, TO AVOID POSSIBLE
+C* UNDERFLOW IN THE TRANSFORMATION THAT MIGHT RESULT IN SEVERE
+C* DEPARTURE FROM ORTHOGONALITY. THE SUM OF SQUARES SIGMA OF
+C* THESE SCALED ELEMENTS IS NEXT FORMED. THEN, A VECTOR U AND
+C* A SCALAR
+C* H = U(TRANSPOSE) * U / 2
+C* DEFINE A REFLECTION OPERATOR
+C* P = I - U * U(TRANSPOSE) / H
+C* WHICH IS ORTHOGONAL AND SYMMETRIC AND FOR WHICH THE
+C* SIMILIARITY TRANSFORMATION PAP ELIMINATES THE ELEMENTS IN
+C* THE J-TH ROW OF A TO THE LEFT OF THE SUBDIAGONAL AND THE
+C* SYMMETRICAL ELEMENTS IN THE J-TH COLUMN.
+C*
+C* THE NON-ZERO COMPONENTS OF U ARE THE ELEMENTS OF THE J-TH
+C* ROW TO THE LEFT OF THE DIAGONAL WITH THE LAST OF THEM
+C* AUGMENTED BY THE SQUARE ROOT OF SIGMA PREFIXED BY THE SIGN
+C* OF THE SUBDIAGONAL ELEMENT. BY STORING THE TRANSFORMED SUB-
+C* DIAGONAL ELEMENT IN E(J) AND NOT OVERWRITING THE ROW
+C* ELEMENTS ELIMINATED IN THE TRANSFORMATION, FULL INFORMATION
+C* ABOUT P IS SAVE FOR LATER USE IN ETRBK3.
+C*
+C* THE TRANSFORMATION SETS E2(J) EQUAL TO SIGMA AND E(J)
+C* EQUAL TO THE SQUARE ROOT OF SIGMA PREFIXED BY THE SIGN
+C* OF THE REPLACED SUBDIAGONAL ELEMENT.
+C*
+C* THE ABOVE STEPS ARE REPEATED ON FURTHER ROWS OF THE
+C* TRANSFORMED A IN REVERSE ORDER UNTIL A IS REDUCED TO TRI-
+C* DIAGONAL FORM, THAT IS, REPEATED FOR J = N-1,N-2,...,3.
+C*
+C* COMPLEXITY -
+C* 2/3 N**3
+C*
+C* ON ENTRY-
+C* N - INTEGER
+C* THE ORDER OF THE MATRIX.
+C* NV - INTEGER
+C* MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A
+C* AS DECLARED IN THE CALLING ROUTINE DIMENSION STATEMENT
+C* A - W.P. REAL (NV)
+C* CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC
+C* INPUT MATRIX, STORED ROW-WISE AS A ONE-DIMENSIONAL
+C* ARRAY, IN ITS FIRST N*(N+1)/2 POSITIONS.
+C*
+C* ON EXIT-
+C* A - W.P. REAL (NV)
+C* CONTAINS INFORMATION ABOUT THE ORTHOGONAL
+C* TRANSFORMATIONS USED IN THE REDUCTION.
+C* D - W.P. REAL (N)
+C* CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL
+C* MATRIX.
+C* E - W.P. REAL (N)
+C* CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
+C* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO
+C* E2 - W.P. REAL (N)
+C* CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF
+C* E. MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED.
+C*
+C* DIFFERENCES FROM EISPACK 3 -
+C* OUTER LOOP CHANGED FROM II=1,N TO I=N,3,-1
+C* PARAMETER STATEMENT AND GENERIC INTRINSIC FUNCTIONS USED
+C* SCALE.NE.0 TEST NOW SPOTS TRI-DIAGONAL FORM
+C* VALUES LESS THAN EPSLON CLEARED TO ZERO
+C* USE BLAS(1)
+C* U NOT COPIED TO D, LEFT IN A
+C* E2 COMPUTED FROM E
+C* INNER LOOPS SPLIT INTO ROUTINES ELAU AND FREDA
+C* INVERSE OF H STORED INSTEAD OF H
+C*
+C* NOTE -
+C* QUESTIONS AND COMMENTS CONCERNING EISPACK SHOULD BE DIRECTED TO
+C* B. S. GARBOW, APPLIED MATH. DIVISION, ARGONNE NATIONAL LAB.
+C
+ INTEGER I,IIA,IZ0,L,N,NV
+C
+ DOUBLE PRECISION A(NV),D(N),E(N),E2(N)
+ DOUBLE PRECISION AIIMAX,F,G,H,HROOT,SCALE,SCALEI
+ DOUBLE PRECISION DASUM, DNRM2
+ DOUBLE PRECISION ONE, ZERO
+C
+ PARAMETER (ZERO = 0.0D+00, ONE = 1.0D+00)
+C
+C-----------------------------------------------------------------------
+C
+ IF (N .LE. 2) GO TO 310
+ IZ0 = (N*N+N)/2
+ AIIMAX = ABS(A(IZ0))
+ DO 300 I = N, 3, -1
+ L = I - 1
+ IIA = IZ0
+ IZ0 = IZ0 - I
+ AIIMAX = MAX(AIIMAX, ABS(A(IIA)))
+ SCALE = DASUM (L, A(IZ0+1), 1)
+ IF(SCALE .EQ. ABS(A(IIA-1)) .OR. AIIMAX+SCALE .EQ. AIIMAX) THEN
+C
+C THIS ROW IS ALREADY IN TRI-DIAGONAL FORM
+C
+ D(I) = A(IIA)
+ IF (AIIMAX+D(I) .EQ. AIIMAX) D(I) = ZERO
+ E(I) = A(IIA-1)
+ IF (AIIMAX+E(I) .EQ. AIIMAX) E(I) = ZERO
+ E2(I) = E(I)*E(I)
+ A(IIA) = ZERO
+ GO TO 300
+C
+ END IF
+C
+ SCALEI = ONE / SCALE
+ CALL DSCAL(L,SCALEI,A(IZ0+1),1)
+ HROOT = DNRM2(L,A(IZ0+1),1)
+C
+ F = A(IZ0+L)
+ G = -SIGN(HROOT,F)
+ E(I) = SCALE * G
+ E2(I) = E(I)*E(I)
+ H = HROOT*HROOT - F * G
+ A(IZ0+L) = F - G
+ D(I) = A(IIA)
+ A(IIA) = ONE / SQRT(H)
+C .......... FORM P THEN Q IN E(1:L) ..........
+ CALL ELAU(ONE/H,L,A(IZ0+1),A,E)
+C .......... FORM REDUCED A ..........
+ CALL FREDA(L,A(IZ0+1),A,E)
+C
+ 300 CONTINUE
+ 310 CONTINUE
+ E(1) = ZERO
+ E2(1)= ZERO
+ D(1) = A(1)
+ IF(N.EQ.1) RETURN
+C
+ E(2) = A(2)
+ E2(2)= A(2)*A(2)
+ D(2) = A(3)
+ RETURN
+ END
+C*MODULE EIGEN *DECK EVVRSP
+ SUBROUTINE EVVRSP(MSGFL,N,NVECT,LENA,NV,A,B,IND,ROOT,
+ * VECT,IORDER,IERR)
+C*
+C* AUTHOR: S. T. ELBERT, AMES LABORATORY-USDOE, JUNE 1985
+C*
+C* PURPOSE -
+C* FINDS (ALL) EIGENVALUES AND (SOME OR ALL) EIGENVECTORS
+C* * * *
+C* OF A REAL SYMMETRIC PACKED MATRIX.
+C* * * *
+C*
+C* METHOD -
+C* THE METHOD AS PRESENTED IN THIS ROUTINE CONSISTS OF FOUR STEPS:
+C* FIRST, THE INPUT MATRIX IS REDUCED TO TRIDIAGONAL FORM BY THE
+C* HOUSEHOLDER TECHNIQUE (ORTHOGONAL SIMILARITY TRANSFORMATIONS).
+C* SECOND, THE ROOTS ARE LOCATED USING THE RATIONAL QL METHOD.
+C* THIRD, THE VECTORS OF THE TRIDIAGONAL FORM ARE EVALUATED BY THE
+C* INVERSE ITERATION TECHNIQUE. VECTORS FOR DEGENERATE OR NEAR-
+C* DEGENERATE ROOTS ARE FORCED TO BE ORTHOGONAL.
+C* FOURTH, THE TRIDIAGONAL VECTORS ARE ROTATED TO VECTORS OF THE
+C* ORIGINAL ARRAY.
+C*
+C* THESE ROUTINES ARE MODIFICATIONS OF THE EISPACK 3
+C* ROUTINES TRED3, TQLRAT, TINVIT AND TRBAK3
+C*
+C* FOR FURTHER DETAILS, SEE EISPACK USERS GUIDE, B. T. SMITH
+C* ET AL, SPRINGER-VERLAG, LECTURE NOTES IN COMPUTER SCIENCE,
+C* VOL. 6, 2-ND EDITION, 1976. ANOTHER GOOD REFERENCE IS
+C* THE SYMMETRIC EIGENVALUE PROBLEM BY B. N. PARLETT
+C* PUBLISHED BY PRENTICE-HALL, INC., ENGLEWOOD CLIFFS, N.J. (1980)
+C*
+C* ON ENTRY -
+C* MSGFL - INTEGER (LOGICAL UNIT NO.)
+C* FILE WHERE ERROR MESSAGES WILL BE PRINTED.
+C* IF MSGFL IS 0, ERROR MESSAGES WILL BE PRINTED ON LU 6.
+C* IF MSGFL IS NEGATIVE, NO ERROR MESSAGES PRINTED.
+C* N - INTEGER
+C* ORDER OF MATRIX A.
+C* NVECT - INTEGER
+C* NUMBER OF VECTORS DESIRED. 0 .LE. NVECT .LE. N.
+C* LENA - INTEGER
+C* DIMENSION OF A IN CALLING ROUTINE. MUST NOT BE LESS
+C* THAN (N*N+N)/2.
+C* NV - INTEGER
+C* ROW DIMENSION OF VECT IN CALLING ROUTINE. N .LE. NV.
+C* A - WORKING PRECISION REAL (LENA)
+C* INPUT MATRIX, ROWS OF THE LOWER TRIANGLE PACKED INTO
+C* LINEAR ARRAY OF DIMENSION N*(N+1)/2. THE PACKED ORDER
+C* IS A(1,1), A(2,1), A(2,2), A(3,1), A(3,2), ...
+C* B - WORKING PRECISION REAL (N,8)
+C* SCRATCH ARRAY, 8*N ELEMENTS
+C* IND - INTEGER (N)
+C* SCRATCH ARRAY OF LENGTH N.
+C* IORDER - INTEGER
+C* ROOT ORDERING FLAG.
+C* = 0, ROOTS WILL BE PUT IN ASCENDING ORDER.
+C* = 2, ROOTS WILL BE PUT IN DESCENDING ORDER.
+C*
+C* ON EXIT -
+C* A - DESTORYED. NOW HOLDS REFLECTION OPERATORS.
+C* ROOT - WORKING PRECISION REAL (N)
+C* ALL EIGENVALUES IN ASCENDING OR DESCENDING ORDER.
+C* IF IORDER = 0, ROOT(1) .LE. ... .LE. ROOT(N)
+C* IF IORDER = 2, ROOT(1) .GE. ... .GE. ROOT(N)
+C* VECT - WORKING PRECISION REAL (NV,NVECT)
+C* EIGENVECTORS FOR ROOT(1), ..., ROOT(NVECT).
+C* IERR - INTEGER
+C* = 0 IF NO ERROR DETECTED,
+C* = K IF ITERATION FOR K-TH EIGENVALUE FAILED,
+C* = -K IF ITERATION FOR K-TH EIGENVECTOR FAILED.
+C* (FAILURES SHOULD BE VERY RARE. CONTACT C. MOLER.)
+C*
+C
+ LOGICAL GOPARR,DSKWRK,MASWRK
+C
+ DOUBLE PRECISION A(LENA)
+ DOUBLE PRECISION B(N,8)
+ DOUBLE PRECISION ROOT(N)
+ DOUBLE PRECISION T
+ DOUBLE PRECISION VECT(NV,*)
+C
+ INTEGER IND(N)
+C
+ COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
+C
+ 900 FORMAT(26H0*** EVVRSP PARAMETERS ***/
+ + 14H *** N = ,I8,4H ***/
+ + 14H *** NVECT = ,I8,4H ***/
+ + 14H *** LENA = ,I8,4H ***/
+ + 14H *** NV = ,I8,4H ***/
+ + 14H *** IORDER = ,I8,4H ***/
+ + 14H *** IERR = ,I8,4H ***)
+ 901 FORMAT(37H VALUE OF LENA IS LESS THAN (N*N+N)/2)
+ 902 FORMAT(39H EQLRAT HAS FAILED TO CONVERGE FOR ROOT,I5)
+ 903 FORMAT(18H NV IS LESS THAN N)
+ 904 FORMAT(41H EINVIT HAS FAILED TO CONVERGE FOR VECTOR,I5)
+ 905 FORMAT(51H VALUE OF IORDER MUST BE 0 (SMALLEST ROOT FIRST) OR
+ * ,23H 2 (LARGEST ROOT FIRST))
+ 906 FORMAT(' VALUE OF N IS LESS THAN OR EQUAL ZERO')
+C
+C-----------------------------------------------------------------------
+C
+ LMSGFL=MSGFL
+ IF (MSGFL .EQ. 0) LMSGFL=6
+ IERR = N - 1
+ IF (N .LE. 0) GO TO 800
+ IERR = N + 1
+ IF ( (N*N+N)/2 .GT. LENA) GO TO 810
+C
+C REDUCE REAL SYMMETRIC MATRIX A TO TRIDIAGONAL FORM
+C
+ CALL ETRED3(N,LENA,A,B(1,1),B(1,2),B(1,3))
+C
+C FIND ALL EIGENVALUES OF TRIDIAGONAL MATRIX
+C
+ CALL EQLRAT(N,B(1,1),B(1,2),B(1,3),ROOT,IND,IERR,B(1,4))
+ IF (IERR .NE. 0) GO TO 820
+C
+C CHECK THE DESIRED ORDER OF THE EIGENVALUES
+C
+ B(1,3) = IORDER
+ IF (IORDER .EQ. 0) GO TO 300
+ IF (IORDER .NE. 2) GO TO 850
+C
+C ORDER ROOTS IN DESCENDING ORDER (LARGEST FIRST)...
+C TURN ROOT AND IND ARRAYS END FOR END
+C
+ DO 210 I = 1, N/2
+ J = N+1-I
+ T = ROOT(I)
+ ROOT(I) = ROOT(J)
+ ROOT(J) = T
+ L = IND(I)
+ IND(I) = IND(J)
+ IND(J) = L
+ 210 CONTINUE
+C
+C FIND I AND J MARKING THE START AND END OF A SEQUENCE
+C OF DEGENERATE ROOTS
+C
+ I=0
+ 220 CONTINUE
+ I = I+1
+ IF (I .GT. N) GO TO 300
+ DO 230 J=I,N
+ IF (ROOT(J) .NE. ROOT(I)) GO TO 240
+ 230 CONTINUE
+ J = N+1
+ 240 CONTINUE
+ J = J-1
+ IF (J .EQ. I) GO TO 220
+C
+C TURN AROUND IND BETWEEN I AND J
+C
+ JSV = J
+ KLIM = (J-I+1)/2
+ DO 250 K=1,KLIM
+ L = IND(J)
+ IND(J) = IND(I)
+ IND(I) = L
+ I = I+1
+ J = J-1
+ 250 CONTINUE
+ I = JSV
+ GO TO 220
+C
+ 300 CONTINUE
+C
+ IF (NVECT .LE. 0) RETURN
+ IF (NV .LT. N) GO TO 830
+C
+C FIND EIGENVECTORS OF TRI-DIAGONAL MATRIX VIA INVERSE ITERATION
+C
+ IERR = LMSGFL
+ CALL EINVIT(NV,N,B(1,1),B(1,2),B(1,3),NVECT,ROOT,IND,
+ + VECT,IERR,B(1,4),B(1,5),B(1,6),B(1,7),B(1,8))
+ IF (IERR .NE. 0) GO TO 840
+C
+C FIND EIGENVECTORS OF SYMMETRIC MATRIX VIA BACK TRANSFORMATION
+C
+ 400 CONTINUE
+ CALL ETRBK3(NV,N,LENA,A,NVECT,VECT)
+ RETURN
+C
+C ERROR MESSAGE SECTION
+C
+ 800 IF (LMSGFL .LT. 0) RETURN
+ IF (MASWRK) WRITE(LMSGFL,906)
+ GO TO 890
+C
+ 810 IF (LMSGFL .LT. 0) RETURN
+ IF (MASWRK) WRITE(LMSGFL,901)
+ GO TO 890
+C
+ 820 IF (LMSGFL .LT. 0) RETURN
+ IF (MASWRK) WRITE(LMSGFL,902) IERR
+ GO TO 890
+C
+ 830 IF (LMSGFL .LT. 0) RETURN
+ IF (MASWRK) WRITE(LMSGFL,903)
+ GO TO 890
+C
+ 840 CONTINUE
+ IF ((LMSGFL .GT. 0).AND.MASWRK) WRITE(LMSGFL,904) -IERR
+ GO TO 400
+C
+ 850 IERR=-1
+ IF (LMSGFL .LT. 0) RETURN
+ IF (MASWRK) WRITE(LMSGFL,905)
+ GO TO 890
+C
+ 890 CONTINUE
+ IF (MASWRK) WRITE(LMSGFL,900) N,NVECT,LENA,NV,IORDER,IERR
+ RETURN
+ END
+C*MODULE EIGEN *DECK FREDA
+ SUBROUTINE FREDA(L,D,A,E)
+C
+ DOUBLE PRECISION A(*)
+ DOUBLE PRECISION D(L)
+ DOUBLE PRECISION E(L)
+ DOUBLE PRECISION F
+ DOUBLE PRECISION G
+C
+ JK = 1
+C
+C .......... FORM REDUCED A ..........
+C
+ DO 280 J = 1, L
+ F = D(J)
+ G = E(J)
+C
+ DO 260 K = 1, J
+ A(JK) = A(JK) - F * E(K) - G * D(K)
+ JK = JK + 1
+ 260 CONTINUE
+C
+ 280 CONTINUE
+ RETURN
+ END
+C*MODULE EIGEN *DECK GIVEIS
+ SUBROUTINE GIVEIS(N,NVECT,NV,A,B,INDB,ROOT,VECT,IERR)
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ DIMENSION A(*),B(N,8),INDB(N),ROOT(N),VECT(NV,NVECT)
+C
+C EISPACK-BASED SUBSTITUTE FOR QCPE ROUTINE GIVENS.
+C FINDS ALL EIGENVALUES AND SOME EIGENVECTORS OF A REAL SYMMETRIC
+C MATRIX. AUTHOR.. C. MOLER AND D. SPANGLER, N.R.C.C., 4/1/79.
+C
+C INPUT..
+C N = ORDER OF MATRIX .
+C NVECT = NUMBER OF VECTORS DESIRED. 0 .LE. NVECT .LE. N .
+C NV = LEADING DIMENSION OF VECT .
+C A = INPUT MATRIX, COLUMNS OF THE UPPER TRIANGLE PACKED INTO
+C LINEAR ARRAY OF DIMENSION N*(N+1)/2 .
+C B = SCRATCH ARRAY, 8*N ELEMENTS (NOTE THIS IS MORE THAN
+C PREVIOUS VERSIONS OF GIVENS.)
+C IND = INDEX ARRAY OF N ELEMENTS
+C
+C OUTPUT..
+C A DESTROYED .
+C ROOT = ALL EIGENVALUES, ROOT(1) .LE. ... .LE. ROOT(N) .
+C (FOR OTHER ORDERINGS, SEE BELOW.)
+C VECT = EIGENVECTORS FOR ROOT(1),..., ROOT(NVECT) .
+C IERR = 0 IF NO ERROR DETECTED,
+C = K IF ITERATION FOR K-TH EIGENVALUE FAILED,
+C = -K IF ITERATION FOR K-TH EIGENVECTOR FAILED.
+C (FAILURES SHOULD BE VERY RARE. CONTACT MOLER.)
+C
+C CALLS MODIFIED EISPACK ROUTINES TRED3B, IMTQLV, TINVTB, AND
+C TRBK3B. THE ROUTINES TRED3B, TINVTB, AND TRBK3B.
+C THE ORIGINAL EISPACK ROUTINES TRED3, TINVIT, AND TRBAK3
+C WERE MODIFIED BY THE INTRODUCTION OF TWO ROUTINES FROM THE
+C BLAS LIBRARY - DDOT AND DAXPY.
+C
+C IF TINVIT FAILS TO CONVERGE, TQL2 IS CALLED
+C
+C SEE EISPACK USERS GUIDE, B. T. SMITH ET AL, SPRINGER-VERLAG
+C LECTURE NOTES IN COMPUTER SCIENCE, VOL. 6, 2-ND EDITION, 1976 .
+C NOTE THAT IMTQLV AND TINVTB HAVE INTERNAL MACHINE
+C DEPENDENT CONSTANTS.
+C
+ DATA ONE, ZERO /1.0D+00, 0.0D+00/
+ CALL TRED3B(N,(N*N+N)/2,A,B(1,1),B(1,2),B(1,3))
+ CALL IMTQLV(N,B(1,1),B(1,2),B(1,3),ROOT,INDB,IERR,B(1,4))
+ IF (IERR .NE. 0) RETURN
+C
+C TO REORDER ROOTS...
+C K = N/2
+C B(1,3) = 2.0D+00
+C DO 50 I = 1, K
+C J = N+1-I
+C T = ROOT(I)
+C ROOT(I) = ROOT(J)
+C ROOT(J) = T
+C 50 CONTINUE
+C
+ IF (NVECT .LE. 0) RETURN
+ CALL TINVTB(NV,N,B(1,1),B(1,2),B(1,3),NVECT,ROOT,INDB,VECT,IERR,
+ + B(1,4),B(1,5),B(1,6),B(1,7),B(1,8))
+ IF (IERR .EQ. 0) GO TO 160
+C
+C IF INVERSE ITERATION GIVES AN ERROR IN DETERMINING THE
+C EIGENVECTORS, TRY THE QL ALGORITHM IF ALL THE EIGENVECTORS
+C ARE DESIRED.
+C
+ IF (NVECT .NE. N) RETURN
+ DO 120 I = 1, NVECT
+ DO 100 J = 1, N
+ VECT(I,J) = ZERO
+ 100 CONTINUE
+ VECT(I,I) = ONE
+ 120 CONTINUE
+ CALL TQL2 (NV,N,B(1,1),B(1,2),VECT,IERR)
+ DO 140 I = 1, NVECT
+ ROOT(I) = B(I,1)
+ 140 CONTINUE
+ IF (IERR .NE. 0) RETURN
+ 160 CALL TRBK3B(NV,N,(N*N+N)/2,A,NVECT,VECT)
+ RETURN
+ END
+C*MODULE EIGEN *DECK GLDIAG
+ SUBROUTINE GLDIAG(LDVECT,NVECT,N,H,WRK,EIG,VECTOR,IERR,IWRK)
+C
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+C
+ LOGICAL GOPARR,DSKWRK,MASWRK
+C
+ DIMENSION H(*),WRK(N,8),EIG(N),VECTOR(LDVECT,NVECT),IWRK(N)
+C
+ COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(400)
+ COMMON /MACHSW/ KDIAG,ICORFL,IXDR
+ COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
+C
+C ----- GENERAL ROUTINE TO DIAGONALIZE A SYMMETRIC MATRIX -----
+C IF KDIAG = 0, USE A ROUTINE FROM THE VECTOR LIBRARY,
+C IF AVAILABLE (SEE THE SUBROUTINE 'GLDIAG'
+C IN VECTOR.SRC), OR EVVRSP OTHERWISE
+C = 1, USE EVVRSP
+C = 2, USE GIVEIS
+C = 3, USE JACOBI
+C
+C N = DIMENSION (ORDER) OF MATRIX TO BE SOLVED
+C LDVECT = LEADING DIMENSION OF VECTOR
+C NVECT = NUMBER OF VECTORS DESIRED
+C H = MATRIX TO BE DIAGONALIZED
+C WRK = N*8 W.P. REAL WORDS OF SCRATCH SPACE
+C EIG = EIGENVECTORS (OUTPUT)
+C VECTOR = EIGENVECTORS (OUTPUT)
+C IERR = ERROR FLAG (OUTPUT)
+C IWRK = N INTEGER WORDS OF SCRATCH SPACE
+C
+ IERR = 0
+C
+C ----- USE STEVE ELBERT'S ROUTINE -----
+C
+ IF(KDIAG.LE.1 .OR. KDIAG.GT.3) THEN
+ LENH = (N*N+N)/2
+ KORDER =0
+ CALL EVVRSP(IW,N,NVECT,LENH,LDVECT,H,WRK,IWRK,EIG,VECTOR
+ * ,KORDER,IERR)
+ END IF
+C
+C ----- USE MODIFIED EISPAK ROUTINE -----
+C
+ IF(KDIAG.EQ.2)
+ * CALL GIVEIS(N,NVECT,LDVECT,H,WRK,IWRK,EIG,VECTOR,IERR)
+C
+C ----- USE JACOBI ROTATION ROUTINE -----
+C
+ IF(KDIAG.EQ.3) THEN
+ IF(NVECT.EQ.N) THEN
+ CALL JACDG(H,VECTOR,EIG,IWRK,WRK,LDVECT,N)
+ ELSE
+ IF (MASWRK) WRITE(IW,9000) N,NVECT,LDVECT
+ CALL ABRT
+ END IF
+ END IF
+ RETURN
+C
+ 9000 FORMAT(1X,'IN -GLDIAG-, N,NVECT,LDVECT=',3I8/
+ * 1X,'THE JACOBI CODE CANNOT COPE WITH N.NE.NVECT!'/
+ * 1X,'SO THIS RUN DOES NOT PERMIT KDIAG=3.')
+ END
+C*MODULE EIGEN *DECK IMTQLV
+ SUBROUTINE IMTQLV(N,D,E,E2,W,IND,IERR,RV1)
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ INTEGER TAG
+ DOUBLE PRECISION MACHEP
+ DIMENSION D(N),E(N),E2(N),W(N),RV1(N),IND(N)
+C
+C THIS ROUTINE IS A VARIANT OF IMTQL1 WHICH IS A TRANSLATION OF
+C ALGOL PROCEDURE IMTQL1, NUM. MATH. 12, 377-383(1968) BY MARTIN AND
+C WILKINSON, AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE.
+C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971).
+C
+C THIS ROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC TRIDIAGONAL
+C MATRIX BY THE IMPLICIT QL METHOD AND ASSOCIATES WITH THEM
+C THEIR CORRESPONDING SUBMATRIX INDICES.
+C
+C ON INPUT-
+C
+C N IS THE ORDER OF THE MATRIX,
+C
+C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX,
+C
+C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
+C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY,
+C
+C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
+C E2(1) IS ARBITRARY.
+C
+C ON OUTPUT-
+C
+C D AND E ARE UNALTERED,
+C
+C ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED
+C AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE
+C MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES.
+C E2(1) IS ALSO SET TO ZERO,
+C
+C W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN
+C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND
+C ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE
+C THE SMALLEST EIGENVALUES,
+C
+C IND CONTAINS THE SUBMATRIX INDICES ASSOCIATED WITH THE
+C CORRESPONDING EIGENVALUES IN W -- 1 FOR EIGENVALUES
+C BELONGING TO THE FIRST SUBMATRIX FROM THE TOP,
+C 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC.,
+C
+C IERR IS SET TO
+C ZERO FOR NORMAL RETURN,
+C J IF THE J-TH EIGENVALUE HAS NOT BEEN
+C DETERMINED AFTER 30 ITERATIONS,
+C
+C RV1 IS A TEMPORARY STORAGE ARRAY.
+C
+C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
+C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
+C
+C ------------------------------------------------------------------
+C
+C ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING
+C THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC.
+C
+C **********
+ MACHEP = 2.0D+00**(-50)
+C
+ IERR = 0
+ K = 0
+ TAG = 0
+C
+ DO 100 I = 1, N
+ W(I) = D(I)
+ IF (I .NE. 1) RV1(I-1) = E(I)
+ 100 CONTINUE
+C
+ E2(1) = 0.0D+00
+ RV1(N) = 0.0D+00
+C
+ DO 360 L = 1, N
+ J = 0
+C ********** LOOK FOR SMALL SUB-DIAGONAL ELEMENT **********
+ 120 DO 140 M = L, N
+ IF (M .EQ. N) GO TO 160
+ IF (ABS(RV1(M)) .LE. MACHEP * (ABS(W(M)) + ABS(W(M+1)))) GO TO
+ + 160
+C ********** GUARD AGAINST UNDERFLOWED ELEMENT OF E2 **********
+ IF (E2(M+1) .EQ. 0.0D+00) GO TO 180
+ 140 CONTINUE
+C
+ 160 IF (M .LE. K) GO TO 200
+ IF (M .NE. N) E2(M+1) = 0.0D+00
+ 180 K = M
+ TAG = TAG + 1
+ 200 P = W(L)
+ IF (M .EQ. L) GO TO 280
+ IF (J .EQ. 30) GO TO 380
+ J = J + 1
+C ********** FORM SHIFT **********
+ G = (W(L+1) - P) / (2.0D+00 * RV1(L))
+ R = SQRT(G*G+1.0D+00)
+ G = W(M) - P + RV1(L) / (G + SIGN(R,G))
+ S = 1.0D+00
+ C = 1.0D+00
+ P = 0.0D+00
+ MML = M - L
+C ********** FOR I=M-1 STEP -1 UNTIL L DO -- **********
+ DO 260 II = 1, MML
+ I = M - II
+ F = S * RV1(I)
+ B = C * RV1(I)
+ IF (ABS(F) .LT. ABS(G)) GO TO 220
+ C = G / F
+ R = SQRT(C*C+1.0D+00)
+ RV1(I+1) = F * R
+ S = 1.0D+00 / R
+ C = C * S
+ GO TO 240
+ 220 S = F / G
+ R = SQRT(S*S+1.0D+00)
+ RV1(I+1) = G * R
+ C = 1.0D+00 / R
+ S = S * C
+ 240 G = W(I+1) - P
+ R = (W(I) - G) * S + 2.0D+00 * C * B
+ P = S * R
+ W(I+1) = G + P
+ G = C * R - B
+ 260 CONTINUE
+C
+ W(L) = W(L) - P
+ RV1(L) = G
+ RV1(M) = 0.0D+00
+ GO TO 120
+C ********** ORDER EIGENVALUES **********
+ 280 IF (L .EQ. 1) GO TO 320
+C ********** FOR I=L STEP -1 UNTIL 2 DO -- **********
+ DO 300 II = 2, L
+ I = L + 2 - II
+ IF (P .GE. W(I-1)) GO TO 340
+ W(I) = W(I-1)
+ IND(I) = IND(I-1)
+ 300 CONTINUE
+C
+ 320 I = 1
+ 340 W(I) = P
+ IND(I) = TAG
+ 360 CONTINUE
+C
+ GO TO 400
+C ********** SET ERROR -- NO CONVERGENCE TO AN
+C EIGENVALUE AFTER 30 ITERATIONS **********
+ 380 IERR = L
+ 400 RETURN
+C ********** LAST CARD OF IMTQLV **********
+ END
+C*MODULE EIGEN *DECK JACDG
+ SUBROUTINE JACDG(A,VEC,EIG,JBIG,BIG,LDVEC,N)
+C
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+C
+ DIMENSION A(*),VEC(LDVEC,N),EIG(N),JBIG(N),BIG(N)
+C
+ PARAMETER (ONE=1.0D+00)
+C
+C ----- JACOBI DIAGONALIZATION OF SYMMETRIC MATRIX -----
+C SYMMETRIC MATRIX -A- OF DIMENSION -N- IS DESTROYED ON EXIT.
+C ALL EIGENVECTORS ARE FOUND, SO -VEC- MUST BE SQUARE,
+C UNLESS SOMEONE TAKES THE TROUBLE TO LOOK AT -NMAX- BELOW.
+C -BIG- AND -JBIG- ARE SCRATCH WORK ARRAYS.
+C
+ CALL VCLR(VEC,1,LDVEC*N)
+ DO 20 I = 1,N
+ VEC(I,I) = ONE
+ 20 CONTINUE
+C
+ NB1 = N
+ NB2 = (NB1*NB1+NB1)/2
+ NMIN = 1
+ NMAX = NB1
+C
+ CALL JACDIA(A,VEC,NB1,NB2,LDVEC,NMIN,NMAX,BIG,JBIG)
+C
+ DO 30 I=1,N
+ EIG(I) = A((I*I+I)/2)
+ 30 CONTINUE
+C
+ CALL JACORD(VEC,EIG,NB1,LDVEC)
+ RETURN
+ END
+C*MODULE EIGEN *DECK JACDIA
+ SUBROUTINE JACDIA(F,VEC,NB1,NB2,LDVEC,NMIN,NMAX,BIG,JBIG)
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ LOGICAL GOPARR,DSKWRK,MASWRK
+ DIMENSION F(NB2),VEC(LDVEC,NB1),BIG(NB1),JBIG(NB1)
+C
+ COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
+C
+ PARAMETER (ROOT2=0.707106781186548D+00 )
+ PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, D1050=1.05D+00,
+ * D1500=1.5D+00, D3875=3.875D+00,
+ * D0500=0.5D+00, D1375=1.375D+00, D0250=0.25D+00 )
+ PARAMETER (C2=1.0D-12, C3=4.0D-16,
+ * C4=2.0D-16, C5=8.0D-09, C6=3.0D-06 )
+C
+C F IS THE MATRIX TO BE DIAGONALIZED, F IS STORED TRIANGULAR
+C VEC IS THE ARRAY OF EIGENVECTORS, DIMENSION NB1*NB1
+C BIG AND JBIG ARE TEMPORARY SCRATCH AREAS OF DIMENSION NB1
+C THE ROTATIONS AMONG THE FIRST NMIN BASIS FUNCTIONS ARE NOT
+C ACCOUNTED FOR.
+C THE ROTATIONS AMONG THE LAST NB1-NMAX BASIS FUNCTIONS ARE NOT
+C ACCOUNTED FOR.
+C
+ IEAA=0
+ IEAB=0
+ TT=ZERO
+ EPS = 64.0D+00*EPSLON(ONE)
+C
+C LOOP OVER COLUMNS (K) OF TRIANGULAR MATRIX TO DETERMINE
+C LARGEST OFF-DIAGONAL ELEMENTS IN ROW(I).
+C
+ DO 20 I=1,NB1
+ BIG(I)=ZERO
+ JBIG(I)=0
+ IF(I.LT.NMIN .OR. I.EQ.1) GO TO 20
+ II = (I*I-I)/2
+ J=MIN(I-1,NMAX)
+ DO 10 K=1,J
+ IF(ABS(BIG(I)).GE.ABS(F(II+K))) GO TO 10
+ BIG(I)=F(II+K)
+ JBIG(I)=K
+ 10 CONTINUE
+ 20 CONTINUE
+C
+C ----- 2X2 JACOBI ITERATIONS BEGIN HERE -----
+C
+ MAXIT=MAX(NB2*20,500)
+ ITER=0
+ 30 CONTINUE
+ ITER=ITER+1
+C
+C FIND SMALLEST DIAGONAL ELEMENT
+C
+ SD=D1050
+ JJ=0
+ DO 40 J=1,NB1
+ JJ=JJ+J
+ SD= MIN(SD,ABS(F(JJ)))
+ 40 CONTINUE
+ TEST = MAX(EPS, C2*MAX(SD,C6))
+C
+C FIND LARGEST OFF-DIAGONAL ELEMENT
+C
+ T=ZERO
+ I1=MAX(2,NMIN)
+ IB = I1
+ DO 50 I=I1,NB1
+ IF(T.GE.ABS(BIG(I))) GO TO 50
+ T= ABS(BIG(I))
+ IB=I
+ 50 CONTINUE
+C
+C TEST FOR CONVERGENCE, THEN DETERMINE ROTATION.
+C
+ IF(T.LT.TEST) RETURN
+C ******
+C
+ IF(ITER.GT.MAXIT) THEN
+ IF (MASWRK) THEN
+ WRITE(6,*) 'JACOBI DIAGONALIZATION FAILS, DIMENSION=',NB1
+ WRITE(6,9020) ITER,T,TEST,SD
+ ENDIF
+ CALL ABRT
+ STOP
+ END IF
+C
+ IA=JBIG(IB)
+ IAA=IA*(IA-1)/2
+ IBB=IB*(IB-1)/2
+ DIF=F(IAA+IA)-F(IBB+IB)
+ IF(ABS(DIF).GT.C3*T) GO TO 70
+ SX=ROOT2
+ CX=ROOT2
+ GO TO 110
+ 70 T2X2=BIG(IB)/DIF
+ T2X25=T2X2*T2X2
+ IF(T2X25 . GT . C4) GO TO 80
+ CX=ONE
+ SX=T2X2
+ GO TO 110
+ 80 IF(T2X25 . GT . C5) GO TO 90
+ SX=T2X2*(ONE-D1500*T2X25)
+ CX=ONE-D0500*T2X25
+ GO TO 110
+ 90 IF(T2X25 . GT . C6) GO TO 100
+ CX=ONE+T2X25*(T2X25*D1375 - D0500)
+ SX= T2X2*(ONE + T2X25*(T2X25*D3875 - D1500))
+ GO TO 110
+ 100 T=D0250 / SQRT(D0250 + T2X25)
+ CX= SQRT(D0500 + T)
+ SX= SIGN( SQRT(D0500 - T),T2X2)
+ 110 IEAR=IAA+1
+ IEBR=IBB+1
+C
+ DO 230 IR=1,NB1
+ T=F(IEAR)*SX
+ F(IEAR)=F(IEAR)*CX+F(IEBR)*SX
+ F(IEBR)=T-F(IEBR)*CX
+ IF(IR-IA) 220,120,130
+ 120 TT=F(IEBR)
+ IEAA=IEAR
+ IEAB=IEBR
+ F(IEBR)=BIG(IB)
+ IEAR=IEAR+IR-1
+ IF(JBIG(IR)) 200,220,200
+ 130 T=F(IEAR)
+ IT=IA
+ IEAR=IEAR+IR-1
+ IF(IR-IB) 180,150,160
+ 150 F(IEAA)=F(IEAA)*CX+F(IEAB)*SX
+ F(IEAB)=TT*CX+F(IEBR)*SX
+ F(IEBR)=TT*SX-F(IEBR)*CX
+ IEBR=IEBR+IR-1
+ GO TO 200
+ 160 IF( ABS(T) . GE . ABS(F(IEBR))) GO TO 170
+ IF(IB.GT.NMAX) GO TO 170
+ T=F(IEBR)
+ IT=IB
+ 170 IEBR=IEBR+IR-1
+ 180 IF( ABS(T) . LT . ABS(BIG(IR))) GO TO 190
+ BIG(IR) = T
+ JBIG(IR) = IT
+ GO TO 220
+ 190 IF(IA . NE . JBIG(IR) . AND . IB . NE . JBIG(IR)) GO TO 220
+ 200 KQ=IEAR-IR-IA+1
+ BIG(IR)=ZERO
+ IR1=MIN(IR-1,NMAX)
+ DO 210 I=1,IR1
+ K=KQ+I
+ IF(ABS(BIG(IR)) . GE . ABS(F(K))) GO TO 210
+ BIG(IR) = F(K)
+ JBIG(IR)=I
+ 210 CONTINUE
+ 220 IEAR=IEAR+1
+ 230 IEBR=IEBR+1
+C
+ DO 240 I=1,NB1
+ T1=VEC(I,IA)*CX + VEC(I,IB)*SX
+ T2=VEC(I,IA)*SX - VEC(I,IB)*CX
+ VEC(I,IA)=T1
+ VEC(I,IB)=T2
+ 240 CONTINUE
+ GO TO 30
+C
+ 9020 FORMAT(1X,'ITER=',I6,' T,TEST,SD=',1P,3E20.10)
+ END
+C*MODULE EIGEN *DECK JACORD
+ SUBROUTINE JACORD(VEC,EIG,N,LDVEC)
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ DIMENSION VEC(LDVEC,N),EIG(N)
+C
+C ---- SORT EIGENDATA INTO ASCENDING ORDER -----
+C
+ DO 290 I = 1, N
+ JJ = I
+ DO 270 J = I, N
+ IF (EIG(J) .LT. EIG(JJ)) JJ = J
+ 270 CONTINUE
+ IF (JJ .EQ. I) GO TO 290
+ T = EIG(JJ)
+ EIG(JJ) = EIG(I)
+ EIG(I) = T
+ DO 280 J = 1, N
+ T = VEC(J,JJ)
+ VEC(J,JJ) = VEC(J,I)
+ VEC(J,I) = T
+ 280 CONTINUE
+ 290 CONTINUE
+ RETURN
+ END
+C*MODULE EIGEN *DECK TINVTB
+ SUBROUTINE TINVTB(NM,N,D,E,E2,M,W,IND,Z,
+ * IERR,RV1,RV2,RV3,RV4,RV6)
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ DIMENSION D(N),E(N),E2(N),W(M),Z(NM,M),
+ * RV1(N),RV2(N),RV3(N),RV4(N),RV6(N),IND(M)
+ DOUBLE PRECISION MACHEP,NORM
+ INTEGER P,Q,R,S,TAG,GROUP
+C ------------------------------------------------------------------
+C
+C THIS ROUTINE IS A TRANSLATION OF THE INVERSE ITERATION TECH-
+C NIQUE IN THE ALGOL PROCEDURE TRISTURM BY PETERS AND WILKINSON.
+C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971).
+C
+C THIS ROUTINE FINDS THOSE EIGENVECTORS OF A TRIDIAGONAL
+C SYMMETRIC MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES,
+C USING INVERSE ITERATION.
+C
+C ON INPUT-
+C
+C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
+C ARRAY PARAMETERS AS DECLARED IN THE CALLING ROUTINE
+C DIMENSION STATEMENT,
+C
+C N IS THE ORDER OF THE MATRIX,
+C
+C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX,
+C
+C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
+C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY,
+C
+C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E,
+C WITH ZEROS CORRESPONDING TO NEGLIGIBLE ELEMENTS OF E.
+C E(I) IS CONSIDERED NEGLIGIBLE IF IT IS NOT LARGER THAN
+C THE PRODUCT OF THE RELATIVE MACHINE PRECISION AND THE SUM
+C OF THE MAGNITUDES OF D(I) AND D(I-1). E2(1) MUST CONTAIN
+C 0.0 IF THE EIGENVALUES ARE IN ASCENDING ORDER, OR 2.0
+C IF THE EIGENVALUES ARE IN DESCENDING ORDER. IF BISECT,
+C TRIDIB, OR IMTQLV HAS BEEN USED TO FIND THE EIGENVALUES,
+C THEIR OUTPUT E2 ARRAY IS EXACTLY WHAT IS EXPECTED HERE,
+C
+C M IS THE NUMBER OF SPECIFIED EIGENVALUES,
+C
+C W CONTAINS THE M EIGENVALUES IN ASCENDING OR DESCENDING ORDER,
+C
+C IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES
+C ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W --
+C 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM
+C THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC.
+C
+C ON OUTPUT-
+C
+C ALL INPUT ARRAYS ARE UNALTERED,
+C
+C Z CONTAINS THE ASSOCIATED SET OF ORTHONORMAL EIGENVECTORS.
+C ANY VECTOR WHICH FAILS TO CONVERGE IS SET TO ZERO,
+C
+C IERR IS SET TO
+C ZERO FOR NORMAL RETURN,
+C -R IF THE EIGENVECTOR CORRESPONDING TO THE R-TH
+C EIGENVALUE FAILS TO CONVERGE IN 5 ITERATIONS,
+C
+C RV1, RV2, RV3, RV4, AND RV6 ARE TEMPORARY STORAGE ARRAYS.
+C
+C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
+C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
+C
+C ------------------------------------------------------------------
+C
+C ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING
+C THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC.
+C
+C **********
+ MACHEP = 2.0D+00**(-50)
+C
+ IERR = 0
+ IF (M .EQ. 0) GO TO 680
+ TAG = 0
+ ORDER = 1.0D+00 - E2(1)
+ XU = 0.0D+00
+ UK = 0.0D+00
+ X0 = 0.0D+00
+ U = 0.0D+00
+ EPS2 = 0.0D+00
+ EPS3 = 0.0D+00
+ EPS4 = 0.0D+00
+ GROUP = 0
+ Q = 0
+C ********** ESTABLISH AND PROCESS NEXT SUBMATRIX **********
+ 100 P = Q + 1
+ IP = P + 1
+C
+ DO 120 Q = P, N
+ IF (Q .EQ. N) GO TO 140
+ IF (E2(Q+1) .EQ. 0.0D+00) GO TO 140
+ 120 CONTINUE
+C ********** FIND VECTORS BY INVERSE ITERATION **********
+ 140 TAG = TAG + 1
+ IQMP = Q - P + 1
+ S = 0
+C
+ DO 660 R = 1, M
+ IF (IND(R) .NE. TAG) GO TO 660
+ ITS = 1
+ X1 = W(R)
+ IF (S .NE. 0) GO TO 220
+C ********** CHECK FOR ISOLATED ROOT **********
+ XU = 1.0D+00
+ IF (P .NE. Q) GO TO 160
+ RV6(P) = 1.0D+00
+ GO TO 600
+ 160 NORM = ABS(D(P))
+C
+ DO 180 I = IP, Q
+ 180 NORM = NORM + ABS(D(I)) + ABS(E(I))
+C ********** EPS2 IS THE CRITERION FOR GROUPING,
+C EPS3 REPLACES ZERO PIVOTS AND EQUAL
+C ROOTS ARE MODIFIED BY EPS3,
+C EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW **********
+ EPS2 = 1.0D-03 * NORM
+ EPS3 = MACHEP * NORM
+ UK = IQMP
+ EPS4 = UK * EPS3
+ UK = EPS4 / SQRT(UK)
+ S = P
+ 200 GROUP = 0
+ GO TO 240
+C ********** LOOK FOR CLOSE OR COINCIDENT ROOTS **********
+ 220 IF (ABS(X1-X0) .GE. EPS2) GO TO 200
+ GROUP = GROUP + 1
+ IF (ORDER * (X1 - X0) .LE. 0.0D+00) X1 = X0 + ORDER * EPS3
+C ********** ELIMINATION WITH INTERCHANGES AND
+C INITIALIZATION OF VECTOR **********
+ 240 V = 0.0D+00
+C
+ DO 300 I = P, Q
+ RV6(I) = UK
+ IF (I .EQ. P) GO TO 280
+ IF (ABS(E(I)) .LT. ABS(U)) GO TO 260
+C ********** WARNING -- A DIVIDE CHECK MAY OCCUR HERE IF
+C E2 ARRAY HAS NOT BEEN SPECIFIED CORRECTLY **********
+ XU = U / E(I)
+ RV4(I) = XU
+ RV1(I-1) = E(I)
+ RV2(I-1) = D(I) - X1
+ RV3(I-1) = 0.0D+00
+ IF (I .NE. Q) RV3(I-1) = E(I+1)
+ U = V - XU * RV2(I-1)
+ V = -XU * RV3(I-1)
+ GO TO 300
+ 260 XU = E(I) / U
+ RV4(I) = XU
+ RV1(I-1) = U
+ RV2(I-1) = V
+ RV3(I-1) = 0.0D+00
+ 280 U = D(I) - X1 - XU * V
+ IF (I .NE. Q) V = E(I+1)
+ 300 CONTINUE
+C
+ IF (U .EQ. 0.0D+00) U = EPS3
+ RV1(Q) = U
+ RV2(Q) = 0.0D+00
+ RV3(Q) = 0.0D+00
+C ********** BACK SUBSTITUTION
+C FOR I=Q STEP -1 UNTIL P DO -- **********
+ 320 DO 340 II = P, Q
+ I = P + Q - II
+ RV6(I) = (RV6(I) - U * RV2(I) - V * RV3(I)) / RV1(I)
+ V = U
+ U = RV6(I)
+ 340 CONTINUE
+C ********** ORTHOGONALIZE WITH RESPECT TO PREVIOUS
+C MEMBERS OF GROUP **********
+ IF (GROUP .EQ. 0) GO TO 400
+ J = R
+C
+ DO 380 JJ = 1, GROUP
+ 360 J = J - 1
+ IF (IND(J) .NE. TAG) GO TO 360
+ XU = DDOT(IQMP,RV6(P),1,Z(P,J),1)
+C
+ CALL DAXPY(IQMP,-XU,Z(P,J),1,RV6(P),1)
+C
+ 380 CONTINUE
+C
+ 400 NORM = 0.0D+00
+C
+ DO 420 I = P, Q
+ 420 NORM = NORM + ABS(RV6(I))
+C
+ IF (NORM .GE. 1.0D+00) GO TO 560
+C ********** FORWARD SUBSTITUTION **********
+ IF (ITS .EQ. 5) GO TO 540
+ IF (NORM .NE. 0.0D+00) GO TO 440
+ RV6(S) = EPS4
+ S = S + 1
+ IF (S .GT. Q) S = P
+ GO TO 480
+ 440 XU = EPS4 / NORM
+C
+ DO 460 I = P, Q
+ 460 RV6(I) = RV6(I) * XU
+C ********** ELIMINATION OPERATIONS ON NEXT VECTOR
+C ITERATE **********
+ 480 DO 520 I = IP, Q
+ U = RV6(I)
+C ********** IF RV1(I-1) .EQ. E(I), A ROW INTERCHANGE
+C WAS PERFORMED EARLIER IN THE
+C TRIANGULARIZATION PROCESS **********
+ IF (RV1(I-1) .NE. E(I)) GO TO 500
+ U = RV6(I-1)
+ RV6(I-1) = RV6(I)
+ 500 RV6(I) = U - RV4(I) * RV6(I-1)
+ 520 CONTINUE
+C
+ ITS = ITS + 1
+ GO TO 320
+C ********** SET ERROR -- NON-CONVERGED EIGENVECTOR **********
+ 540 IERR = -R
+ XU = 0.0D+00
+ GO TO 600
+C ********** NORMALIZE SO THAT SUM OF SQUARES IS
+C 1 AND EXPAND TO FULL ORDER **********
+ 560 U = 0.0D+00
+C
+ DO 580 I = P, Q
+ RV6(I) = RV6(I) / NORM
+ 580 U = U + RV6(I)**2
+C
+ XU = 1.0D+00 / SQRT(U)
+C
+ 600 DO 620 I = 1, N
+ 620 Z(I,R) = 0.0D+00
+C
+ DO 640 I = P, Q
+ 640 Z(I,R) = RV6(I) * XU
+C
+ X0 = X1
+ 660 CONTINUE
+C
+ IF (Q .LT. N) GO TO 100
+ 680 RETURN
+C ********** LAST CARD OF TINVIT **********
+ END
+C*MODULE EIGEN *DECK TQL2
+C
+C ------------------------------------------------------------------
+C
+ SUBROUTINE TQL2(NM,N,D,E,Z,IERR)
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ DOUBLE PRECISION MACHEP
+ DIMENSION D(N),E(N),Z(NM,N)
+C
+C THIS ROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQL2,
+C NUM. MATH. 11, 293-306(1968) BY BOWDLER, MARTIN, REINSCH, AND
+C WILKINSON.
+C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971).
+C
+C THIS ROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
+C OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE QL METHOD.
+C THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO
+C BE FOUND IF TRED2 HAS BEEN USED TO REDUCE THIS
+C FULL MATRIX TO TRIDIAGONAL FORM.
+C
+C ON INPUT-
+C
+C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
+C ARRAY PARAMETERS AS DECLARED IN THE CALLING ROUTINE
+C DIMENSION STATEMENT,
+C
+C N IS THE ORDER OF THE MATRIX,
+C
+C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX,
+C
+C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
+C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY,
+C
+C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
+C REDUCTION BY TRED2, IF PERFORMED. IF THE EIGENVECTORS
+C OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN
+C THE IDENTITY MATRIX.
+C
+C ON OUTPUT-
+C
+C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN
+C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT
+C UNORDERED FOR INDICES 1,2,...,IERR-1,
+C
+C E HAS BEEN DESTROYED,
+C
+C Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC
+C TRIDIAGONAL (OR FULL) MATRIX. IF AN ERROR EXIT IS MADE,
+C Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED
+C EIGENVALUES,
+C
+C IERR IS SET TO
+C ZERO FOR NORMAL RETURN,
+C J IF THE J-TH EIGENVALUE HAS NOT BEEN
+C DETERMINED AFTER 30 ITERATIONS.
+C
+C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
+C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
+C
+C ------------------------------------------------------------------
+C
+C ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING
+C THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC.
+C
+C **********
+ MACHEP = 2.0D+00**(-50)
+C
+ IERR = 0
+ IF (N .EQ. 1) GO TO 400
+C
+ DO 100 I = 2, N
+ 100 E(I-1) = E(I)
+C
+ F = 0.0D+00
+ B = 0.0D+00
+ E(N) = 0.0D+00
+C
+ DO 300 L = 1, N
+ J = 0
+ H = MACHEP * (ABS(D(L)) + ABS(E(L)))
+ IF (B .LT. H) B = H
+C ********** LOOK FOR SMALL SUB-DIAGONAL ELEMENT **********
+ DO 120 M = L, N
+ IF (ABS(E(M)) .LE. B) GO TO 140
+C ********** E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT
+C THROUGH THE BOTTOM OF THE LOOP **********
+ 120 CONTINUE
+C
+ 140 IF (M .EQ. L) GO TO 280
+ 160 IF (J .EQ. 30) GO TO 380
+ J = J + 1
+C ********** FORM SHIFT **********
+ L1 = L + 1
+ G = D(L)
+ P = (D(L1) - G) / (2.0D+00 * E(L))
+ R = SQRT(P*P+1.0D+00)
+ D(L) = E(L) / (P + SIGN(R,P))
+ H = G - D(L)
+C
+ DO 180 I = L1, N
+ 180 D(I) = D(I) - H
+C
+ F = F + H
+C ********** QL TRANSFORMATION **********
+ P = D(M)
+ C = 1.0D+00
+ S = 0.0D+00
+ MML = M - L
+C ********** FOR I=M-1 STEP -1 UNTIL L DO -- **********
+ DO 260 II = 1, MML
+ I = M - II
+ G = C * E(I)
+ H = C * P
+ IF (ABS(P) .LT. ABS(E(I))) GO TO 200
+ C = E(I) / P
+ R = SQRT(C*C+1.0D+00)
+ E(I+1) = S * P * R
+ S = C / R
+ C = 1.0D+00 / R
+ GO TO 220
+ 200 C = P / E(I)
+ R = SQRT(C*C+1.0D+00)
+ E(I+1) = S * E(I) * R
+ S = 1.0D+00 / R
+ C = C * S
+ 220 P = C * D(I) - S * G
+ D(I+1) = H + S * (C * G + S * D(I))
+C ********** FORM VECTOR **********
+ CALL DROT(N,Z(1,I+1),1,Z(1,I),1,C,S)
+C
+ 260 CONTINUE
+C
+ E(L) = S * P
+ D(L) = C * P
+ IF (ABS(E(L)) .GT. B) GO TO 160
+ 280 D(L) = D(L) + F
+ 300 CONTINUE
+C ********** ORDER EIGENVALUES AND EIGENVECTORS **********
+ DO 360 II = 2, N
+ I = II - 1
+ K = I
+ P = D(I)
+C
+ DO 320 J = II, N
+ IF (D(J) .GE. P) GO TO 320
+ K = J
+ P = D(J)
+ 320 CONTINUE
+C
+ IF (K .EQ. I) GO TO 360
+ D(K) = D(I)
+ D(I) = P
+C
+ CALL DSWAP(N,Z(1,I),1,Z(1,K),1)
+C
+ 360 CONTINUE
+C
+ GO TO 400
+C ********** SET ERROR -- NO CONVERGENCE TO AN
+C EIGENVALUE AFTER 30 ITERATIONS **********
+ 380 IERR = L
+ 400 RETURN
+C ********** LAST CARD OF TQL2 **********
+ END
+C*MODULE EIGEN *DECK TRBK3B
+C
+C ------------------------------------------------------------------
+C
+ SUBROUTINE TRBK3B(NM,N,NV,A,M,Z)
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ DIMENSION A(NV),Z(NM,M)
+C
+C THIS ROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRBAK3,
+C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
+C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
+C
+C THIS ROUTINE FORMS THE EIGENVECTORS OF A REAL SYMMETRIC
+C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
+C SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY TRED3B.
+C
+C ON INPUT-
+C
+C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
+C ARRAY PARAMETERS AS DECLARED IN THE CALLING ROUTINE
+C DIMENSION STATEMENT,
+C
+C N IS THE ORDER OF THE MATRIX,
+C
+C NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A
+C AS DECLARED IN THE CALLING ROUTINE DIMENSION STATEMENT,
+C
+C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANSFORMATIONS
+C USED IN THE REDUCTION BY TRED3B IN ITS FIRST
+C N*(N+1)/2 POSITIONS,
+C
+C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED,
+C
+C Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED
+C IN ITS FIRST M COLUMNS.
+C
+C ON OUTPUT-
+C
+C Z CONTAINS THE TRANSFORMED EIGENVECTORS
+C IN ITS FIRST M COLUMNS.
+C
+C NOTE THAT TRBAK3 PRESERVES VECTOR EUCLIDEAN NORMS.
+C
+C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
+C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
+C
+C ------------------------------------------------------------------
+C
+ IF (M .EQ. 0) GO TO 140
+ IF (N .EQ. 1) GO TO 140
+C
+ DO 120 I = 2, N
+ L = I - 1
+ IZ = (I * L) / 2
+ IK = IZ + I
+ H = A(IK)
+ IF (H .EQ. 0.0D+00) GO TO 120
+C
+ DO 100 J = 1, M
+ S = -DDOT(L,A(IZ+1),1,Z(1,J),1)
+C
+C ********** DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW **********
+ S = (S / H) / H
+C
+ CALL DAXPY(L,S,A(IZ+1),1,Z(1,J),1)
+C
+ 100 CONTINUE
+C
+ 120 CONTINUE
+C
+ 140 RETURN
+C ********** LAST CARD OF TRBAK3 **********
+ END
+C*MODULE EIGEN *DECK TRED3B
+C
+C ------------------------------------------------------------------
+C
+ SUBROUTINE TRED3B(N,NV,A,D,E,E2)
+ IMPLICIT DOUBLE PRECISION(A-H,O-Z)
+ DIMENSION A(NV),D(N),E(N),E2(N)
+C
+C THIS ROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED3,
+C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
+C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
+C
+C THIS ROUTINE REDUCES A REAL SYMMETRIC MATRIX, STORED AS
+C A ONE-DIMENSIONAL ARRAY, TO A SYMMETRIC TRIDIAGONAL MATRIX
+C USING ORTHOGONAL SIMILARITY TRANSFORMATIONS.
+C
+C ON INPUT-
+C
+C N IS THE ORDER OF THE MATRIX,
+C
+C NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A
+C AS DECLARED IN THE CALLING ROUTINE DIMENSION STATEMENT,
+C
+C A CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC
+C INPUT MATRIX, STORED ROW-WISE AS A ONE-DIMENSIONAL
+C ARRAY, IN ITS FIRST N*(N+1)/2 POSITIONS.
+C
+C ON OUTPUT-
+C
+C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL
+C TRANSFORMATIONS USED IN THE REDUCTION,
+C
+C D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX,
+C
+C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
+C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO,
+C
+C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
+C E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED.
+C
+C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
+C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
+C
+C ------------------------------------------------------------------
+C
+C ********** FOR I=N STEP -1 UNTIL 1 DO -- **********
+ DO 300 II = 1, N
+ I = N + 1 - II
+ L = I - 1
+ IZ = (I * L) / 2
+ H = 0.0D+00
+ SCALE = 0.0D+00
+ IF (L .LT. 1) GO TO 120
+C ********** SCALE ROW (ALGOL TOL THEN NOT NEEDED) **********
+ DO 100 K = 1, L
+ IZ = IZ + 1
+ D(K) = A(IZ)
+ SCALE = SCALE + ABS(D(K))
+ 100 CONTINUE
+C
+ IF (SCALE .NE. 0.0D+00) GO TO 140
+ 120 E(I) = 0.0D+00
+ E2(I) = 0.0D+00
+ GO TO 280
+C
+ 140 DO 160 K = 1, L
+ D(K) = D(K) / SCALE
+ H = H + D(K) * D(K)
+ 160 CONTINUE
+C
+ E2(I) = SCALE * SCALE * H
+ F = D(L)
+ G = -SIGN(SQRT(H),F)
+ E(I) = SCALE * G
+ H = H - F * G
+ D(L) = F - G
+ A(IZ) = SCALE * D(L)
+ IF (L .EQ. 1) GO TO 280
+ F = 0.0D+00
+C
+ JK = 1
+ DO 220 J = 1, L
+ JM1 = J - 1
+ DT = D(J)
+ G = 0.0D+00
+C ********** FORM ELEMENT OF A*U **********
+ IF (JM1 .EQ. 0) GO TO 200
+ DO 180 K = 1, JM1
+ E(K) = E(K) + DT * A(JK)
+ G = G + D(K) * A(JK)
+ JK = JK + 1
+ 180 CONTINUE
+ 200 E(J) = G + A(JK) * DT
+ JK = JK + 1
+C ********** FORM ELEMENT OF P **********
+ 220 CONTINUE
+ F = 0.0D+00
+ DO 240 J = 1, L
+ E(J) = E(J) / H
+ F = F + E(J) * D(J)
+ 240 CONTINUE
+C
+ HH = F / (H + H)
+ JK = 0
+C ********** FORM REDUCED A **********
+ DO 260 J = 1, L
+ F = D(J)
+ G = E(J) - HH * F
+ E(J) = G
+C
+ DO 260 K = 1, J
+ JK = JK + 1
+ A(JK) = A(JK) - F * E(K) - G * D(K)
+ 260 CONTINUE
+C
+ 280 D(I) = A(IZ+1)
+ A(IZ+1) = SCALE * SQRT(H)
+ 300 CONTINUE
+C
+ RETURN
+C ********** LAST CARD OF TRED3 **********
+ END
--- /dev/null
+ subroutine elecont(lprint,ncont,icont)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.LOCAL'
+ include 'COMMON.FFIELD'
+ include 'COMMON.NAMES'
+ logical lprint
+ double precision elpp_6(2,2),elpp_3(2,2),ael6_(2,2),ael3_(2,2)
+ double precision app_(2,2),bpp_(2,2),rpp_(2,2)
+ integer ncont,icont(2,maxcont)
+ double precision econt(maxcont)
+*
+* Load the constants of peptide bond - peptide bond interactions.
+* Type 1 - ordinary peptide bond, type 2 - alkylated peptide bond (e.g.
+* proline) - determined by averaging ECEPP energy.
+*
+* as of 7/06/91.
+*
+c data epp / 0.3045d0, 0.3649d0, 0.3649d0, 0.5743d0/
+ data rpp_ / 4.5088d0, 4.5395d0, 4.5395d0, 4.4846d0/
+ data elpp_6 /-0.2379d0,-0.2056d0,-0.2056d0,-0.0610d0/
+ data elpp_3 / 0.0503d0, 0.0000d0, 0.0000d0, 0.0692d0/
+ data elcutoff /-0.3d0/,elecutoff_14 /-0.5d0/
+ if (lprint) write (iout,'(a)')
+ & "Constants of electrostatic interaction energy expression."
+ 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.0*epp(i,j)*rri
+ ael6_(i,j)=elpp_6(i,j)*4.2**6
+ ael3_(i,j)=elpp_3(i,j)*4.2**3
+ if (lprint)
+ & write (iout,'(2i2,4e15.4)') i,j,app_(i,j),bpp_(i,j),ael6_(i,j),
+ & ael3_(i,j)
+ enddo
+ enddo
+ ncont=0
+ ees=0.0
+ evdw=0.0
+ do 1 i=nnt,nct-2
+ xi=c(1,i)
+ yi=c(2,i)
+ zi=c(3,i)
+ dxi=c(1,i+1)-c(1,i)
+ dyi=c(2,i+1)-c(2,i)
+ dzi=c(3,i+1)-c(3,i)
+ xmedi=xi+0.5*dxi
+ ymedi=yi+0.5*dyi
+ zmedi=zi+0.5*dzi
+ do 4 j=i+2,nct-1
+ ind=ind+1
+ iteli=itel(i)
+ itelj=itel(j)
+ if (j.eq.i+2 .and. itelj.eq.2) iteli=2
+ if (iteli.eq.2 .and. itelj.eq.2) goto 4
+ aaa=app_(iteli,itelj)
+ bbb=bpp_(iteli,itelj)
+ ael6_i=ael6_(iteli,itelj)
+ ael3_i=ael3_(iteli,itelj)
+ dxj=c(1,j+1)-c(1,j)
+ dyj=c(2,j+1)-c(2,j)
+ dzj=c(3,j+1)-c(3,j)
+ xj=c(1,j)+0.5*dxj-xmedi
+ yj=c(2,j)+0.5*dyj-ymedi
+ zj=c(3,j)+0.5*dzj-zmedi
+ rrmij=1.0/(xj*xj+yj*yj+zj*zj)
+ rmij=sqrt(rrmij)
+ r3ij=rrmij*rmij
+ r6ij=r3ij*r3ij
+ vrmij=vblinv*rmij
+ cosa=(dxi*dxj+dyi*dyj+dzi*dzj)*vblinv2
+ cosb=(xj*dxi+yj*dyi+zj*dzi)*vrmij
+ cosg=(xj*dxj+yj*dyj+zj*dzj)*vrmij
+ fac=cosa-3.0*cosb*cosg
+ ev1=aaa*r6ij*r6ij
+ ev2=bbb*r6ij
+ fac3=ael6_i*r6ij
+ fac4=ael3_i*r3ij
+ evdwij=ev1+ev2
+ el1=fac3*(4.0+fac*fac-3.0*(cosb*cosb+cosg*cosg))
+ el2=fac4*fac
+ eesij=el1+el2
+ if (j.gt.i+2 .and. eesij.le.elcutoff .or.
+ & j.eq.i+2 .and. eesij.le.elecutoff_14) then
+ ncont=ncont+1
+ icont(1,ncont)=i
+ icont(2,ncont)=j
+ econt(ncont)=eesij
+ endif
+ ees=ees+eesij
+ evdw=evdw+evdwij
+ 4 continue
+ 1 continue
+ if (lprint) then
+ write (iout,*) 'Total average electrostatic energy: ',ees
+ write (iout,*) 'VDW energy between peptide-group centers: ',evdw
+ write (iout,*)
+ write (iout,*) 'Electrostatic contacts before pruning: '
+ do i=1,ncont
+ i1=icont(1,i)
+ i2=icont(2,i)
+ it1=itype(i1)
+ it2=itype(i2)
+ write (iout,'(i3,2x,a,i4,2x,a,i4,f10.5)')
+ & i,restyp(it1),i1,restyp(it2),i2,econt(i)
+ enddo
+ endif
+c For given residues keep only the contacts with the greatest energy.
+ i=0
+ do while (i.lt.ncont)
+ i=i+1
+ ene=econt(i)
+ ic1=icont(1,i)
+ ic2=icont(2,i)
+ j=i
+ do while (j.lt.ncont)
+ j=j+1
+ if (ic1.eq.icont(1,j).and.iabs(icont(2,j)-ic2).le.2 .or.
+ & ic2.eq.icont(2,j).and.iabs(icont(1,j)-ic1).le.2) then
+c write (iout,*) "i",i," j",j," ic1",ic1," ic2",ic2,
+c & " jc1",icont(1,j)," jc2",icont(2,j)," ncont",ncont
+ if (econt(j).lt.ene .and. icont(2,j).ne.icont(1,j)+2) then
+ if (ic1.eq.icont(1,j)) then
+ do k=1,ncont
+ if (k.ne.i .and. k.ne.j .and. icont(2,k).eq.icont(2,j)
+ & .and. iabs(icont(1,k)-ic1).le.2 .and.
+ & econt(k).lt.econt(j) ) goto 21
+ enddo
+ else if (ic2.eq.icont(2,j) ) then
+ do k=1,ncont
+ if (k.ne.i .and. k.ne.j .and. icont(1,k).eq.icont(1,j)
+ & .and. iabs(icont(2,k)-ic2).le.2 .and.
+ & econt(k).lt.econt(j) ) goto 21
+ enddo
+ endif
+c Remove ith contact
+ do k=i+1,ncont
+ icont(1,k-1)=icont(1,k)
+ icont(2,k-1)=icont(2,k)
+ econt(k-1)=econt(k)
+ enddo
+ i=i-1
+ ncont=ncont-1
+c write (iout,*) "ncont",ncont
+c do k=1,ncont
+c write (iout,*) icont(1,k),icont(2,k)
+c enddo
+ goto 20
+ else if (econt(j).gt.ene .and. ic2.ne.ic1+2)
+ & then
+ if (ic1.eq.icont(1,j)) then
+ do k=1,ncont
+ if (k.ne.i .and. k.ne.j .and. icont(2,k).eq.ic2
+ & .and. iabs(icont(1,k)-icont(1,j)).le.2 .and.
+ & econt(k).lt.econt(i) ) goto 21
+ enddo
+ else if (ic2.eq.icont(2,j) ) then
+ do k=1,ncont
+ if (k.ne.i .and. k.ne.j .and. icont(1,k).eq.ic1
+ & .and. iabs(icont(2,k)-icont(2,j)).le.2 .and.
+ & econt(k).lt.econt(i) ) goto 21
+ enddo
+ endif
+c Remove jth contact
+ do k=j+1,ncont
+ icont(1,k-1)=icont(1,k)
+ icont(2,k-1)=icont(2,k)
+ econt(k-1)=econt(k)
+ enddo
+ ncont=ncont-1
+c write (iout,*) "ncont",ncont
+c do k=1,ncont
+c write (iout,*) icont(1,k),icont(2,k)
+c enddo
+ j=j-1
+ endif
+ endif
+ 21 continue
+ enddo
+ 20 continue
+ enddo
+ if (lprint) then
+ write (iout,*)
+ write (iout,*) 'Electrostatic contacts after pruning: '
+ do i=1,ncont
+ i1=icont(1,i)
+ i2=icont(2,i)
+ it1=itype(i1)
+ it2=itype(i2)
+ write (iout,'(i3,2x,a,i4,2x,a,i4,f10.5)')
+ & i,restyp(it1),i1,restyp(it2),i2,econt(i)
+ enddo
+ endif
+ return
+ end
+c--------------------------------------------
+ subroutine secondary2(lprint)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.DISTFIT'
+ include 'COMMON.VAR'
+ include 'COMMON.GEO'
+ include 'COMMON.CONTROL'
+ integer ncont,icont(2,maxcont),isec(maxres,4),nsec(maxres)
+ logical lprint,not_done,freeres
+ double precision p1,p2
+ external freeres
+
+ if(.not.dccart) call chainbuild
+cd call write_pdb(99,'sec structure',0d0)
+ ncont=0
+ nbfrag=0
+ nhfrag=0
+ do i=1,nres
+ isec(i,1)=0
+ isec(i,2)=0
+ nsec(i)=0
+ enddo
+
+ call elecont(lprint,ncont,icont)
+
+c finding parallel beta
+cd write (iout,*) '------- looking for parallel beta -----------'
+ nbeta=0
+ nstrand=0
+ do i=1,ncont
+ i1=icont(1,i)
+ j1=icont(2,i)
+ if(j1-i1.gt.5 .and. freeres(i1,j1,nsec,isec)) then
+ ii1=i1
+ jj1=j1
+cd write (iout,*) i1,j1
+ not_done=.true.
+ do while (not_done)
+ i1=i1+1
+ j1=j1+1
+ do j=1,ncont
+ if (i1.eq.icont(1,j) .and. j1.eq.icont(2,j) .and.
+ & freeres(i1,j1,nsec,isec)) goto 5
+ enddo
+ not_done=.false.
+ 5 continue
+cd write (iout,*) i1,j1,not_done
+ enddo
+ j1=j1-1
+ i1=i1-1
+ if (i1-ii1.gt.1) then
+ ii1=max0(ii1-1,1)
+ jj1=max0(jj1-1,1)
+ nbeta=nbeta+1
+ if(lprint)write(iout,'(a,i3,4i4)')'parallel beta',
+ & nbeta,ii1,i1,jj1,j1
+
+ nbfrag=nbfrag+1
+ bfrag(1,nbfrag)=ii1+1
+ bfrag(2,nbfrag)=i1+1
+ bfrag(3,nbfrag)=jj1+1
+ bfrag(4,nbfrag)=min0(j1+1,nres)
+
+ do ij=ii1,i1
+ nsec(ij)=nsec(ij)+1
+ isec(ij,nsec(ij))=nbeta
+ enddo
+ do ij=jj1,j1
+ nsec(ij)=nsec(ij)+1
+ isec(ij,nsec(ij))=nbeta
+ enddo
+
+ if(lprint) then
+ nstrand=nstrand+1
+ if (nbeta.le.9) then
+ write(12,'(a18,i1,a9,i3,a2,i3,a1)')
+ & "DefPropRes 'strand",nstrand,
+ & "' 'num = ",ii1-1,"..",i1-1,"'"
+ else
+ write(12,'(a18,i2,a9,i3,a2,i3,a1)')
+ & "DefPropRes 'strand",nstrand,
+ & "' 'num = ",ii1-1,"..",i1-1,"'"
+ endif
+ nstrand=nstrand+1
+ if (nbeta.le.9) then
+ write(12,'(a18,i1,a9,i3,a2,i3,a1)')
+ & "DefPropRes 'strand",nstrand,
+ & "' 'num = ",jj1-1,"..",j1-1,"'"
+ else
+ write(12,'(a18,i2,a9,i3,a2,i3,a1)')
+ & "DefPropRes 'strand",nstrand,
+ & "' 'num = ",jj1-1,"..",j1-1,"'"
+ endif
+ write(12,'(a8,4i4)')
+ & "SetNeigh",ii1-1,i1-1,jj1-1,j1-1
+ endif
+ endif
+ endif
+ enddo
+
+c finding alpha or 310 helix
+
+ nhelix=0
+ do i=1,ncont
+ i1=icont(1,i)
+ j1=icont(2,i)
+ p1=phi(i1+2)*rad2deg
+ p2=0.0
+ if (j1+2.le.nres) p2=phi(j1+2)*rad2deg
+
+
+ if (j1.eq.i1+3 .and.
+ & ((p1.ge.10.and.p1.le.80).or.i1.le.2).and.
+ & ((p2.ge.10.and.p2.le.80).or.j1.le.2.or.j1.ge.nres-3) )then
+cd if (j1.eq.i1+3) write (iout,*) "found 1-4 ",i1,j1,p1,p2
+co if (j1.eq.i1+4) write (iout,*) "found 1-5 ",i1,j1,p1,p2
+ ii1=i1
+ jj1=j1
+ if (nsec(ii1).eq.0) then
+ not_done=.true.
+ else
+ not_done=.false.
+ endif
+ do while (not_done)
+ i1=i1+1
+ j1=j1+1
+ do j=1,ncont
+ if (i1.eq.icont(1,j) .and. j1.eq.icont(2,j)) goto 10
+ enddo
+ not_done=.false.
+ 10 continue
+ p1=phi(i1+2)*rad2deg
+ p2=phi(j1+2)*rad2deg
+ if (p1.lt.10.or.p1.gt.80.or.p2.lt.10.or.p2.gt.80)
+ & not_done=.false.
+cd write (iout,*) i1,j1,not_done,p1,p2
+ enddo
+ j1=j1+1
+ if (j1-ii1.gt.5) then
+ nhelix=nhelix+1
+cd write (iout,*)'helix',nhelix,ii1,j1
+
+ nhfrag=nhfrag+1
+ hfrag(1,nhfrag)=ii1
+ hfrag(2,nhfrag)=j1
+
+ do ij=ii1,j1
+ nsec(ij)=-1
+ enddo
+ if (lprint) then
+ write (iout,'(a,i3,2i4)') "Helix",nhelix,ii1-1,j1-1
+ if (nhelix.le.9) then
+ write(12,'(a17,i1,a9,i3,a2,i3,a1)')
+ & "DefPropRes 'helix",nhelix,
+ & "' 'num = ",ii1-1,"..",j1-2,"'"
+ else
+ write(12,'(a17,i2,a9,i3,a2,i3,a1)')
+ & "DefPropRes 'helix",nhelix,
+ & "' 'num = ",ii1-1,"..",j1-2,"'"
+ endif
+ endif
+ endif
+ endif
+ enddo
+
+ if (nhelix.gt.0.and.lprint) then
+ write(12,'(a26,$)') "DefPropRes 'helix' 'helix1"
+ do i=2,nhelix
+ if (nhelix.le.9) then
+ write(12,'(a8,i1,$)') " | helix",i
+ else
+ write(12,'(a8,i2,$)') " | helix",i
+ endif
+ enddo
+ write(12,'(a1)') "'"
+ endif
+
+
+c finding antiparallel beta
+cd write (iout,*) '--------- looking for antiparallel beta ---------'
+
+ do i=1,ncont
+ i1=icont(1,i)
+ j1=icont(2,i)
+ if (freeres(i1,j1,nsec,isec)) then
+ ii1=i1
+ jj1=j1
+cd write (iout,*) i1,j1
+
+ not_done=.true.
+ do while (not_done)
+ i1=i1+1
+ j1=j1-1
+ do j=1,ncont
+ if (i1.eq.icont(1,j).and.j1.eq.icont(2,j) .and.
+ & freeres(i1,j1,nsec,isec)) goto 6
+ enddo
+ not_done=.false.
+ 6 continue
+cd write (iout,*) i1,j1,not_done
+ enddo
+ i1=i1-1
+ j1=j1+1
+ if (i1-ii1.gt.1) then
+
+ nbfrag=nbfrag+1
+ bfrag(1,nbfrag)=ii1
+ bfrag(2,nbfrag)=min0(i1+1,nres)
+ bfrag(3,nbfrag)=min0(jj1+1,nres)
+ bfrag(4,nbfrag)=j1
+
+ nbeta=nbeta+1
+ iii1=max0(ii1-1,1)
+ do ij=iii1,i1
+ nsec(ij)=nsec(ij)+1
+ if (nsec(ij).le.2) then
+ isec(ij,nsec(ij))=nbeta
+ endif
+ enddo
+ jjj1=max0(j1-1,1)
+ do ij=jjj1,jj1
+ nsec(ij)=nsec(ij)+1
+ if (nsec(ij).le.2 .and. nsec(ij).gt.0) then
+ isec(ij,nsec(ij))=nbeta
+ endif
+ enddo
+
+
+ if (lprint) then
+ write (iout,'(a,i3,4i4)')'antiparallel beta',
+ & nbeta,ii1-1,i1,jj1,j1-1
+ nstrand=nstrand+1
+ if (nstrand.le.9) then
+ write(12,'(a18,i1,a9,i3,a2,i3,a1)')
+ & "DefPropRes 'strand",nstrand,
+ & "' 'num = ",ii1-2,"..",i1-1,"'"
+ else
+ write(12,'(a18,i2,a9,i3,a2,i3,a1)')
+ & "DefPropRes 'strand",nstrand,
+ & "' 'num = ",ii1-2,"..",i1-1,"'"
+ endif
+ nstrand=nstrand+1
+ if (nstrand.le.9) then
+ write(12,'(a18,i1,a9,i3,a2,i3,a1)')
+ & "DefPropRes 'strand",nstrand,
+ & "' 'num = ",j1-2,"..",jj1-1,"'"
+ else
+ write(12,'(a18,i2,a9,i3,a2,i3,a1)')
+ & "DefPropRes 'strand",nstrand,
+ & "' 'num = ",j1-2,"..",jj1-1,"'"
+ endif
+ write(12,'(a8,4i4)')
+ & "SetNeigh",ii1-2,i1-1,jj1-1,j1-2
+ endif
+ endif
+ endif
+ enddo
+
+ if (nstrand.gt.0.and.lprint) then
+ write(12,'(a27,$)') "DefPropRes 'sheet' 'strand1"
+ do i=2,nstrand
+ if (i.le.9) then
+ write(12,'(a9,i1,$)') " | strand",i
+ else
+ write(12,'(a9,i2,$)') " | strand",i
+ endif
+ enddo
+ write(12,'(a1)') "'"
+ endif
+
+
+
+ if (lprint) then
+ write(12,'(a37)') "DefPropRes 'coil' '! (helix | sheet)'"
+ write(12,'(a20)') "XMacStand ribbon.mac"
+
+
+ write(iout,*) 'UNRES seq:'
+ do j=1,nbfrag
+ write(iout,*) 'beta ',(bfrag(i,j),i=1,4)
+ enddo
+
+ do j=1,nhfrag
+ write(iout,*) 'helix ',(hfrag(i,j),i=1,2)
+ enddo
+ endif
+
+ return
+ end
+c-------------------------------------------------
+ logical function freeres(i,j,nsec,isec)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ integer isec(maxres,4),nsec(maxres)
+ freeres=.false.
+
+ if (nsec(i).lt.0.or.nsec(j).lt.0) return
+ if (nsec(i).gt.1.or.nsec(j).gt.1) return
+ do k=1,nsec(i)
+ do l=1,nsec(j)
+ if (isec(i,k).eq.isec(j,l)) return
+ enddo
+ enddo
+ freeres=.true.
+ return
+ end
+
--- /dev/null
+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-----------------------------------------------------------------------
+ subroutine elj_long(evdw)
+C
+C This subroutine calculates the interaction energy of nonbonded side chains
+C assuming the LJ potential of interaction.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ 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)
+c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
+ evdw=0.0D0
+ do i=iatsc_s,iatsc_e
+ itypi=itype(i)
+ itypi1=itype(i+1)
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+C
+C Calculate SC interaction energy.
+C
+ do iint=1,nint_gr(i)
+cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
+cd & 'iend=',iend(i,iint)
+ do j=istart(i,iint),iend(i,iint)
+ itypj=itype(j)
+ xj=c(1,nres+j)-xi
+ yj=c(2,nres+j)-yi
+ zj=c(3,nres+j)-zi
+ rij=xj*xj+yj*yj+zj*zj
+ sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
+ if (sss.lt.1.0d0) then
+ rrij=1.0D0/rij
+ eps0ij=eps(itypi,itypj)
+ fac=rrij**expon2
+ e1=fac*fac*aa(itypi,itypj)
+ e2=fac*bb(itypi,itypj)
+ evdwij=e1+e2
+ evdw=evdw+(1.0d0-sss)*evdwij
+C
+C Calculate the components of the gradient in DC and X
+C
+ fac=-rrij*(e1+evdwij)*(1.0d0-sss)
+ 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)
+ gvdwc(k,i)=gvdwc(k,i)-gg(k)
+ gvdwc(k,j)=gvdwc(k,j)+gg(k)
+ enddo
+ endif
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+ do i=1,nct
+ do j=1,3
+ gvdwc(j,i)=expon*gvdwc(j,i)
+ gvdwx(j,i)=expon*gvdwx(j,i)
+ enddo
+ enddo
+C******************************************************************************
+C
+C N O T E !!!
+C
+C To save time, the factor of EXPON has been extracted from ALL components
+C of GVDWC and GRADX. Remember to multiply them by this factor before further
+C use!
+C
+C******************************************************************************
+ return
+ end
+C-----------------------------------------------------------------------
+ subroutine elj_short(evdw)
+C
+C This subroutine calculates the interaction energy of nonbonded side chains
+C assuming the LJ potential of interaction.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ 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)
+c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
+ evdw=0.0D0
+ do i=iatsc_s,iatsc_e
+ itypi=itype(i)
+ itypi1=itype(i+1)
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+C Change 12/1/95
+ num_conti=0
+C
+C Calculate SC interaction energy.
+C
+ do iint=1,nint_gr(i)
+cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
+cd & 'iend=',iend(i,iint)
+ do j=istart(i,iint),iend(i,iint)
+ itypj=itype(j)
+ xj=c(1,nres+j)-xi
+ yj=c(2,nres+j)-yi
+ zj=c(3,nres+j)-zi
+C Change 12/1/95 to calculate four-body interactions
+ rij=xj*xj+yj*yj+zj*zj
+ sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
+ if (sss.gt.0.0d0) then
+ rrij=1.0D0/rij
+ eps0ij=eps(itypi,itypj)
+ fac=rrij**expon2
+ e1=fac*fac*aa(itypi,itypj)
+ e2=fac*bb(itypi,itypj)
+ evdwij=e1+e2
+ evdw=evdw+sss*evdwij
+C
+C Calculate the components of the gradient in DC and X
+C
+ fac=-rrij*(e1+evdwij)*sss
+ 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)
+ gvdwc(k,i)=gvdwc(k,i)-gg(k)
+ gvdwc(k,j)=gvdwc(k,j)+gg(k)
+ enddo
+ endif
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+ do i=1,nct
+ do j=1,3
+ gvdwc(j,i)=expon*gvdwc(j,i)
+ gvdwx(j,i)=expon*gvdwx(j,i)
+ enddo
+ enddo
+C******************************************************************************
+C
+C N O T E !!!
+C
+C To save time, the factor of EXPON has been extracted from ALL components
+C of GVDWC and GRADX. Remember to multiply them by this factor before further
+C use!
+C
+C******************************************************************************
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine eljk_long(evdw)
+C
+C This subroutine calculates the interaction energy of nonbonded side chains
+C assuming the LJK potential of interaction.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ dimension gg(3)
+ logical scheck
+c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
+ evdw=0.0D0
+ do i=iatsc_s,iatsc_e
+ itypi=itype(i)
+ itypi1=itype(i+1)
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+C
+C Calculate SC interaction energy.
+C
+ do iint=1,nint_gr(i)
+ do j=istart(i,iint),iend(i,iint)
+ itypj=itype(j)
+ xj=c(1,nres+j)-xi
+ yj=c(2,nres+j)-yi
+ zj=c(3,nres+j)-zi
+ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
+ fac_augm=rrij**expon
+ e_augm=augm(itypi,itypj)*fac_augm
+ r_inv_ij=dsqrt(rrij)
+ rij=1.0D0/r_inv_ij
+ sss=sscale(rij/sigma(itypi,itypj))
+ if (sss.lt.1.0d0) then
+ r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
+ fac=r_shift_inv**expon
+ e1=fac*fac*aa(itypi,itypj)
+ e2=fac*bb(itypi,itypj)
+ evdwij=e_augm+e1+e2
+cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
+cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
+cd write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
+cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
+cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
+cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
+cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
+ evdw=evdw+(1.0d0-sss)*evdwij
+C
+C Calculate the components of the gradient in DC and X
+C
+ fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
+ fac=fac*(1.0d0-sss)
+ 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)
+ gvdwc(k,i)=gvdwc(k,i)-gg(k)
+ gvdwc(k,j)=gvdwc(k,j)+gg(k)
+ enddo
+ endif
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+ do i=1,nct
+ do j=1,3
+ gvdwc(j,i)=expon*gvdwc(j,i)
+ gvdwx(j,i)=expon*gvdwx(j,i)
+ enddo
+ enddo
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine eljk_short(evdw)
+C
+C This subroutine calculates the interaction energy of nonbonded side chains
+C assuming the LJK potential of interaction.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ dimension gg(3)
+ logical scheck
+c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
+ evdw=0.0D0
+ do i=iatsc_s,iatsc_e
+ itypi=itype(i)
+ itypi1=itype(i+1)
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+C
+C Calculate SC interaction energy.
+C
+ do iint=1,nint_gr(i)
+ do j=istart(i,iint),iend(i,iint)
+ itypj=itype(j)
+ xj=c(1,nres+j)-xi
+ yj=c(2,nres+j)-yi
+ zj=c(3,nres+j)-zi
+ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
+ fac_augm=rrij**expon
+ e_augm=augm(itypi,itypj)*fac_augm
+ r_inv_ij=dsqrt(rrij)
+ rij=1.0D0/r_inv_ij
+ sss=sscale(rij/sigma(itypi,itypj))
+ if (sss.gt.0.0d0) then
+ r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
+ fac=r_shift_inv**expon
+ e1=fac*fac*aa(itypi,itypj)
+ e2=fac*bb(itypi,itypj)
+ evdwij=e_augm+e1+e2
+cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
+cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
+cd write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
+cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
+cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
+cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
+cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
+ evdw=evdw+sss*evdwij
+C
+C Calculate the components of the gradient in DC and X
+C
+ fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
+ fac=fac*sss
+ 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)
+ gvdwc(k,i)=gvdwc(k,i)-gg(k)
+ gvdwc(k,j)=gvdwc(k,j)+gg(k)
+ enddo
+ endif
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+ do i=1,nct
+ do j=1,3
+ gvdwc(j,i)=expon*gvdwc(j,i)
+ gvdwx(j,i)=expon*gvdwx(j,i)
+ enddo
+ enddo
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine ebp_long(evdw)
+C
+C This subroutine calculates the interaction energy of nonbonded side chains
+C assuming the Berne-Pechukas potential of interaction.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.NAMES'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CALC'
+ common /srutu/ icall
+c double precision rrsave(maxdim)
+ logical lprn
+ evdw=0.0D0
+c print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
+ evdw=0.0D0
+c if (icall.eq.0) then
+c lprn=.true.
+c else
+ lprn=.false.
+c endif
+ ind=0
+ do i=iatsc_s,iatsc_e
+ itypi=itype(i)
+ itypi1=itype(i+1)
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+ dxi=dc_norm(1,nres+i)
+ dyi=dc_norm(2,nres+i)
+ dzi=dc_norm(3,nres+i)
+c dsci_inv=dsc_inv(itypi)
+ dsci_inv=vbld_inv(i+nres)
+C
+C Calculate SC interaction energy.
+C
+ do iint=1,nint_gr(i)
+ do j=istart(i,iint),iend(i,iint)
+ ind=ind+1
+ itypj=itype(j)
+c dscj_inv=dsc_inv(itypj)
+ 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)
+ 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)
+ sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
+
+ if (sss.lt.1.0d0) then
+
+C Calculate the angle-dependent terms of energy & contributions to derivatives.
+ call sc_angular
+C Calculate whole angle-dependent part of epsilon and contributions
+C to its derivatives
+ fac=(rrij*sigsq)**expon2
+ e1=fac*fac*aa(itypi,itypj)
+ e2=fac*bb(itypi,itypj)
+ evdwij=eps1*eps2rt*eps3rt*(e1+e2)
+ eps2der=evdwij*eps3rt
+ eps3der=evdwij*eps2rt
+ evdwij=evdwij*eps2rt*eps3rt
+ evdw=evdw+evdwij*(1.0d0-sss)
+ if (lprn) then
+ sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
+ epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
+cd write (iout,'(2(a3,i3,2x),15(0pf7.3))')
+cd & restyp(itypi),i,restyp(itypj),j,
+cd & epsi,sigm,chi1,chi2,chip1,chip2,
+cd & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
+cd & om1,om2,om12,1.0D0/dsqrt(rrij),
+cd & evdwij
+ endif
+C Calculate gradient components.
+ e1=e1*eps1*eps2rt**2*eps3rt**2
+ fac=-expon*(e1+evdwij)
+ sigder=fac/sigsq
+ fac=rrij*fac
+C Calculate radial part of the gradient
+ gg(1)=xj*fac
+ gg(2)=yj*fac
+ gg(3)=zj*fac
+C Calculate the angular part of the gradient and sum add the contributions
+C to the appropriate components of the Cartesian gradient.
+ call sc_grad_scale(1.0d0-sss)
+ endif
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+c stop
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine ebp_short(evdw)
+C
+C This subroutine calculates the interaction energy of nonbonded side chains
+C assuming the Berne-Pechukas potential of interaction.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.NAMES'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CALC'
+ common /srutu/ icall
+c double precision rrsave(maxdim)
+ logical lprn
+ evdw=0.0D0
+c print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
+ evdw=0.0D0
+c if (icall.eq.0) then
+c lprn=.true.
+c else
+ lprn=.false.
+c endif
+ ind=0
+ do i=iatsc_s,iatsc_e
+ itypi=itype(i)
+ itypi1=itype(i+1)
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+ dxi=dc_norm(1,nres+i)
+ dyi=dc_norm(2,nres+i)
+ dzi=dc_norm(3,nres+i)
+c dsci_inv=dsc_inv(itypi)
+ dsci_inv=vbld_inv(i+nres)
+C
+C Calculate SC interaction energy.
+C
+ do iint=1,nint_gr(i)
+ do j=istart(i,iint),iend(i,iint)
+ ind=ind+1
+ itypj=itype(j)
+c dscj_inv=dsc_inv(itypj)
+ 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)
+ 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)
+ sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
+
+ if (sss.gt.0.0d0) then
+
+C Calculate the angle-dependent terms of energy & contributions to derivatives.
+ call sc_angular
+C Calculate whole angle-dependent part of epsilon and contributions
+C to its derivatives
+ fac=(rrij*sigsq)**expon2
+ e1=fac*fac*aa(itypi,itypj)
+ e2=fac*bb(itypi,itypj)
+ evdwij=eps1*eps2rt*eps3rt*(e1+e2)
+ eps2der=evdwij*eps3rt
+ eps3der=evdwij*eps2rt
+ evdwij=evdwij*eps2rt*eps3rt
+ evdw=evdw+evdwij*sss
+ if (lprn) then
+ sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
+ epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
+cd write (iout,'(2(a3,i3,2x),15(0pf7.3))')
+cd & restyp(itypi),i,restyp(itypj),j,
+cd & epsi,sigm,chi1,chi2,chip1,chip2,
+cd & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
+cd & om1,om2,om12,1.0D0/dsqrt(rrij),
+cd & evdwij
+ endif
+C Calculate gradient components.
+ e1=e1*eps1*eps2rt**2*eps3rt**2
+ fac=-expon*(e1+evdwij)
+ sigder=fac/sigsq
+ fac=rrij*fac
+C Calculate radial part of the gradient
+ gg(1)=xj*fac
+ gg(2)=yj*fac
+ gg(3)=zj*fac
+C Calculate the angular part of the gradient and sum add the contributions
+C to the appropriate components of the Cartesian gradient.
+ call sc_grad_scale(sss)
+ endif
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+c stop
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine egb_long(evdw,evdw_p,evdw_m)
+C
+C This subroutine calculates the interaction energy of nonbonded side chains
+C assuming the Gay-Berne potential of interaction.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.NAMES'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CALC'
+ include 'COMMON.CONTROL'
+ logical lprn
+ccccc energy_dec=.false.
+c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
+ evdw=0.0D0
+ evdw_p=0.0D0
+ evdw_m=0.0D0
+ lprn=.false.
+c if (icall.eq.0) lprn=.false.
+ ind=0
+ do i=iatsc_s,iatsc_e
+ itypi=itype(i)
+ itypi1=itype(i+1)
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+ dxi=dc_norm(1,nres+i)
+ dyi=dc_norm(2,nres+i)
+ dzi=dc_norm(3,nres+i)
+c dsci_inv=dsc_inv(itypi)
+ dsci_inv=vbld_inv(i+nres)
+c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
+c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
+C
+C Calculate SC interaction energy.
+C
+ do iint=1,nint_gr(i)
+ do j=istart(i,iint),iend(i,iint)
+ ind=ind+1
+ itypj=itype(j)
+c dscj_inv=dsc_inv(itypj)
+ dscj_inv=vbld_inv(j+nres)
+c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
+c & 1.0d0/vbld(j+nres)
+c write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
+ sig0ij=sigma(itypi,itypj)
+ chi1=chi(itypi,itypj)
+ chi2=chi(itypj,itypi)
+ chi12=chi1*chi2
+ chip1=chip(itypi)
+ chip2=chip(itypj)
+ chip12=chip1*chip2
+ alf1=alp(itypi)
+ alf2=alp(itypj)
+ alf12=0.5D0*(alf1+alf2)
+ 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)
+ sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
+
+ if (sss.lt.1.0d0) then
+
+C Calculate angle-dependent terms of energy and contributions to their
+C derivatives.
+ call sc_angular
+ sigsq=1.0D0/sigsq
+ sig=sig0ij*dsqrt(sigsq)
+ rij_shift=1.0D0/rij-sig+sig0ij
+c for diagnostics; uncomment
+c rij_shift=1.2*sig0ij
+C I hate to put IF's in the loops, but here don't have another choice!!!!
+ if (rij_shift.le.0.0D0) then
+ evdw=1.0D20
+cd write (iout,'(2(a3,i3,2x),17(0pf7.3))')
+cd & restyp(itypi),i,restyp(itypj),j,
+cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
+ return
+ endif
+ sigder=-sig*sigsq
+c---------------------------------------------------------------
+ rij_shift=1.0D0/rij_shift
+ fac=rij_shift**expon
+ e1=fac*fac*aa(itypi,itypj)
+ e2=fac*bb(itypi,itypj)
+ evdwij=eps1*eps2rt*eps3rt*(e1+e2)
+ eps2der=evdwij*eps3rt
+ eps3der=evdwij*eps2rt
+c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
+c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
+ evdwij=evdwij*eps2rt*eps3rt
+#ifdef TSCSC
+ if (bb(itypi,itypj).gt.0) then
+ evdw_p=evdw_p+evdwij*(1.0d0-sss)
+ else
+ evdw_m=evdw_m+evdwij*(1.0d0-sss)
+ endif
+#else
+ evdw=evdw+evdwij*(1.0d0-sss)
+#endif
+ if (lprn) then
+ sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
+ epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
+ write (iout,'(2(a3,i3,2x),17(0pf7.3))')
+ & restyp(itypi),i,restyp(itypj),j,
+ & epsi,sigm,chi1,chi2,chip1,chip2,
+ & eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
+ & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
+ & evdwij
+ endif
+
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
+ & 'evdw',i,j,evdwij
+
+C Calculate gradient components.
+ e1=e1*eps1*eps2rt**2*eps3rt**2
+ fac=-expon*(e1+evdwij)*rij_shift
+ sigder=fac*sigder
+ fac=rij*fac
+c fac=0.0d0
+C Calculate the radial part of the gradient
+ gg(1)=xj*fac
+ gg(2)=yj*fac
+ gg(3)=zj*fac
+C Calculate angular part of the gradient.
+#ifdef TSCSC
+ if (bb(itypi,itypj).gt.0) then
+ call sc_grad_scale_T(1.0d0-sss)
+ else
+ call sc_grad_scale(1.0d0-sss)
+ endif
+#else
+ call sc_grad_scale(1.0d0-sss)
+#endif
+ endif
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+c write (iout,*) "Number of loop steps in EGB:",ind
+cccc energy_dec=.false.
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine egb_short(evdw,evdw_p,evdw_m)
+C
+C This subroutine calculates the interaction energy of nonbonded side chains
+C assuming the Gay-Berne potential of interaction.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.NAMES'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CALC'
+ include 'COMMON.CONTROL'
+ logical lprn
+ evdw=0.0D0
+ evdw_p=0.0D0
+ evdw_m=0.0D0
+ccccc energy_dec=.false.
+c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
+ evdw=0.0D0
+ lprn=.false.
+c if (icall.eq.0) lprn=.false.
+ ind=0
+ do i=iatsc_s,iatsc_e
+ itypi=itype(i)
+ itypi1=itype(i+1)
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+ dxi=dc_norm(1,nres+i)
+ dyi=dc_norm(2,nres+i)
+ dzi=dc_norm(3,nres+i)
+c dsci_inv=dsc_inv(itypi)
+ dsci_inv=vbld_inv(i+nres)
+c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
+c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
+C
+C Calculate SC interaction energy.
+C
+ do iint=1,nint_gr(i)
+ do j=istart(i,iint),iend(i,iint)
+ ind=ind+1
+ itypj=itype(j)
+c dscj_inv=dsc_inv(itypj)
+ dscj_inv=vbld_inv(j+nres)
+c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
+c & 1.0d0/vbld(j+nres)
+c write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
+ sig0ij=sigma(itypi,itypj)
+ chi1=chi(itypi,itypj)
+ chi2=chi(itypj,itypi)
+ chi12=chi1*chi2
+ chip1=chip(itypi)
+ chip2=chip(itypj)
+ chip12=chip1*chip2
+ alf1=alp(itypi)
+ alf2=alp(itypj)
+ alf12=0.5D0*(alf1+alf2)
+ 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)
+ sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
+
+ if (sss.gt.0.0d0) then
+
+C Calculate angle-dependent terms of energy and contributions to their
+C derivatives.
+ call sc_angular
+ sigsq=1.0D0/sigsq
+ sig=sig0ij*dsqrt(sigsq)
+ rij_shift=1.0D0/rij-sig+sig0ij
+c for diagnostics; uncomment
+c rij_shift=1.2*sig0ij
+C I hate to put IF's in the loops, but here don't have another choice!!!!
+ if (rij_shift.le.0.0D0) then
+ evdw=1.0D20
+cd write (iout,'(2(a3,i3,2x),17(0pf7.3))')
+cd & restyp(itypi),i,restyp(itypj),j,
+cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
+ return
+ endif
+ sigder=-sig*sigsq
+c---------------------------------------------------------------
+ rij_shift=1.0D0/rij_shift
+ fac=rij_shift**expon
+ e1=fac*fac*aa(itypi,itypj)
+ e2=fac*bb(itypi,itypj)
+ evdwij=eps1*eps2rt*eps3rt*(e1+e2)
+ eps2der=evdwij*eps3rt
+ eps3der=evdwij*eps2rt
+c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
+c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
+ evdwij=evdwij*eps2rt*eps3rt
+#ifdef TSCSC
+ if (bb(itypi,itypj).gt.0) then
+ evdw_p=evdw_p+evdwij*sss
+ else
+ evdw_m=evdw_m+evdwij*sss
+ endif
+#else
+ evdw=evdw+evdwij*sss
+#endif
+ if (lprn) then
+ sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
+ epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
+ write (iout,'(2(a3,i3,2x),17(0pf7.3))')
+ & restyp(itypi),i,restyp(itypj),j,
+ & epsi,sigm,chi1,chi2,chip1,chip2,
+ & eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
+ & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
+ & evdwij
+ endif
+
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
+ & 'evdw',i,j,evdwij
+
+C Calculate gradient components.
+ e1=e1*eps1*eps2rt**2*eps3rt**2
+ fac=-expon*(e1+evdwij)*rij_shift
+ sigder=fac*sigder
+ fac=rij*fac
+c fac=0.0d0
+C Calculate the radial part of the gradient
+ gg(1)=xj*fac
+ gg(2)=yj*fac
+ gg(3)=zj*fac
+C Calculate angular part of the gradient.
+#ifdef TSCSC
+ if (bb(itypi,itypj).gt.0) then
+ call sc_grad_scale_T(sss)
+ else
+ call sc_grad_scale(sss)
+ endif
+#else
+ call sc_grad_scale(sss)
+#endif
+ endif
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+c write (iout,*) "Number of loop steps in EGB:",ind
+cccc energy_dec=.false.
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine egbv_long(evdw)
+C
+C This subroutine calculates the interaction energy of nonbonded side chains
+C assuming the Gay-Berne-Vorobjev potential of interaction.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.NAMES'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CALC'
+ common /srutu/ icall
+ logical lprn
+ evdw=0.0D0
+c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
+ evdw=0.0D0
+ lprn=.false.
+c if (icall.eq.0) lprn=.true.
+ ind=0
+ do i=iatsc_s,iatsc_e
+ itypi=itype(i)
+ itypi1=itype(i+1)
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+ dxi=dc_norm(1,nres+i)
+ dyi=dc_norm(2,nres+i)
+ dzi=dc_norm(3,nres+i)
+c dsci_inv=dsc_inv(itypi)
+ dsci_inv=vbld_inv(i+nres)
+C
+C Calculate SC interaction energy.
+C
+ do iint=1,nint_gr(i)
+ do j=istart(i,iint),iend(i,iint)
+ ind=ind+1
+ itypj=itype(j)
+c dscj_inv=dsc_inv(itypj)
+ dscj_inv=vbld_inv(j+nres)
+ sig0ij=sigma(itypi,itypj)
+ r0ij=r0(itypi,itypj)
+ chi1=chi(itypi,itypj)
+ chi2=chi(itypj,itypi)
+ chi12=chi1*chi2
+ chip1=chip(itypi)
+ chip2=chip(itypj)
+ chip12=chip1*chip2
+ alf1=alp(itypi)
+ alf2=alp(itypj)
+ alf12=0.5D0*(alf1+alf2)
+ 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)
+
+ sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
+
+ if (sss.lt.1.0d0) then
+
+C Calculate angle-dependent terms of energy and contributions to their
+C derivatives.
+ call sc_angular
+ sigsq=1.0D0/sigsq
+ sig=sig0ij*dsqrt(sigsq)
+ rij_shift=1.0D0/rij-sig+r0ij
+C I hate to put IF's in the loops, but here don't have another choice!!!!
+ if (rij_shift.le.0.0D0) then
+ evdw=1.0D20
+ return
+ endif
+ sigder=-sig*sigsq
+c---------------------------------------------------------------
+ rij_shift=1.0D0/rij_shift
+ fac=rij_shift**expon
+ e1=fac*fac*aa(itypi,itypj)
+ e2=fac*bb(itypi,itypj)
+ evdwij=eps1*eps2rt*eps3rt*(e1+e2)
+ eps2der=evdwij*eps3rt
+ eps3der=evdwij*eps2rt
+ fac_augm=rrij**expon
+ e_augm=augm(itypi,itypj)*fac_augm
+ evdwij=evdwij*eps2rt*eps3rt
+ evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
+ if (lprn) then
+ sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
+ epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
+ write (iout,'(2(a3,i3,2x),17(0pf7.3))')
+ & restyp(itypi),i,restyp(itypj),j,
+ & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
+ & chi1,chi2,chip1,chip2,
+ & eps1,eps2rt**2,eps3rt**2,
+ & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
+ & evdwij+e_augm
+ endif
+C Calculate gradient components.
+ e1=e1*eps1*eps2rt**2*eps3rt**2
+ fac=-expon*(e1+evdwij)*rij_shift
+ sigder=fac*sigder
+ fac=rij*fac-2*expon*rrij*e_augm
+C Calculate the radial part of the gradient
+ gg(1)=xj*fac
+ gg(2)=yj*fac
+ gg(3)=zj*fac
+C Calculate angular part of the gradient.
+ call sc_grad_scale(1.0d0-sss)
+ endif
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+ end
+C-----------------------------------------------------------------------------
+ subroutine egbv_short(evdw)
+C
+C This subroutine calculates the interaction energy of nonbonded side chains
+C assuming the Gay-Berne-Vorobjev potential of interaction.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.NAMES'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CALC'
+ common /srutu/ icall
+ logical lprn
+ evdw=0.0D0
+c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
+ evdw=0.0D0
+ lprn=.false.
+c if (icall.eq.0) lprn=.true.
+ ind=0
+ do i=iatsc_s,iatsc_e
+ itypi=itype(i)
+ itypi1=itype(i+1)
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+ dxi=dc_norm(1,nres+i)
+ dyi=dc_norm(2,nres+i)
+ dzi=dc_norm(3,nres+i)
+c dsci_inv=dsc_inv(itypi)
+ dsci_inv=vbld_inv(i+nres)
+C
+C Calculate SC interaction energy.
+C
+ do iint=1,nint_gr(i)
+ do j=istart(i,iint),iend(i,iint)
+ ind=ind+1
+ itypj=itype(j)
+c dscj_inv=dsc_inv(itypj)
+ dscj_inv=vbld_inv(j+nres)
+ sig0ij=sigma(itypi,itypj)
+ r0ij=r0(itypi,itypj)
+ chi1=chi(itypi,itypj)
+ chi2=chi(itypj,itypi)
+ chi12=chi1*chi2
+ chip1=chip(itypi)
+ chip2=chip(itypj)
+ chip12=chip1*chip2
+ alf1=alp(itypi)
+ alf2=alp(itypj)
+ alf12=0.5D0*(alf1+alf2)
+ 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)
+
+ sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
+
+ if (sss.gt.0.0d0) then
+
+C Calculate angle-dependent terms of energy and contributions to their
+C derivatives.
+ call sc_angular
+ sigsq=1.0D0/sigsq
+ sig=sig0ij*dsqrt(sigsq)
+ rij_shift=1.0D0/rij-sig+r0ij
+C I hate to put IF's in the loops, but here don't have another choice!!!!
+ if (rij_shift.le.0.0D0) then
+ evdw=1.0D20
+ return
+ endif
+ sigder=-sig*sigsq
+c---------------------------------------------------------------
+ rij_shift=1.0D0/rij_shift
+ fac=rij_shift**expon
+ e1=fac*fac*aa(itypi,itypj)
+ e2=fac*bb(itypi,itypj)
+ evdwij=eps1*eps2rt*eps3rt*(e1+e2)
+ eps2der=evdwij*eps3rt
+ eps3der=evdwij*eps2rt
+ fac_augm=rrij**expon
+ e_augm=augm(itypi,itypj)*fac_augm
+ evdwij=evdwij*eps2rt*eps3rt
+ evdw=evdw+(evdwij+e_augm)*sss
+ if (lprn) then
+ sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
+ epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
+ write (iout,'(2(a3,i3,2x),17(0pf7.3))')
+ & restyp(itypi),i,restyp(itypj),j,
+ & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
+ & chi1,chi2,chip1,chip2,
+ & eps1,eps2rt**2,eps3rt**2,
+ & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
+ & evdwij+e_augm
+ endif
+C Calculate gradient components.
+ e1=e1*eps1*eps2rt**2*eps3rt**2
+ fac=-expon*(e1+evdwij)*rij_shift
+ sigder=fac*sigder
+ fac=rij*fac-2*expon*rrij*e_augm
+C Calculate the radial part of the gradient
+ gg(1)=xj*fac
+ gg(2)=yj*fac
+ gg(3)=zj*fac
+C Calculate angular part of the gradient.
+ call sc_grad_scale(sss)
+ endif
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+ end
+C----------------------------------------------------------------------------
+ subroutine sc_grad_scale(scalfac)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.CALC'
+ include 'COMMON.IOUNITS'
+ double precision dcosom1(3),dcosom2(3)
+ double precision scalfac
+ eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
+ eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
+ eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
+ & -2.0D0*alf12*eps3der+sigder*sigsq_om12
+c diagnostics only
+c eom1=0.0d0
+c eom2=0.0d0
+c eom12=evdwij*eps1_om12
+c end diagnostics
+c write (iout,*) "eps2der",eps2der," eps3der",eps3der,
+c & " sigder",sigder
+c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
+c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
+ do k=1,3
+ dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
+ dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
+ enddo
+ do k=1,3
+ gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac
+ enddo
+c write (iout,*) "gg",(gg(k),k=1,3)
+ 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*scalfac
+ 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*scalfac
+c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
+c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
+c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
+c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
+ enddo
+C
+C Calculate the components of the gradient in DC and X
+C
+ do l=1,3
+ gvdwc(l,i)=gvdwc(l,i)-gg(l)
+ gvdwc(l,j)=gvdwc(l,j)+gg(l)
+ enddo
+ return
+ end
+C----------------------------------------------------------------------------
+ subroutine sc_grad_scale_T(scalfac)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.CALC'
+ include 'COMMON.IOUNITS'
+ double precision dcosom1(3),dcosom2(3)
+ double precision scalfac
+ eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
+ eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
+ eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
+ & -2.0D0*alf12*eps3der+sigder*sigsq_om12
+c diagnostics only
+c eom1=0.0d0
+c eom2=0.0d0
+c eom12=evdwij*eps1_om12
+c end diagnostics
+c write (iout,*) "eps2der",eps2der," eps3der",eps3der,
+c & " sigder",sigder
+c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
+c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
+ do k=1,3
+ dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
+ dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
+ enddo
+ do k=1,3
+ gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac
+ enddo
+c write (iout,*) "gg",(gg(k),k=1,3)
+ do k=1,3
+ gvdwxT(k,i)=gvdwxT(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*scalfac
+ gvdwxT(k,j)=gvdwxT(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*scalfac
+c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
+c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
+c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
+c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
+ enddo
+C
+C Calculate the components of the gradient in DC and X
+C
+ do l=1,3
+ gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
+ gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
+ enddo
+ return
+ end
+
+C--------------------------------------------------------------------------
+ subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
+C
+C This subroutine calculates the average interaction energy and its gradient
+C in the virtual-bond vectors between non-adjacent peptide groups, based on
+C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
+C The potential depends both on the distance of peptide-group centers and on
+C the orientation of the CA-CA virtual bonds.
+C
+ implicit real*8 (a-h,o-z)
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.SETUP'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.TORSION'
+ include 'COMMON.VECTORS'
+ include 'COMMON.FFIELD'
+ include 'COMMON.TIME1'
+ dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
+ & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
+ double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
+ & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
+ common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
+ & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
+ & num_conti,j1,j2
+c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
+#ifdef MOMENT
+ double precision scal_el /1.0d0/
+#else
+ double precision scal_el /0.5d0/
+#endif
+C 12/13/98
+C 13-go grudnia roku pamietnego...
+ double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
+ & 0.0d0,1.0d0,0.0d0,
+ & 0.0d0,0.0d0,1.0d0/
+cd write(iout,*) 'In EELEC'
+cd do i=1,nloctyp
+cd write(iout,*) 'Type',i
+cd write(iout,*) 'B1',B1(:,i)
+cd write(iout,*) 'B2',B2(:,i)
+cd write(iout,*) 'CC',CC(:,:,i)
+cd write(iout,*) 'DD',DD(:,:,i)
+cd write(iout,*) 'EE',EE(:,:,i)
+cd enddo
+cd call check_vecgrad
+cd stop
+ if (icheckgrad.eq.1) then
+ do i=1,nres-1
+ fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
+ do k=1,3
+ dc_norm(k,i)=dc(k,i)*fac
+ enddo
+c write (iout,*) 'i',i,' fac',fac
+ enddo
+ endif
+ if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
+ & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
+ & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
+c call vec_and_deriv
+#ifdef TIMING
+ time01=MPI_Wtime()
+#endif
+ call set_matrices
+#ifdef TIMING
+ time_mat=time_mat+MPI_Wtime()-time01
+#endif
+ endif
+cd do i=1,nres-1
+cd write (iout,*) 'i=',i
+cd do k=1,3
+cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
+cd enddo
+cd do k=1,3
+cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
+cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
+cd enddo
+cd enddo
+ t_eelecij=0.0d0
+ ees=0.0D0
+ evdw1=0.0D0
+ eel_loc=0.0d0
+ eello_turn3=0.0d0
+ eello_turn4=0.0d0
+ ind=0
+ do i=1,nres
+ num_cont_hb(i)=0
+ enddo
+cd print '(a)','Enter EELEC'
+cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
+ do i=1,nres
+ gel_loc_loc(i)=0.0d0
+ gcorr_loc(i)=0.0d0
+ enddo
+c
+c
+c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
+C
+C Loop over i,i+2 and i,i+3 pairs of the peptide groups
+C
+ do i=iturn3_start,iturn3_end
+ dxi=dc(1,i)
+ dyi=dc(2,i)
+ dzi=dc(3,i)
+ dx_normi=dc_norm(1,i)
+ dy_normi=dc_norm(2,i)
+ dz_normi=dc_norm(3,i)
+ xmedi=c(1,i)+0.5d0*dxi
+ ymedi=c(2,i)+0.5d0*dyi
+ zmedi=c(3,i)+0.5d0*dzi
+ num_conti=0
+ call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
+ if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
+ num_cont_hb(i)=num_conti
+ enddo
+ do i=iturn4_start,iturn4_end
+ dxi=dc(1,i)
+ dyi=dc(2,i)
+ dzi=dc(3,i)
+ dx_normi=dc_norm(1,i)
+ dy_normi=dc_norm(2,i)
+ dz_normi=dc_norm(3,i)
+ xmedi=c(1,i)+0.5d0*dxi
+ ymedi=c(2,i)+0.5d0*dyi
+ zmedi=c(3,i)+0.5d0*dzi
+ num_conti=num_cont_hb(i)
+ call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
+ if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
+ num_cont_hb(i)=num_conti
+ enddo ! i
+c
+c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
+c
+ do i=iatel_s,iatel_e
+ dxi=dc(1,i)
+ dyi=dc(2,i)
+ dzi=dc(3,i)
+ dx_normi=dc_norm(1,i)
+ dy_normi=dc_norm(2,i)
+ dz_normi=dc_norm(3,i)
+ xmedi=c(1,i)+0.5d0*dxi
+ ymedi=c(2,i)+0.5d0*dyi
+ zmedi=c(3,i)+0.5d0*dzi
+c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
+ num_conti=num_cont_hb(i)
+ do j=ielstart(i),ielend(i)
+ call eelecij_scale(i,j,ees,evdw1,eel_loc)
+ enddo ! j
+ num_cont_hb(i)=num_conti
+ enddo ! i
+c write (iout,*) "Number of loop steps in EELEC:",ind
+cd do i=1,nres
+cd write (iout,'(i3,3f10.5,5x,3f10.5)')
+cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
+cd enddo
+c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
+ccc eel_loc=eel_loc+eello_turn3
+cd print *,"Processor",fg_rank," t_eelecij",t_eelecij
+ return
+ end
+C-------------------------------------------------------------------------------
+ subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include "mpif.h"
+#endif
+ include 'COMMON.CONTROL'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.TORSION'
+ include 'COMMON.VECTORS'
+ include 'COMMON.FFIELD'
+ include 'COMMON.TIME1'
+ dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
+ & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
+ double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
+ & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
+ common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
+ & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
+ & num_conti,j1,j2
+c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
+#ifdef MOMENT
+ double precision scal_el /1.0d0/
+#else
+ double precision scal_el /0.5d0/
+#endif
+C 12/13/98
+C 13-go grudnia roku pamietnego...
+ double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
+ & 0.0d0,1.0d0,0.0d0,
+ & 0.0d0,0.0d0,1.0d0/
+c time00=MPI_Wtime()
+cd write (iout,*) "eelecij",i,j
+ ind=ind+1
+ iteli=itel(i)
+ itelj=itel(j)
+ if (j.eq.i+2 .and. itelj.eq.2) iteli=2
+ aaa=app(iteli,itelj)
+ bbb=bpp(iteli,itelj)
+ ael6i=ael6(iteli,itelj)
+ ael3i=ael3(iteli,itelj)
+ dxj=dc(1,j)
+ dyj=dc(2,j)
+ dzj=dc(3,j)
+ dx_normj=dc_norm(1,j)
+ dy_normj=dc_norm(2,j)
+ dz_normj=dc_norm(3,j)
+ xj=c(1,j)+0.5D0*dxj-xmedi
+ yj=c(2,j)+0.5D0*dyj-ymedi
+ zj=c(3,j)+0.5D0*dzj-zmedi
+ rij=xj*xj+yj*yj+zj*zj
+ rrmij=1.0D0/rij
+ rij=dsqrt(rij)
+ rmij=1.0D0/rij
+c For extracting the short-range part of Evdwpp
+ sss=sscale(rij/rpp(iteli,itelj))
+
+ r3ij=rrmij*rmij
+ r6ij=r3ij*r3ij
+ cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
+ cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
+ cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
+ fac=cosa-3.0D0*cosb*cosg
+ ev1=aaa*r6ij*r6ij
+c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
+ if (j.eq.i+2) ev1=scal_el*ev1
+ ev2=bbb*r6ij
+ fac3=ael6i*r6ij
+ fac4=ael3i*r3ij
+ evdwij=ev1+ev2
+ el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
+ el2=fac4*fac
+ eesij=el1+el2
+C 12/26/95 - for the evaluation of multi-body H-bonding interactions
+ ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
+ ees=ees+eesij
+ evdw1=evdw1+evdwij*(1.0d0-sss)
+cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
+cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
+cd & 1.0D0/dsqrt(rrmij),evdwij,eesij,
+cd & xmedi,ymedi,zmedi,xj,yj,zj
+
+ if (energy_dec) then
+ write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
+ write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
+ endif
+
+C
+C Calculate contributions to the Cartesian gradient.
+C
+#ifdef SPLITELE
+ facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)
+ facel=-3*rrmij*(el1+eesij)
+ fac1=fac
+ erij(1)=xj*rmij
+ erij(2)=yj*rmij
+ erij(3)=zj*rmij
+*
+* Radial derivatives. First process both termini of the fragment (i,j)
+*
+ ggg(1)=facel*xj
+ ggg(2)=facel*yj
+ ggg(3)=facel*zj
+c do k=1,3
+c ghalf=0.5D0*ggg(k)
+c gelc(k,i)=gelc(k,i)+ghalf
+c gelc(k,j)=gelc(k,j)+ghalf
+c enddo
+c 9/28/08 AL Gradient compotents will be summed only at the end
+ do k=1,3
+ gelc_long(k,j)=gelc_long(k,j)+ggg(k)
+ gelc_long(k,i)=gelc_long(k,i)-ggg(k)
+ enddo
+*
+* Loop over residues i+1 thru j-1.
+*
+cgrad do k=i+1,j-1
+cgrad do l=1,3
+cgrad gelc(l,k)=gelc(l,k)+ggg(l)
+cgrad enddo
+cgrad enddo
+ ggg(1)=facvdw*xj
+ ggg(2)=facvdw*yj
+ ggg(3)=facvdw*zj
+c do k=1,3
+c ghalf=0.5D0*ggg(k)
+c gvdwpp(k,i)=gvdwpp(k,i)+ghalf
+c gvdwpp(k,j)=gvdwpp(k,j)+ghalf
+c enddo
+c 9/28/08 AL Gradient compotents will be summed only at the end
+ do k=1,3
+ gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
+ gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
+ enddo
+*
+* Loop over residues i+1 thru j-1.
+*
+cgrad do k=i+1,j-1
+cgrad do l=1,3
+cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
+cgrad enddo
+cgrad enddo
+#else
+ facvdw=ev1+evdwij*(1.0d0-sss)
+ facel=el1+eesij
+ fac1=fac
+ fac=-3*rrmij*(facvdw+facvdw+facel)
+ erij(1)=xj*rmij
+ erij(2)=yj*rmij
+ erij(3)=zj*rmij
+*
+* Radial derivatives. First process both termini of the fragment (i,j)
+*
+ ggg(1)=fac*xj
+ ggg(2)=fac*yj
+ ggg(3)=fac*zj
+c do k=1,3
+c ghalf=0.5D0*ggg(k)
+c gelc(k,i)=gelc(k,i)+ghalf
+c gelc(k,j)=gelc(k,j)+ghalf
+c enddo
+c 9/28/08 AL Gradient compotents will be summed only at the end
+ do k=1,3
+ gelc_long(k,j)=gelc(k,j)+ggg(k)
+ gelc_long(k,i)=gelc(k,i)-ggg(k)
+ enddo
+*
+* Loop over residues i+1 thru j-1.
+*
+cgrad do k=i+1,j-1
+cgrad do l=1,3
+cgrad gelc(l,k)=gelc(l,k)+ggg(l)
+cgrad enddo
+cgrad enddo
+c 9/28/08 AL Gradient compotents will be summed only at the end
+ ggg(1)=facvdw*xj
+ ggg(2)=facvdw*yj
+ ggg(3)=facvdw*zj
+ do k=1,3
+ gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
+ gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
+ enddo
+#endif
+*
+* Angular part
+*
+ ecosa=2.0D0*fac3*fac1+fac4
+ fac4=-3.0D0*fac4
+ fac3=-6.0D0*fac3
+ ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
+ ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
+ do k=1,3
+ dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
+ dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
+ enddo
+cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
+cd & (dcosg(k),k=1,3)
+ do k=1,3
+ ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
+ enddo
+c do k=1,3
+c ghalf=0.5D0*ggg(k)
+c gelc(k,i)=gelc(k,i)+ghalf
+c & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
+c & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
+c gelc(k,j)=gelc(k,j)+ghalf
+c & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
+c & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
+c enddo
+cgrad do k=i+1,j-1
+cgrad do l=1,3
+cgrad gelc(l,k)=gelc(l,k)+ggg(l)
+cgrad enddo
+cgrad enddo
+ do k=1,3
+ gelc(k,i)=gelc(k,i)
+ & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
+ & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
+ gelc(k,j)=gelc(k,j)
+ & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
+ & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
+ gelc_long(k,j)=gelc_long(k,j)+ggg(k)
+ gelc_long(k,i)=gelc_long(k,i)-ggg(k)
+ enddo
+ IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
+ & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
+ & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
+C
+C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
+C energy of a peptide unit is assumed in the form of a second-order
+C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
+C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
+C are computed for EVERY pair of non-contiguous peptide groups.
+C
+ if (j.lt.nres-1) then
+ j1=j+1
+ j2=j-1
+ else
+ j1=j-1
+ j2=j-2
+ endif
+ kkk=0
+ do k=1,2
+ do l=1,2
+ kkk=kkk+1
+ muij(kkk)=mu(k,i)*mu(l,j)
+ enddo
+ enddo
+cd write (iout,*) 'EELEC: i',i,' j',j
+cd write (iout,*) 'j',j,' j1',j1,' j2',j2
+cd write(iout,*) 'muij',muij
+ ury=scalar(uy(1,i),erij)
+ urz=scalar(uz(1,i),erij)
+ vry=scalar(uy(1,j),erij)
+ vrz=scalar(uz(1,j),erij)
+ a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
+ a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
+ a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
+ a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
+ fac=dsqrt(-ael6i)*r3ij
+ a22=a22*fac
+ a23=a23*fac
+ a32=a32*fac
+ a33=a33*fac
+cd write (iout,'(4i5,4f10.5)')
+cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
+cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
+cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
+cd & uy(:,j),uz(:,j)
+cd write (iout,'(4f10.5)')
+cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
+cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
+cd write (iout,'(4f10.5)') ury,urz,vry,vrz
+cd write (iout,'(9f10.5/)')
+cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
+C Derivatives of the elements of A in virtual-bond vectors
+ call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
+ do k=1,3
+ uryg(k,1)=scalar(erder(1,k),uy(1,i))
+ uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
+ uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
+ urzg(k,1)=scalar(erder(1,k),uz(1,i))
+ urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
+ urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
+ vryg(k,1)=scalar(erder(1,k),uy(1,j))
+ vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
+ vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
+ vrzg(k,1)=scalar(erder(1,k),uz(1,j))
+ vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
+ vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
+ enddo
+C Compute radial contributions to the gradient
+ facr=-3.0d0*rrmij
+ a22der=a22*facr
+ a23der=a23*facr
+ a32der=a32*facr
+ a33der=a33*facr
+ agg(1,1)=a22der*xj
+ agg(2,1)=a22der*yj
+ agg(3,1)=a22der*zj
+ agg(1,2)=a23der*xj
+ agg(2,2)=a23der*yj
+ agg(3,2)=a23der*zj
+ agg(1,3)=a32der*xj
+ agg(2,3)=a32der*yj
+ agg(3,3)=a32der*zj
+ agg(1,4)=a33der*xj
+ agg(2,4)=a33der*yj
+ agg(3,4)=a33der*zj
+C Add the contributions coming from er
+ fac3=-3.0d0*fac
+ do k=1,3
+ agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
+ agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
+ agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
+ agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
+ enddo
+ do k=1,3
+C Derivatives in DC(i)
+cgrad ghalf1=0.5d0*agg(k,1)
+cgrad ghalf2=0.5d0*agg(k,2)
+cgrad ghalf3=0.5d0*agg(k,3)
+cgrad ghalf4=0.5d0*agg(k,4)
+ aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
+ & -3.0d0*uryg(k,2)*vry)!+ghalf1
+ aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
+ & -3.0d0*uryg(k,2)*vrz)!+ghalf2
+ aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
+ & -3.0d0*urzg(k,2)*vry)!+ghalf3
+ aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
+ & -3.0d0*urzg(k,2)*vrz)!+ghalf4
+C Derivatives in DC(i+1)
+ aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
+ & -3.0d0*uryg(k,3)*vry)!+agg(k,1)
+ aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
+ & -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
+ aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
+ & -3.0d0*urzg(k,3)*vry)!+agg(k,3)
+ aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
+ & -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
+C Derivatives in DC(j)
+ aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
+ & -3.0d0*vryg(k,2)*ury)!+ghalf1
+ aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
+ & -3.0d0*vrzg(k,2)*ury)!+ghalf2
+ aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
+ & -3.0d0*vryg(k,2)*urz)!+ghalf3
+ aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
+ & -3.0d0*vrzg(k,2)*urz)!+ghalf4
+C Derivatives in DC(j+1) or DC(nres-1)
+ aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
+ & -3.0d0*vryg(k,3)*ury)
+ aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
+ & -3.0d0*vrzg(k,3)*ury)
+ aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
+ & -3.0d0*vryg(k,3)*urz)
+ aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
+ & -3.0d0*vrzg(k,3)*urz)
+cgrad if (j.eq.nres-1 .and. i.lt.j-2) then
+cgrad do l=1,4
+cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l)
+cgrad enddo
+cgrad endif
+ enddo
+ acipa(1,1)=a22
+ acipa(1,2)=a23
+ acipa(2,1)=a32
+ acipa(2,2)=a33
+ a22=-a22
+ a23=-a23
+ do l=1,2
+ do k=1,3
+ agg(k,l)=-agg(k,l)
+ aggi(k,l)=-aggi(k,l)
+ aggi1(k,l)=-aggi1(k,l)
+ aggj(k,l)=-aggj(k,l)
+ aggj1(k,l)=-aggj1(k,l)
+ enddo
+ enddo
+ if (j.lt.nres-1) then
+ a22=-a22
+ a32=-a32
+ do l=1,3,2
+ do k=1,3
+ agg(k,l)=-agg(k,l)
+ aggi(k,l)=-aggi(k,l)
+ aggi1(k,l)=-aggi1(k,l)
+ aggj(k,l)=-aggj(k,l)
+ aggj1(k,l)=-aggj1(k,l)
+ enddo
+ enddo
+ else
+ a22=-a22
+ a23=-a23
+ a32=-a32
+ a33=-a33
+ do l=1,4
+ do k=1,3
+ agg(k,l)=-agg(k,l)
+ aggi(k,l)=-aggi(k,l)
+ aggi1(k,l)=-aggi1(k,l)
+ aggj(k,l)=-aggj(k,l)
+ aggj1(k,l)=-aggj1(k,l)
+ enddo
+ enddo
+ endif
+ ENDIF ! WCORR
+ IF (wel_loc.gt.0.0d0) THEN
+C Contribution to the local-electrostatic energy coming from the i-j pair
+ eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
+ & +a33*muij(4)
+cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
+
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
+ & 'eelloc',i,j,eel_loc_ij
+
+ eel_loc=eel_loc+eel_loc_ij
+C Partial derivatives in virtual-bond dihedral angles gamma
+ if (i.gt.1)
+ & gel_loc_loc(i-1)=gel_loc_loc(i-1)+
+ & a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
+ & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
+ gel_loc_loc(j-1)=gel_loc_loc(j-1)+
+ & a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
+ & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
+C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
+ do l=1,3
+ ggg(l)=agg(l,1)*muij(1)+
+ & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
+ gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
+ gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
+cgrad ghalf=0.5d0*ggg(l)
+cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf
+cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf
+ enddo
+cgrad do k=i+1,j2
+cgrad do l=1,3
+cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l)
+cgrad enddo
+cgrad enddo
+C Remaining derivatives of eello
+ do l=1,3
+ gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
+ & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
+ gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
+ & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
+ gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
+ & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
+ gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
+ & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
+ enddo
+ ENDIF
+C Change 12/26/95 to calculate four-body contributions to H-bonding energy
+c if (j.gt.i+1 .and. num_conti.le.maxconts) then
+ if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
+ & .and. num_conti.le.maxconts) then
+c write (iout,*) i,j," entered corr"
+C
+C Calculate the contact function. The ith column of the array JCONT will
+C contain the numbers of atoms that make contacts with the atom I (of numbers
+C greater than I). The arrays FACONT and GACONT will contain the values of
+C the contact function and its derivative.
+c r0ij=1.02D0*rpp(iteli,itelj)
+c r0ij=1.11D0*rpp(iteli,itelj)
+ r0ij=2.20D0*rpp(iteli,itelj)
+c r0ij=1.55D0*rpp(iteli,itelj)
+ call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
+ if (fcont.gt.0.0D0) then
+ num_conti=num_conti+1
+ if (num_conti.gt.maxconts) then
+ write (iout,*) 'WARNING - max. # of contacts exceeded;',
+ & ' will skip next contacts for this conf.'
+ else
+ jcont_hb(num_conti,i)=j
+cd write (iout,*) "i",i," j",j," num_conti",num_conti,
+cd & " jcont_hb",jcont_hb(num_conti,i)
+ IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
+ & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
+C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
+C terms.
+ d_cont(num_conti,i)=rij
+cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
+C --- Electrostatic-interaction matrix ---
+ a_chuj(1,1,num_conti,i)=a22
+ a_chuj(1,2,num_conti,i)=a23
+ a_chuj(2,1,num_conti,i)=a32
+ a_chuj(2,2,num_conti,i)=a33
+C --- Gradient of rij
+ do kkk=1,3
+ grij_hb_cont(kkk,num_conti,i)=erij(kkk)
+ enddo
+ kkll=0
+ do k=1,2
+ do l=1,2
+ kkll=kkll+1
+ do m=1,3
+ a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
+ a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
+ a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
+ a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
+ a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
+ enddo
+ enddo
+ enddo
+ ENDIF
+ IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
+C Calculate contact energies
+ cosa4=4.0D0*cosa
+ wij=cosa-3.0D0*cosb*cosg
+ cosbg1=cosb+cosg
+ cosbg2=cosb-cosg
+c fac3=dsqrt(-ael6i)/r0ij**3
+ fac3=dsqrt(-ael6i)*r3ij
+c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
+ ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
+ if (ees0tmp.gt.0) then
+ ees0pij=dsqrt(ees0tmp)
+ else
+ ees0pij=0
+ endif
+c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
+ ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
+ if (ees0tmp.gt.0) then
+ ees0mij=dsqrt(ees0tmp)
+ else
+ ees0mij=0
+ endif
+c ees0mij=0.0D0
+ ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
+ ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
+C Diagnostics. Comment out or remove after debugging!
+c ees0p(num_conti,i)=0.5D0*fac3*ees0pij
+c ees0m(num_conti,i)=0.5D0*fac3*ees0mij
+c ees0m(num_conti,i)=0.0D0
+C End diagnostics.
+c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
+c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
+C Angular derivatives of the contact function
+ ees0pij1=fac3/ees0pij
+ ees0mij1=fac3/ees0mij
+ fac3p=-3.0D0*fac3*rrmij
+ ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
+ ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
+c ees0mij1=0.0D0
+ ecosa1= ees0pij1*( 1.0D0+0.5D0*wij)
+ ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
+ ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
+ ecosa2= ees0mij1*(-1.0D0+0.5D0*wij)
+ ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
+ ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
+ ecosap=ecosa1+ecosa2
+ ecosbp=ecosb1+ecosb2
+ ecosgp=ecosg1+ecosg2
+ ecosam=ecosa1-ecosa2
+ ecosbm=ecosb1-ecosb2
+ ecosgm=ecosg1-ecosg2
+C Diagnostics
+c ecosap=ecosa1
+c ecosbp=ecosb1
+c ecosgp=ecosg1
+c ecosam=0.0D0
+c ecosbm=0.0D0
+c ecosgm=0.0D0
+C End diagnostics
+ facont_hb(num_conti,i)=fcont
+ fprimcont=fprimcont/rij
+cd facont_hb(num_conti,i)=1.0D0
+C Following line is for diagnostics.
+cd fprimcont=0.0D0
+ do k=1,3
+ dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
+ dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
+ enddo
+ do k=1,3
+ gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
+ gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
+ enddo
+ gggp(1)=gggp(1)+ees0pijp*xj
+ gggp(2)=gggp(2)+ees0pijp*yj
+ gggp(3)=gggp(3)+ees0pijp*zj
+ gggm(1)=gggm(1)+ees0mijp*xj
+ gggm(2)=gggm(2)+ees0mijp*yj
+ gggm(3)=gggm(3)+ees0mijp*zj
+C Derivatives due to the contact function
+ gacont_hbr(1,num_conti,i)=fprimcont*xj
+ gacont_hbr(2,num_conti,i)=fprimcont*yj
+ gacont_hbr(3,num_conti,i)=fprimcont*zj
+ do k=1,3
+c
+c 10/24/08 cgrad and ! comments indicate the parts of the code removed
+c following the change of gradient-summation algorithm.
+c
+cgrad ghalfp=0.5D0*gggp(k)
+cgrad ghalfm=0.5D0*gggm(k)
+ gacontp_hb1(k,num_conti,i)=!ghalfp
+ & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
+ & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
+ gacontp_hb2(k,num_conti,i)=!ghalfp
+ & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
+ & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
+ gacontp_hb3(k,num_conti,i)=gggp(k)
+ gacontm_hb1(k,num_conti,i)=!ghalfm
+ & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
+ & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
+ gacontm_hb2(k,num_conti,i)=!ghalfm
+ & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
+ & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
+ gacontm_hb3(k,num_conti,i)=gggm(k)
+ enddo
+ ENDIF ! wcorr
+ endif ! num_conti.le.maxconts
+ endif ! fcont.gt.0
+ endif ! j.gt.i+1
+ if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
+ do k=1,4
+ do l=1,3
+ ghalf=0.5d0*agg(l,k)
+ aggi(l,k)=aggi(l,k)+ghalf
+ aggi1(l,k)=aggi1(l,k)+agg(l,k)
+ aggj(l,k)=aggj(l,k)+ghalf
+ enddo
+ enddo
+ if (j.eq.nres-1 .and. i.lt.j-2) then
+ do k=1,4
+ do l=1,3
+ aggj1(l,k)=aggj1(l,k)+agg(l,k)
+ enddo
+ enddo
+ endif
+ endif
+c t_eelecij=t_eelecij+MPI_Wtime()-time00
+ return
+ end
+C-----------------------------------------------------------------------
+ subroutine evdwpp_short(evdw1)
+C
+C Compute Evdwpp
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.TORSION'
+ include 'COMMON.VECTORS'
+ include 'COMMON.FFIELD'
+ dimension ggg(3)
+c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
+#ifdef MOMENT
+ double precision scal_el /1.0d0/
+#else
+ double precision scal_el /0.5d0/
+#endif
+ evdw1=0.0D0
+c write (iout,*) "iatel_s_vdw",iatel_s_vdw,
+c & " iatel_e_vdw",iatel_e_vdw
+ call flush(iout)
+ do i=iatel_s_vdw,iatel_e_vdw
+ dxi=dc(1,i)
+ dyi=dc(2,i)
+ dzi=dc(3,i)
+ dx_normi=dc_norm(1,i)
+ dy_normi=dc_norm(2,i)
+ dz_normi=dc_norm(3,i)
+ xmedi=c(1,i)+0.5d0*dxi
+ ymedi=c(2,i)+0.5d0*dyi
+ zmedi=c(3,i)+0.5d0*dzi
+ num_conti=0
+c write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
+c & ' ielend',ielend_vdw(i)
+ call flush(iout)
+ do j=ielstart_vdw(i),ielend_vdw(i)
+ ind=ind+1
+ iteli=itel(i)
+ itelj=itel(j)
+ if (j.eq.i+2 .and. itelj.eq.2) iteli=2
+ aaa=app(iteli,itelj)
+ bbb=bpp(iteli,itelj)
+ dxj=dc(1,j)
+ dyj=dc(2,j)
+ dzj=dc(3,j)
+ dx_normj=dc_norm(1,j)
+ dy_normj=dc_norm(2,j)
+ dz_normj=dc_norm(3,j)
+ xj=c(1,j)+0.5D0*dxj-xmedi
+ yj=c(2,j)+0.5D0*dyj-ymedi
+ zj=c(3,j)+0.5D0*dzj-zmedi
+ rij=xj*xj+yj*yj+zj*zj
+ rrmij=1.0D0/rij
+ rij=dsqrt(rij)
+ sss=sscale(rij/rpp(iteli,itelj))
+ if (sss.gt.0.0d0) then
+ rmij=1.0D0/rij
+ r3ij=rrmij*rmij
+ r6ij=r3ij*r3ij
+ ev1=aaa*r6ij*r6ij
+c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
+ if (j.eq.i+2) ev1=scal_el*ev1
+ ev2=bbb*r6ij
+ evdwij=ev1+ev2
+ if (energy_dec) then
+ write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
+ endif
+ evdw1=evdw1+evdwij*sss
+C
+C Calculate contributions to the Cartesian gradient.
+C
+ facvdw=-6*rrmij*(ev1+evdwij)*sss
+ ggg(1)=facvdw*xj
+ ggg(2)=facvdw*yj
+ ggg(3)=facvdw*zj
+ do k=1,3
+ gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
+ gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
+ enddo
+ endif
+ enddo ! j
+ enddo ! i
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine escp_long(evdw2,evdw2_14)
+C
+C This subroutine calculates the excluded-volume interaction energy between
+C peptide-group centers and side chains and its gradient in virtual-bond and
+C side-chain vectors.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.FFIELD'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CONTROL'
+ dimension ggg(3)
+ evdw2=0.0D0
+ evdw2_14=0.0d0
+cd print '(a)','Enter ESCP'
+cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
+ do i=iatscp_s,iatscp_e
+ iteli=itel(i)
+ xi=0.5D0*(c(1,i)+c(1,i+1))
+ yi=0.5D0*(c(2,i)+c(2,i+1))
+ zi=0.5D0*(c(3,i)+c(3,i+1))
+
+ do iint=1,nscp_gr(i)
+
+ do j=iscpstart(i,iint),iscpend(i,iint)
+ itypj=itype(j)
+C Uncomment following three lines for SC-p interactions
+c xj=c(1,nres+j)-xi
+c yj=c(2,nres+j)-yi
+c zj=c(3,nres+j)-zi
+C Uncomment following three lines for Ca-p interactions
+ xj=c(1,j)-xi
+ yj=c(2,j)-yi
+ zj=c(3,j)-zi
+ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
+
+ sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli)))
+
+ if (sss.lt.1.0d0) then
+
+ fac=rrij**expon2
+ e1=fac*fac*aad(itypj,iteli)
+ e2=fac*bad(itypj,iteli)
+ if (iabs(j-i) .le. 2) then
+ e1=scal14*e1
+ e2=scal14*e2
+ evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)
+ endif
+ evdwij=e1+e2
+ evdw2=evdw2+evdwij*(1.0d0-sss)
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
+ & 'evdw2',i,j,evdwij
+C
+C Calculate contributions to the gradient in the virtual-bond and SC vectors.
+C
+ fac=-(evdwij+e1)*rrij*(1.0d0-sss)
+ ggg(1)=xj*fac
+ ggg(2)=yj*fac
+ ggg(3)=zj*fac
+C Uncomment following three lines for SC-p interactions
+c do k=1,3
+c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
+c enddo
+C Uncomment following line for SC-p interactions
+c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
+ do k=1,3
+ gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
+ gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
+ enddo
+ endif
+ enddo
+
+ enddo ! iint
+ enddo ! i
+ do i=1,nct
+ do j=1,3
+ gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
+ gvdwc_scpp(j,i)=expon*gvdwc_scpp(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 escp_short(evdw2,evdw2_14)
+C
+C This subroutine calculates the excluded-volume interaction energy between
+C peptide-group centers and side chains and its gradient in virtual-bond and
+C side-chain vectors.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.FFIELD'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CONTROL'
+ dimension ggg(3)
+ evdw2=0.0D0
+ evdw2_14=0.0d0
+cd print '(a)','Enter ESCP'
+cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
+ do i=iatscp_s,iatscp_e
+ iteli=itel(i)
+ xi=0.5D0*(c(1,i)+c(1,i+1))
+ yi=0.5D0*(c(2,i)+c(2,i+1))
+ zi=0.5D0*(c(3,i)+c(3,i+1))
+
+ do iint=1,nscp_gr(i)
+
+ do j=iscpstart(i,iint),iscpend(i,iint)
+ itypj=itype(j)
+C Uncomment following three lines for SC-p interactions
+c xj=c(1,nres+j)-xi
+c yj=c(2,nres+j)-yi
+c zj=c(3,nres+j)-zi
+C Uncomment following three lines for Ca-p interactions
+ xj=c(1,j)-xi
+ yj=c(2,j)-yi
+ zj=c(3,j)-zi
+ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
+
+ sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli)))
+
+ if (sss.gt.0.0d0) then
+
+ fac=rrij**expon2
+ e1=fac*fac*aad(itypj,iteli)
+ e2=fac*bad(itypj,iteli)
+ if (iabs(j-i) .le. 2) then
+ e1=scal14*e1
+ e2=scal14*e2
+ evdw2_14=evdw2_14+(e1+e2)*sss
+ endif
+ evdwij=e1+e2
+ evdw2=evdw2+evdwij*sss
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
+ & 'evdw2',i,j,evdwij
+C
+C Calculate contributions to the gradient in the virtual-bond and SC vectors.
+C
+ fac=-(evdwij+e1)*rrij*sss
+ ggg(1)=xj*fac
+ ggg(2)=yj*fac
+ ggg(3)=zj*fac
+C Uncomment following three lines for SC-p interactions
+c do k=1,3
+c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
+c enddo
+C Uncomment following line for SC-p interactions
+c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
+ do k=1,3
+ gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
+ gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
+ enddo
+ endif
+ enddo
+
+ enddo ! iint
+ enddo ! i
+ do i=1,nct
+ do j=1,3
+ gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
+ gvdwc_scpp(j,i)=expon*gvdwc_scpp(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
--- /dev/null
+ subroutine etotal(energia)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifndef ISNAN
+ external proc_proc
+#ifdef WINPGI
+cMS$ATTRIBUTES C :: proc_proc
+#endif
+#endif
+#ifdef MPI
+ include "mpif.h"
+ double precision weights_(n_ene)
+#endif
+ include 'COMMON.SETUP'
+ include 'COMMON.IOUNITS'
+ double precision energia(0:n_ene)
+ include 'COMMON.LOCAL'
+ include 'COMMON.FFIELD'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.CHAIN'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+ include 'COMMON.CONTROL'
+ include 'COMMON.TIME1'
+#ifdef MPI
+c print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
+c & " nfgtasks",nfgtasks
+ if (nfgtasks.gt.1) then
+#ifdef MPI
+ time00=MPI_Wtime()
+#else
+ time00=tcpu()
+#endif
+C FG slaves call the following matching MPI_Bcast in ERGASTULUM
+ if (fg_rank.eq.0) then
+ call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
+c print *,"Processor",myrank," BROADCAST iorder"
+C FG master sets up the WEIGHTS_ array which will be broadcast to the
+C FG slaves as WEIGHTS array.
+ 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)=wbond
+ weights_(18)=scal14
+ weights_(21)=wsccor
+ weights_(22)=wsct
+C FG Master broadcasts the WEIGHTS_ array
+ call MPI_Bcast(weights_(1),n_ene,
+ & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
+ else
+C FG slaves receive the WEIGHTS array
+ call MPI_Bcast(weights(1),n_ene,
+ & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
+ wsc=weights(1)
+ wscp=weights(2)
+ welec=weights(3)
+ wcorr=weights(4)
+ wcorr5=weights(5)
+ wcorr6=weights(6)
+ wel_loc=weights(7)
+ wturn3=weights(8)
+ wturn4=weights(9)
+ wturn6=weights(10)
+ wang=weights(11)
+ wscloc=weights(12)
+ wtor=weights(13)
+ wtor_d=weights(14)
+ wstrain=weights(15)
+ wvdwpp=weights(16)
+ wbond=weights(17)
+ scal14=weights(18)
+ wsccor=weights(21)
+ wsct=weights(22)
+ endif
+ time_Bcast=time_Bcast+MPI_Wtime()-time00
+ time_Bcastw=time_Bcastw+MPI_Wtime()-time00
+c call chainbuild_cart
+ endif
+c print *,'Processor',myrank,' calling etotal ipot=',ipot
+c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
+#else
+c if (modecalc.eq.12.or.modecalc.eq.14) then
+c call int_from_cart1(.false.)
+c endif
+#endif
+#ifdef TIMING
+#ifdef MPI
+ time00=MPI_Wtime()
+#else
+ time00=tcpu()
+#endif
+#endif
+C
+C Compute the side-chain and electrostatic interaction energy
+C
+ goto (101,102,103,104,105,106) ipot
+C Lennard-Jones potential.
+ 101 call elj(evdw,evdw_p,evdw_m)
+cd print '(a)','Exit ELJ'
+ goto 107
+C Lennard-Jones-Kihara potential (shifted).
+ 102 call eljk(evdw,evdw_p,evdw_m)
+ goto 107
+C Berne-Pechukas potential (dilated LJ, angular dependence).
+ 103 call ebp(evdw,evdw_p,evdw_m)
+ goto 107
+C Gay-Berne potential (shifted LJ, angular dependence).
+ 104 call egb(evdw,evdw_p,evdw_m)
+ goto 107
+C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
+ 105 call egbv(evdw,evdw_p,evdw_m)
+ goto 107
+C Soft-sphere potential
+ 106 call e_softsphere(evdw)
+C
+C Calculate electrostatic (H-bonding) energy of the main chain.
+C
+ 107 continue
+c print *,"Processor",myrank," computed USCSC"
+#ifdef TIMING
+#ifdef MPI
+ time01=MPI_Wtime()
+#else
+ time00=tcpu()
+#endif
+#endif
+ call vec_and_deriv
+#ifdef TIMING
+#ifdef MPI
+ time_vec=time_vec+MPI_Wtime()-time01
+#else
+ time_vec=time_vec+tcpu()-time01
+#endif
+#endif
+c print *,"Processor",myrank," left VEC_AND_DERIV"
+ if (ipot.lt.6) then
+#ifdef SPLITELE
+ if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
+ & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
+ & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
+ & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
+#else
+ if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
+ & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
+ & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
+ & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
+#endif
+ call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
+ else
+ ees=0.0d0
+ evdw1=0.0d0
+ eel_loc=0.0d0
+ eello_turn3=0.0d0
+ eello_turn4=0.0d0
+ endif
+ else
+c write (iout,*) "Soft-spheer ELEC potential"
+ call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
+ & eello_turn4)
+ endif
+c print *,"Processor",myrank," computed UELEC"
+C
+C Calculate excluded-volume interaction energy between peptide groups
+C and side chains.
+C
+ if (ipot.lt.6) then
+ if(wscp.gt.0d0) then
+ call escp(evdw2,evdw2_14)
+ else
+ evdw2=0
+ evdw2_14=0
+ endif
+ else
+c write (iout,*) "Soft-sphere SCP potential"
+ call escp_soft_sphere(evdw2,evdw2_14)
+ endif
+c
+c Calculate the bond-stretching energy
+c
+ call ebond(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
+ if (wang.gt.0d0) then
+ call ebend(ebe)
+ else
+ ebe=0
+ endif
+c print *,"Processor",myrank," computed UB"
+C
+C Calculate the SC local energy.
+C
+ call esc(escloc)
+c print *,"Processor",myrank," computed USC"
+C
+C Calculate the virtual-bond torsional energy.
+C
+cd print *,'nterm=',nterm
+ if (wtor.gt.0) then
+ call etor(etors,edihcnstr)
+ else
+ etors=0
+ edihcnstr=0
+ endif
+c print *,"Processor",myrank," computed Utor"
+C
+C 6/23/01 Calculate double-torsional energy
+C
+ if (wtor_d.gt.0) then
+ call etor_d(etors_d)
+ else
+ etors_d=0
+ endif
+c print *,"Processor",myrank," computed Utord"
+C
+C 21/5/07 Calculate local sicdechain correlation energy
+C
+ if (wsccor.gt.0.0d0) then
+ call eback_sc_corr(esccor)
+ else
+ esccor=0.0d0
+ endif
+c print *,"Processor",myrank," computed Usccorr"
+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) .and. ipot.lt.6) then
+ call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
+cd write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
+cd &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",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) .and. ipot.lt.6) then
+ call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
+cd write (iout,*) "multibody_hb ecorr",ecorr
+ endif
+c print *,"Processor",myrank," computed Ucorr"
+C
+C If performing constraint dynamics, call the constraint energy
+C after the equilibration time
+ if(usampl.and.totT.gt.eq_time) then
+ call EconstrQ
+ call Econstr_back
+ else
+ Uconst=0.0d0
+ Uconst_back=0.0d0
+ endif
+#ifdef TIMING
+#ifdef MPI
+ time_enecalc=time_enecalc+MPI_Wtime()-time00
+#else
+ time_enecalc=time_enecalc+tcpu()-time00
+#endif
+#endif
+c print *,"Processor",myrank," computed Uconstr"
+#ifdef TIMING
+#ifdef MPI
+ time00=MPI_Wtime()
+#else
+ time00=tcpu()
+#endif
+#endif
+c
+C Sum the energies
+C
+ energia(1)=evdw
+#ifdef SCP14
+ energia(2)=evdw2-evdw2_14
+ energia(18)=evdw2_14
+#else
+ energia(2)=evdw2
+ energia(18)=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(19)=edihcnstr
+ energia(17)=estr
+ energia(20)=Uconst+Uconst_back
+ energia(21)=esccor
+ energia(22)=evdw_p
+ energia(23)=evdw_m
+c print *," Processor",myrank," calls SUM_ENERGY"
+ call sum_energy(energia,.true.)
+c print *," Processor",myrank," left SUM_ENERGY"
+#ifdef TIMING
+#ifdef MPI
+ time_sumene=time_sumene+MPI_Wtime()-time00
+#else
+ time_sumene=time_sumene+tcpu()-time00
+#endif
+#endif
+ return
+ end
+c-------------------------------------------------------------------------------
+ subroutine sum_energy(energia,reduce)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifndef ISNAN
+ external proc_proc
+#ifdef WINPGI
+cMS$ATTRIBUTES C :: proc_proc
+#endif
+#endif
+#ifdef MPI
+ include "mpif.h"
+#endif
+ include 'COMMON.SETUP'
+ include 'COMMON.IOUNITS'
+ double precision energia(0:n_ene),enebuff(0:n_ene+1)
+ include 'COMMON.FFIELD'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.CHAIN'
+ include 'COMMON.VAR'
+ include 'COMMON.CONTROL'
+ include 'COMMON.TIME1'
+ logical reduce
+#ifdef MPI
+ if (nfgtasks.gt.1 .and. reduce) then
+#ifdef DEBUG
+ write (iout,*) "energies before REDUCE"
+ call enerprint(energia)
+ call flush(iout)
+#endif
+ do i=0,n_ene
+ enebuff(i)=energia(i)
+ enddo
+ time00=MPI_Wtime()
+ call MPI_Barrier(FG_COMM,IERR)
+ time_barrier_e=time_barrier_e+MPI_Wtime()-time00
+ time00=MPI_Wtime()
+ call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
+ & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
+#ifdef DEBUG
+ write (iout,*) "energies after REDUCE"
+ call enerprint(energia)
+ call flush(iout)
+#endif
+ time_Reduce=time_Reduce+MPI_Wtime()-time00
+ endif
+ if (fg_rank.eq.0) then
+#endif
+#ifdef TSCSC
+ evdw=energia(22)+wsct*energia(23)
+#else
+ evdw=energia(1)
+#endif
+#ifdef SCP14
+ evdw2=energia(2)+energia(18)
+ evdw2_14=energia(18)
+#else
+ evdw2=energia(2)
+#endif
+#ifdef SPLITELE
+ ees=energia(3)
+ evdw1=energia(16)
+#else
+ ees=energia(3)
+ evdw1=0.0d0
+#endif
+ ecorr=energia(4)
+ ecorr5=energia(5)
+ ecorr6=energia(6)
+ eel_loc=energia(7)
+ eello_turn3=energia(8)
+ eello_turn4=energia(9)
+ eturn6=energia(10)
+ ebe=energia(11)
+ escloc=energia(12)
+ etors=energia(13)
+ etors_d=energia(14)
+ ehpb=energia(15)
+ edihcnstr=energia(19)
+ estr=energia(17)
+ Uconst=energia(20)
+ esccor=energia(21)
+#ifdef SPLITELE
+ etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
+ & +wang*ebe+wtor*etors+wscloc*escloc
+ & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
+ & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
+ & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
+ & +wbond*estr+Uconst+wsccor*esccor
+#else
+ etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
+ & +wang*ebe+wtor*etors+wscloc*escloc
+ & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
+ & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
+ & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
+ & +wbond*estr+Uconst+wsccor*esccor
+#endif
+ energia(0)=etot
+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 MPI
+ endif
+#endif
+ return
+ end
+c-------------------------------------------------------------------------------
+ subroutine sum_gradient
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifndef ISNAN
+ external proc_proc
+#ifdef WINPGI
+cMS$ATTRIBUTES C :: proc_proc
+#endif
+#endif
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ double precision gradbufc(3,maxres),gradbufx(3,maxres),
+ & glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
+ include 'COMMON.SETUP'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.FFIELD'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.CHAIN'
+ include 'COMMON.VAR'
+ include 'COMMON.CONTROL'
+ include 'COMMON.TIME1'
+ include 'COMMON.MAXGRAD'
+ include 'COMMON.SCCOR'
+#ifdef TIMING
+#ifdef MPI
+ time01=MPI_Wtime()
+#else
+ time01=tcpu()
+#endif
+#endif
+#ifdef DEBUG
+ write (iout,*) "sum_gradient gvdwc, gvdwx"
+ do i=1,nres
+ write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
+ & i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
+ & (gvdwcT(j,i),j=1,3)
+ enddo
+ call flush(iout)
+#endif
+#ifdef MPI
+C FG slaves call the following matching MPI_Bcast in ERGASTULUM
+ if (nfgtasks.gt.1 .and. fg_rank.eq.0)
+ & call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
+#endif
+C
+C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
+C in virtual-bond-vector coordinates
+C
+#ifdef DEBUG
+c write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
+c do i=1,nres-1
+c write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
+c & i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
+c enddo
+c write (iout,*) "gel_loc_tur3 gel_loc_turn4"
+c do i=1,nres-1
+c write (iout,'(i5,3f10.5,2x,f10.5)')
+c & i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
+c enddo
+ write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
+ do i=1,nres
+ write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
+ & i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
+ & g_corr5_loc(i)
+ enddo
+ call flush(iout)
+#endif
+#ifdef SPLITELE
+#ifdef TSCSC
+ do i=1,nct
+ do j=1,3
+ gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
+ & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
+ & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
+ & wel_loc*gel_loc_long(j,i)+
+ & wcorr*gradcorr_long(j,i)+
+ & wcorr5*gradcorr5_long(j,i)+
+ & wcorr6*gradcorr6_long(j,i)+
+ & wturn6*gcorr6_turn_long(j,i)+
+ & wstrain*ghpbc(j,i)
+ enddo
+ enddo
+#else
+ do i=1,nct
+ do j=1,3
+ gradbufc(j,i)=wsc*gvdwc(j,i)+
+ & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
+ & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
+ & wel_loc*gel_loc_long(j,i)+
+ & wcorr*gradcorr_long(j,i)+
+ & wcorr5*gradcorr5_long(j,i)+
+ & wcorr6*gradcorr6_long(j,i)+
+ & wturn6*gcorr6_turn_long(j,i)+
+ & wstrain*ghpbc(j,i)
+ enddo
+ enddo
+#endif
+#else
+ do i=1,nct
+ do j=1,3
+ gradbufc(j,i)=wsc*gvdwc(j,i)+
+ & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
+ & welec*gelc_long(j,i)+
+ & wbond*gradb(j,i)+
+ & wel_loc*gel_loc_long(j,i)+
+ & wcorr*gradcorr_long(j,i)+
+ & wcorr5*gradcorr5_long(j,i)+
+ & wcorr6*gradcorr6_long(j,i)+
+ & wturn6*gcorr6_turn_long(j,i)+
+ & wstrain*ghpbc(j,i)
+ enddo
+ enddo
+#endif
+#ifdef MPI
+ if (nfgtasks.gt.1) then
+ time00=MPI_Wtime()
+#ifdef DEBUG
+ write (iout,*) "gradbufc before allreduce"
+ do i=1,nres
+ write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
+ enddo
+ call flush(iout)
+#endif
+ do i=1,nres
+ do j=1,3
+ gradbufc_sum(j,i)=gradbufc(j,i)
+ enddo
+ enddo
+c call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
+c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
+c time_reduce=time_reduce+MPI_Wtime()-time00
+#ifdef DEBUG
+c write (iout,*) "gradbufc_sum after allreduce"
+c do i=1,nres
+c write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
+c enddo
+c call flush(iout)
+#endif
+#ifdef TIMING
+c time_allreduce=time_allreduce+MPI_Wtime()-time00
+#endif
+ do i=nnt,nres
+ do k=1,3
+ gradbufc(k,i)=0.0d0
+ enddo
+ enddo
+#ifdef DEBUG
+ write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
+ write (iout,*) (i," jgrad_start",jgrad_start(i),
+ & " jgrad_end ",jgrad_end(i),
+ & i=igrad_start,igrad_end)
+#endif
+c
+c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
+c do not parallelize this part.
+c
+c do i=igrad_start,igrad_end
+c do j=jgrad_start(i),jgrad_end(i)
+c do k=1,3
+c gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
+c enddo
+c enddo
+c enddo
+ do j=1,3
+ gradbufc(j,nres-1)=gradbufc_sum(j,nres)
+ enddo
+ do i=nres-2,nnt,-1
+ do j=1,3
+ gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
+ enddo
+ enddo
+#ifdef DEBUG
+ write (iout,*) "gradbufc after summing"
+ do i=1,nres
+ write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
+ enddo
+ call flush(iout)
+#endif
+ else
+#endif
+#ifdef DEBUG
+ write (iout,*) "gradbufc"
+ do i=1,nres
+ write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
+ enddo
+ call flush(iout)
+#endif
+ do i=1,nres
+ do j=1,3
+ gradbufc_sum(j,i)=gradbufc(j,i)
+ gradbufc(j,i)=0.0d0
+ enddo
+ enddo
+ do j=1,3
+ gradbufc(j,nres-1)=gradbufc_sum(j,nres)
+ enddo
+ do i=nres-2,nnt,-1
+ do j=1,3
+ gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
+ enddo
+ enddo
+c do i=nnt,nres-1
+c do k=1,3
+c gradbufc(k,i)=0.0d0
+c enddo
+c do j=i+1,nres
+c do k=1,3
+c gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
+c enddo
+c enddo
+c enddo
+#ifdef DEBUG
+ write (iout,*) "gradbufc after summing"
+ do i=1,nres
+ write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
+ enddo
+ call flush(iout)
+#endif
+#ifdef MPI
+ endif
+#endif
+ do k=1,3
+ gradbufc(k,nres)=0.0d0
+ enddo
+ do i=1,nct
+ do j=1,3
+#ifdef SPLITELE
+ gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
+ & wel_loc*gel_loc(j,i)+
+ & 0.5d0*(wscp*gvdwc_scpp(j,i)+
+ & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
+ & wel_loc*gel_loc_long(j,i)+
+ & wcorr*gradcorr_long(j,i)+
+ & wcorr5*gradcorr5_long(j,i)+
+ & wcorr6*gradcorr6_long(j,i)+
+ & wturn6*gcorr6_turn_long(j,i))+
+ & wbond*gradb(j,i)+
+ & wcorr*gradcorr(j,i)+
+ & wturn3*gcorr3_turn(j,i)+
+ & wturn4*gcorr4_turn(j,i)+
+ & wcorr5*gradcorr5(j,i)+
+ & wcorr6*gradcorr6(j,i)+
+ & wturn6*gcorr6_turn(j,i)+
+ & wsccor*gsccorc(j,i)
+ & +wscloc*gscloc(j,i)
+#else
+ gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
+ & wel_loc*gel_loc(j,i)+
+ & 0.5d0*(wscp*gvdwc_scpp(j,i)+
+ & welec*gelc_long(j,i)+
+ & wel_loc*gel_loc_long(j,i)+
+ & wcorr*gcorr_long(j,i)+
+ & wcorr5*gradcorr5_long(j,i)+
+ & wcorr6*gradcorr6_long(j,i)+
+ & wturn6*gcorr6_turn_long(j,i))+
+ & wbond*gradb(j,i)+
+ & wcorr*gradcorr(j,i)+
+ & wturn3*gcorr3_turn(j,i)+
+ & wturn4*gcorr4_turn(j,i)+
+ & wcorr5*gradcorr5(j,i)+
+ & wcorr6*gradcorr6(j,i)+
+ & wturn6*gcorr6_turn(j,i)+
+ & wsccor*gsccorc(j,i)
+ & +wscloc*gscloc(j,i)
+#endif
+#ifdef TSCSC
+ gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
+ & wscp*gradx_scp(j,i)+
+ & wbond*gradbx(j,i)+
+ & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
+ & wsccor*gsccorx(j,i)
+ & +wscloc*gsclocx(j,i)
+#else
+ 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*gsccorx(j,i)
+ & +wscloc*gsclocx(j,i)
+#endif
+ enddo
+ enddo
+#ifdef DEBUG
+ write (iout,*) "gloc before adding corr"
+ do i=1,4*nres
+ write (iout,*) i,gloc(i,icg)
+ enddo
+#endif
+ do i=1,nres-3
+ gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
+ & +wcorr5*g_corr5_loc(i)
+ & +wcorr6*g_corr6_loc(i)
+ & +wturn4*gel_loc_turn4(i)
+ & +wturn3*gel_loc_turn3(i)
+ & +wturn6*gel_loc_turn6(i)
+ & +wel_loc*gel_loc_loc(i)
+ enddo
+#ifdef DEBUG
+ write (iout,*) "gloc after adding corr"
+ do i=1,4*nres
+ write (iout,*) i,gloc(i,icg)
+ enddo
+#endif
+#ifdef MPI
+ if (nfgtasks.gt.1) then
+ do j=1,3
+ do i=1,nres
+ gradbufc(j,i)=gradc(j,i,icg)
+ gradbufx(j,i)=gradx(j,i,icg)
+ enddo
+ enddo
+ do i=1,4*nres
+ glocbuf(i)=gloc(i,icg)
+ enddo
+#define DEBUG
+#ifdef DEBUG
+ write (iout,*) "gloc_sc before reduce"
+ do i=1,nres
+ do j=1,3
+ write (iout,*) i,j,gloc_sc(j,i,icg)
+ enddo
+ enddo
+#endif
+#undef DEBUG
+ do i=1,nres
+ do j=1,3
+ gloc_scbuf(j,i)=gloc_sc(j,i,icg)
+ enddo
+ enddo
+ time00=MPI_Wtime()
+ call MPI_Barrier(FG_COMM,IERR)
+ time_barrier_g=time_barrier_g+MPI_Wtime()-time00
+ time00=MPI_Wtime()
+ call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
+ & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
+ call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
+ & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
+ call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
+ & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
+ call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
+ & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
+ time_reduce=time_reduce+MPI_Wtime()-time00
+#define DEBUG
+#ifdef DEBUG
+ write (iout,*) "gloc_sc after reduce"
+ do i=1,nres
+ do j=1,3
+ write (iout,*) i,j,gloc_sc(j,i,icg)
+ enddo
+ enddo
+#endif
+#undef DEBUG
+#ifdef DEBUG
+ write (iout,*) "gloc after reduce"
+ do i=1,4*nres
+ write (iout,*) i,gloc(i,icg)
+ enddo
+#endif
+ endif
+#endif
+ if (gnorm_check) then
+c
+c Compute the maximum elements of the gradient
+c
+ gvdwc_max=0.0d0
+ gvdwc_scp_max=0.0d0
+ gelc_max=0.0d0
+ gvdwpp_max=0.0d0
+ gradb_max=0.0d0
+ ghpbc_max=0.0d0
+ gradcorr_max=0.0d0
+ gel_loc_max=0.0d0
+ gcorr3_turn_max=0.0d0
+ gcorr4_turn_max=0.0d0
+ gradcorr5_max=0.0d0
+ gradcorr6_max=0.0d0
+ gcorr6_turn_max=0.0d0
+ gsccorc_max=0.0d0
+ gscloc_max=0.0d0
+ gvdwx_max=0.0d0
+ gradx_scp_max=0.0d0
+ ghpbx_max=0.0d0
+ gradxorr_max=0.0d0
+ gsccorx_max=0.0d0
+ gsclocx_max=0.0d0
+ do i=1,nct
+ gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
+ if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
+#ifdef TSCSC
+ gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
+ if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
+#endif
+ gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
+ if (gvdwc_scp_norm.gt.gvdwc_scp_max)
+ & gvdwc_scp_max=gvdwc_scp_norm
+ gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
+ if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
+ gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
+ if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
+ gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
+ if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
+ ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
+ if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
+ gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
+ if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
+ gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
+ if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
+ gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
+ & gcorr3_turn(1,i)))
+ if (gcorr3_turn_norm.gt.gcorr3_turn_max)
+ & gcorr3_turn_max=gcorr3_turn_norm
+ gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
+ & gcorr4_turn(1,i)))
+ if (gcorr4_turn_norm.gt.gcorr4_turn_max)
+ & gcorr4_turn_max=gcorr4_turn_norm
+ gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
+ if (gradcorr5_norm.gt.gradcorr5_max)
+ & gradcorr5_max=gradcorr5_norm
+ gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
+ if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
+ gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
+ & gcorr6_turn(1,i)))
+ if (gcorr6_turn_norm.gt.gcorr6_turn_max)
+ & gcorr6_turn_max=gcorr6_turn_norm
+ gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
+ if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
+ gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
+ if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
+ gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
+ if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
+#ifdef TSCSC
+ gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
+ if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
+#endif
+ gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
+ if (gradx_scp_norm.gt.gradx_scp_max)
+ & gradx_scp_max=gradx_scp_norm
+ ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
+ if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
+ gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
+ if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
+ gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
+ if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
+ gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
+ if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
+ enddo
+ if (gradout) then
+#ifdef AIX
+ open(istat,file=statname,position="append")
+#else
+ open(istat,file=statname,access="append")
+#endif
+ write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
+ & gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
+ & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
+ & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
+ & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
+ & gsccorx_max,gsclocx_max
+ close(istat)
+ if (gvdwc_max.gt.1.0d4) then
+ write (iout,*) "gvdwc gvdwx gradb gradbx"
+ do i=nnt,nct
+ write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
+ & gradb(j,i),gradbx(j,i),j=1,3)
+ enddo
+ call pdbout(0.0d0,'cipiszcze',iout)
+ call flush(iout)
+ endif
+ endif
+ endif
+#ifdef DEBUG
+ write (iout,*) "gradc gradx gloc"
+ do i=1,nres
+ write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
+ & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
+ enddo
+#endif
+#ifdef TIMING
+#ifdef MPI
+ time_sumgradient=time_sumgradient+MPI_Wtime()-time01
+#else
+ time_sumgradient=time_sumgradient+tcpu()-time01
+#endif
+#endif
+ return
+ end
+c-------------------------------------------------------------------------------
+ subroutine rescale_weights(t_bath)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.FFIELD'
+ include 'COMMON.SBRIDGE'
+ double precision kfac /2.4d0/
+ double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
+c facT=temp0/t_bath
+c facT=2*temp0/(t_bath+temp0)
+ if (rescale_mode.eq.0) then
+ facT=1.0d0
+ facT2=1.0d0
+ facT3=1.0d0
+ facT4=1.0d0
+ facT5=1.0d0
+ else if (rescale_mode.eq.1) then
+ facT=kfac/(kfac-1.0d0+t_bath/temp0)
+ facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
+ facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
+ facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
+ facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
+ else if (rescale_mode.eq.2) then
+ x=t_bath/temp0
+ x2=x*x
+ x3=x2*x
+ x4=x3*x
+ x5=x4*x
+ facT=licznik/dlog(dexp(x)+dexp(-x))
+ facT2=licznik/dlog(dexp(x2)+dexp(-x2))
+ facT3=licznik/dlog(dexp(x3)+dexp(-x3))
+ facT4=licznik/dlog(dexp(x4)+dexp(-x4))
+ facT5=licznik/dlog(dexp(x5)+dexp(-x5))
+ else
+ write (iout,*) "Wrong RESCALE_MODE",rescale_mode
+ write (*,*) "Wrong RESCALE_MODE",rescale_mode
+#ifdef MPI
+ call MPI_Finalize(MPI_COMM_WORLD,IERROR)
+#endif
+ stop 555
+ endif
+ welec=weights(3)*fact
+ wcorr=weights(4)*fact3
+ wcorr5=weights(5)*fact4
+ wcorr6=weights(6)*fact5
+ wel_loc=weights(7)*fact2
+ wturn3=weights(8)*fact2
+ wturn4=weights(9)*fact3
+ wturn6=weights(10)*fact5
+ wtor=weights(13)*fact
+ wtor_d=weights(14)*fact2
+ wsccor=weights(21)*fact
+#ifdef TSCSC
+c wsct=t_bath/temp0
+ wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
+#endif
+ return
+ end
+C------------------------------------------------------------------------
+ subroutine enerprint(energia)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.FFIELD'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.MD'
+ double precision energia(0:n_ene)
+ etot=energia(0)
+#ifdef TSCSC
+ evdw=energia(22)+wsct*energia(23)
+#else
+ evdw=energia(1)
+#endif
+ evdw2=energia(2)
+#ifdef SCP14
+ evdw2=energia(2)+energia(18)
+#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)
+ edihcnstr=energia(19)
+ estr=energia(17)
+ Uconst=energia(20)
+ esccor=energia(21)
+#ifdef SPLITELE
+ write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
+ & estr,wbond,ebe,wang,
+ & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
+ & ecorr,wcorr,
+ & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
+ & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
+ & edihcnstr,ebr*nss,
+ & Uconst,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)'/
+ & '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)'/
+ & 'EHPB= ',1pE16.6,' WEIGHT=',1pD16.6,
+ & ' (SS bridges & dist. cnstr.)'/
+ & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
+ & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
+ & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
+ & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
+ & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
+ & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
+ & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
+ & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
+ & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
+ & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
+ & 'UCONST= ',1pE16.6,' (Constraint energy)'/
+ & 'ETOT= ',1pE16.6,' (total)')
+#else
+ write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
+ & estr,wbond,ebe,wang,
+ & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
+ & ecorr,wcorr,
+ & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
+ & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
+ & ebr*nss,Uconst,etot
+ 10 format (/'Virtual-chain energies:'//
+ & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
+ & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
+ & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
+ & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
+ & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
+ & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
+ & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
+ & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
+ & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6,
+ & ' (SS bridges & dist. cnstr.)'/
+ & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
+ & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
+ & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
+ & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
+ & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
+ & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
+ & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
+ & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
+ & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
+ & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
+ & 'UCONST=',1pE16.6,' (Constraint energy)'/
+ & 'ETOT= ',1pE16.6,' (total)')
+#endif
+ return
+ end
+C-----------------------------------------------------------------------
+ subroutine elj(evdw,evdw_p,evdw_m)
+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'
+ 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)
+c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
+ evdw=0.0D0
+ do i=iatsc_s,iatsc_e
+ itypi=itype(i)
+ itypi1=itype(i+1)
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+C Change 12/1/95
+ num_conti=0
+C
+C Calculate SC interaction energy.
+C
+ do iint=1,nint_gr(i)
+cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
+cd & 'iend=',iend(i,iint)
+ do j=istart(i,iint),iend(i,iint)
+ itypj=itype(j)
+ xj=c(1,nres+j)-xi
+ yj=c(2,nres+j)-yi
+ zj=c(3,nres+j)-zi
+C Change 12/1/95 to calculate four-body interactions
+ rij=xj*xj+yj*yj+zj*zj
+ rrij=1.0D0/rij
+c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
+ eps0ij=eps(itypi,itypj)
+ fac=rrij**expon2
+ e1=fac*fac*aa(itypi,itypj)
+ e2=fac*bb(itypi,itypj)
+ evdwij=e1+e2
+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)
+#ifdef TSCSC
+ if (bb(itypi,itypj).gt.0) then
+ evdw_p=evdw_p+evdwij
+ else
+ evdw_m=evdw_m+evdwij
+ endif
+#else
+ evdw=evdw+evdwij
+#endif
+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
+#ifdef TSCSC
+ if (bb(itypi,itypj).gt.0.0d0) then
+ do k=1,3
+ gvdwx(k,i)=gvdwx(k,i)-gg(k)
+ gvdwx(k,j)=gvdwx(k,j)+gg(k)
+ gvdwc(k,i)=gvdwc(k,i)-gg(k)
+ gvdwc(k,j)=gvdwc(k,j)+gg(k)
+ enddo
+ else
+ do k=1,3
+ gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
+ gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
+ gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
+ gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
+ enddo
+ endif
+#else
+ do k=1,3
+ gvdwx(k,i)=gvdwx(k,i)-gg(k)
+ gvdwx(k,j)=gvdwx(k,j)+gg(k)
+ gvdwc(k,i)=gvdwc(k,i)-gg(k)
+ gvdwc(k,j)=gvdwc(k,j)+gg(k)
+ enddo
+#endif
+cgrad do k=i,j-1
+cgrad do l=1,3
+cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
+cgrad enddo
+cgrad enddo
+C
+C 12/1/95, revised on 5/20/97
+C
+C Calculate the contact function. The ith column of the array JCONT will
+C contain the numbers of atoms that make contacts with the atom I (of numbers
+C greater than I). The arrays FACONT and GACONT will contain the values of
+C the contact function and its derivative.
+C
+C Uncomment next line, if the correlation interactions include EVDW explicitly.
+c if (j.gt.i+1 .and. evdwij.le.0.0D0) then
+C Uncomment next line, if the correlation interactions are contact function only
+ if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
+ rij=dsqrt(rij)
+ sigij=sigma(itypi,itypj)
+ r0ij=rs0(itypi,itypj)
+C
+C Check whether the SC's are not too far to make a contact.
+C
+ rcut=1.5d0*r0ij
+ call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
+C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
+C
+ if (fcont.gt.0.0D0) then
+C If the SC-SC distance if close to sigma, apply spline.
+cAdam call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
+cAdam & fcont1,fprimcont1)
+cAdam fcont1=1.0d0-fcont1
+cAdam if (fcont1.gt.0.0d0) then
+cAdam fprimcont=fprimcont*fcont1+fcont*fprimcont1
+cAdam fcont=fcont*fcont1
+cAdam endif
+C Uncomment following 4 lines to have the geometric average of the epsilon0's
+cga eps0ij=1.0d0/dsqrt(eps0ij)
+cga do k=1,3
+cga gg(k)=gg(k)*eps0ij
+cga enddo
+cga eps0ij=-evdwij*eps0ij
+C Uncomment for AL's type of SC correlation interactions.
+cadam eps0ij=-evdwij
+ num_conti=num_conti+1
+ jcont(num_conti,i)=j
+ facont(num_conti,i)=fcont*eps0ij
+ fprimcont=eps0ij*fprimcont/rij
+ fcont=expon*fcont
+cAdam gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
+cAdam gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
+cAdam gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
+C Uncomment following 3 lines for Skolnick's type of SC correlation.
+ gacont(1,num_conti,i)=-fprimcont*xj
+ gacont(2,num_conti,i)=-fprimcont*yj
+ gacont(3,num_conti,i)=-fprimcont*zj
+cd write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
+cd write (iout,'(2i3,3f10.5)')
+cd & i,j,(gacont(kk,num_conti,i),kk=1,3)
+ endif
+ endif
+ enddo ! j
+ enddo ! iint
+C Change 12/1/95
+ num_cont(i)=num_conti
+ enddo ! i
+ do i=1,nct
+ do j=1,3
+ gvdwc(j,i)=expon*gvdwc(j,i)
+ gvdwx(j,i)=expon*gvdwx(j,i)
+ enddo
+ enddo
+C******************************************************************************
+C
+C N O T E !!!
+C
+C To save time, the factor of EXPON has been extracted from ALL components
+C of GVDWC and GRADX. Remember to multiply them by this factor before further
+C use!
+C
+C******************************************************************************
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine eljk(evdw,evdw_p,evdw_m)
+C
+C This subroutine calculates the interaction energy of nonbonded side chains
+C assuming the LJK potential of interaction.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ dimension gg(3)
+ logical scheck
+c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
+ evdw=0.0D0
+ do i=iatsc_s,iatsc_e
+ itypi=itype(i)
+ itypi1=itype(i+1)
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+C
+C Calculate SC interaction energy.
+C
+ do iint=1,nint_gr(i)
+ do j=istart(i,iint),iend(i,iint)
+ itypj=itype(j)
+ xj=c(1,nres+j)-xi
+ yj=c(2,nres+j)-yi
+ zj=c(3,nres+j)-zi
+ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
+ fac_augm=rrij**expon
+ e_augm=augm(itypi,itypj)*fac_augm
+ r_inv_ij=dsqrt(rrij)
+ rij=1.0D0/r_inv_ij
+ r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
+ fac=r_shift_inv**expon
+ e1=fac*fac*aa(itypi,itypj)
+ e2=fac*bb(itypi,itypj)
+ evdwij=e_augm+e1+e2
+cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
+cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
+cd write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
+cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
+cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
+cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
+cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
+#ifdef TSCSC
+ if (bb(itypi,itypj).gt.0) then
+ evdw_p=evdw_p+evdwij
+ else
+ evdw_m=evdw_m+evdwij
+ endif
+#else
+ evdw=evdw+evdwij
+#endif
+C
+C Calculate the components of the gradient in DC and X
+C
+ fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
+ gg(1)=xj*fac
+ gg(2)=yj*fac
+ gg(3)=zj*fac
+#ifdef TSCSC
+ if (bb(itypi,itypj).gt.0.0d0) then
+ do k=1,3
+ gvdwx(k,i)=gvdwx(k,i)-gg(k)
+ gvdwx(k,j)=gvdwx(k,j)+gg(k)
+ gvdwc(k,i)=gvdwc(k,i)-gg(k)
+ gvdwc(k,j)=gvdwc(k,j)+gg(k)
+ enddo
+ else
+ do k=1,3
+ gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
+ gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
+ gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
+ gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
+ enddo
+ endif
+#else
+ do k=1,3
+ gvdwx(k,i)=gvdwx(k,i)-gg(k)
+ gvdwx(k,j)=gvdwx(k,j)+gg(k)
+ gvdwc(k,i)=gvdwc(k,i)-gg(k)
+ gvdwc(k,j)=gvdwc(k,j)+gg(k)
+ enddo
+#endif
+cgrad do k=i,j-1
+cgrad do l=1,3
+cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
+cgrad enddo
+cgrad enddo
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+ do i=1,nct
+ do j=1,3
+ gvdwc(j,i)=expon*gvdwc(j,i)
+ gvdwx(j,i)=expon*gvdwx(j,i)
+ enddo
+ enddo
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine ebp(evdw,evdw_p,evdw_m)
+C
+C This subroutine calculates the interaction energy of nonbonded side chains
+C assuming the Berne-Pechukas potential of interaction.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.NAMES'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CALC'
+ common /srutu/ icall
+c double precision rrsave(maxdim)
+ logical lprn
+ evdw=0.0D0
+c print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
+ evdw=0.0D0
+c if (icall.eq.0) then
+c lprn=.true.
+c else
+ lprn=.false.
+c endif
+ ind=0
+ do i=iatsc_s,iatsc_e
+ itypi=itype(i)
+ itypi1=itype(i+1)
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+ dxi=dc_norm(1,nres+i)
+ dyi=dc_norm(2,nres+i)
+ dzi=dc_norm(3,nres+i)
+c dsci_inv=dsc_inv(itypi)
+ dsci_inv=vbld_inv(i+nres)
+C
+C Calculate SC interaction energy.
+C
+ do iint=1,nint_gr(i)
+ do j=istart(i,iint),iend(i,iint)
+ ind=ind+1
+ itypj=itype(j)
+c dscj_inv=dsc_inv(itypj)
+ dscj_inv=vbld_inv(j+nres)
+ chi1=chi(itypi,itypj)
+ chi2=chi(itypj,itypi)
+ chi12=chi1*chi2
+ chip1=chip(itypi)
+ chip2=chip(itypj)
+ chip12=chip1*chip2
+ alf1=alp(itypi)
+ alf2=alp(itypj)
+ alf12=0.5D0*(alf1+alf2)
+C For diagnostics only!!!
+c chi1=0.0D0
+c chi2=0.0D0
+c chi12=0.0D0
+c chip1=0.0D0
+c chip2=0.0D0
+c chip12=0.0D0
+c alf1=0.0D0
+c alf2=0.0D0
+c alf12=0.0D0
+ xj=c(1,nres+j)-xi
+ yj=c(2,nres+j)-yi
+ zj=c(3,nres+j)-zi
+ dxj=dc_norm(1,nres+j)
+ dyj=dc_norm(2,nres+j)
+ dzj=dc_norm(3,nres+j)
+ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
+cd if (icall.eq.0) then
+cd rrsave(ind)=rrij
+cd else
+cd rrij=rrsave(ind)
+cd endif
+ rij=dsqrt(rrij)
+C Calculate the angle-dependent terms of energy & contributions to derivatives.
+ call sc_angular
+C Calculate whole angle-dependent part of epsilon and contributions
+C to its derivatives
+ fac=(rrij*sigsq)**expon2
+ e1=fac*fac*aa(itypi,itypj)
+ e2=fac*bb(itypi,itypj)
+ evdwij=eps1*eps2rt*eps3rt*(e1+e2)
+ eps2der=evdwij*eps3rt
+ eps3der=evdwij*eps2rt
+ evdwij=evdwij*eps2rt*eps3rt
+#ifdef TSCSC
+ if (bb(itypi,itypj).gt.0) then
+ evdw_p=evdw_p+evdwij
+ else
+ evdw_m=evdw_m+evdwij
+ endif
+#else
+ evdw=evdw+evdwij
+#endif
+ if (lprn) then
+ sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
+ epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
+cd write (iout,'(2(a3,i3,2x),15(0pf7.3))')
+cd & restyp(itypi),i,restyp(itypj),j,
+cd & epsi,sigm,chi1,chi2,chip1,chip2,
+cd & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
+cd & om1,om2,om12,1.0D0/dsqrt(rrij),
+cd & evdwij
+ endif
+C Calculate gradient components.
+ e1=e1*eps1*eps2rt**2*eps3rt**2
+ fac=-expon*(e1+evdwij)
+ sigder=fac/sigsq
+ fac=rrij*fac
+C Calculate radial part of the gradient
+ gg(1)=xj*fac
+ gg(2)=yj*fac
+ gg(3)=zj*fac
+C Calculate the angular part of the gradient and sum add the contributions
+C to the appropriate components of the Cartesian gradient.
+#ifdef TSCSC
+ if (bb(itypi,itypj).gt.0) then
+ call sc_grad
+ else
+ call sc_grad_T
+ endif
+#else
+ call sc_grad
+#endif
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+c stop
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine egb(evdw,evdw_p,evdw_m)
+C
+C This subroutine calculates the interaction energy of nonbonded side chains
+C assuming the Gay-Berne potential of interaction.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.NAMES'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CALC'
+ include 'COMMON.CONTROL'
+ logical lprn
+ evdw=0.0D0
+ccccc energy_dec=.false.
+c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
+ evdw=0.0D0
+ evdw_p=0.0D0
+ evdw_m=0.0D0
+ lprn=.false.
+c if (icall.eq.0) lprn=.false.
+ ind=0
+ do i=iatsc_s,iatsc_e
+ itypi=itype(i)
+ itypi1=itype(i+1)
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+ dxi=dc_norm(1,nres+i)
+ dyi=dc_norm(2,nres+i)
+ dzi=dc_norm(3,nres+i)
+c dsci_inv=dsc_inv(itypi)
+ dsci_inv=vbld_inv(i+nres)
+c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
+c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
+C
+C Calculate SC interaction energy.
+C
+ do iint=1,nint_gr(i)
+ do j=istart(i,iint),iend(i,iint)
+ ind=ind+1
+ itypj=itype(j)
+c dscj_inv=dsc_inv(itypj)
+ dscj_inv=vbld_inv(j+nres)
+c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
+c & 1.0d0/vbld(j+nres)
+c write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
+ sig0ij=sigma(itypi,itypj)
+ chi1=chi(itypi,itypj)
+ chi2=chi(itypj,itypi)
+ chi12=chi1*chi2
+ chip1=chip(itypi)
+ chip2=chip(itypj)
+ chip12=chip1*chip2
+ alf1=alp(itypi)
+ alf2=alp(itypj)
+ alf12=0.5D0*(alf1+alf2)
+C For diagnostics only!!!
+c chi1=0.0D0
+c chi2=0.0D0
+c chi12=0.0D0
+c chip1=0.0D0
+c chip2=0.0D0
+c chip12=0.0D0
+c alf1=0.0D0
+c alf2=0.0D0
+c alf12=0.0D0
+ xj=c(1,nres+j)-xi
+ yj=c(2,nres+j)-yi
+ zj=c(3,nres+j)-zi
+ dxj=dc_norm(1,nres+j)
+ dyj=dc_norm(2,nres+j)
+ dzj=dc_norm(3,nres+j)
+c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
+c write (iout,*) "j",j," dc_norm",
+c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
+ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
+ rij=dsqrt(rrij)
+C Calculate angle-dependent terms of energy and contributions to their
+C derivatives.
+ call sc_angular
+ sigsq=1.0D0/sigsq
+ sig=sig0ij*dsqrt(sigsq)
+ rij_shift=1.0D0/rij-sig+sig0ij
+c for diagnostics; uncomment
+c rij_shift=1.2*sig0ij
+C I hate to put IF's in the loops, but here don't have another choice!!!!
+ if (rij_shift.le.0.0D0) then
+ evdw=1.0D20
+cd write (iout,'(2(a3,i3,2x),17(0pf7.3))')
+cd & restyp(itypi),i,restyp(itypj),j,
+cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
+ return
+ endif
+ sigder=-sig*sigsq
+c---------------------------------------------------------------
+ rij_shift=1.0D0/rij_shift
+ fac=rij_shift**expon
+ e1=fac*fac*aa(itypi,itypj)
+ e2=fac*bb(itypi,itypj)
+ evdwij=eps1*eps2rt*eps3rt*(e1+e2)
+ eps2der=evdwij*eps3rt
+ eps3der=evdwij*eps2rt
+c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
+c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
+ evdwij=evdwij*eps2rt*eps3rt
+#ifdef TSCSC
+ if (bb(itypi,itypj).gt.0) then
+ evdw_p=evdw_p+evdwij
+ else
+ evdw_m=evdw_m+evdwij
+ endif
+#else
+ evdw=evdw+evdwij
+#endif
+ if (lprn) then
+ sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
+ epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
+ write (iout,'(2(a3,i3,2x),17(0pf7.3))')
+ & restyp(itypi),i,restyp(itypj),j,
+ & epsi,sigm,chi1,chi2,chip1,chip2,
+ & eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
+ & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
+ & evdwij
+ endif
+
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
+ & 'evdw',i,j,evdwij
+
+C Calculate gradient components.
+ e1=e1*eps1*eps2rt**2*eps3rt**2
+ fac=-expon*(e1+evdwij)*rij_shift
+ sigder=fac*sigder
+ fac=rij*fac
+c fac=0.0d0
+C Calculate the radial part of the gradient
+ gg(1)=xj*fac
+ gg(2)=yj*fac
+ gg(3)=zj*fac
+C Calculate angular part of the gradient.
+#ifdef TSCSC
+ if (bb(itypi,itypj).gt.0) then
+ call sc_grad
+ else
+ call sc_grad_T
+ endif
+#else
+ call sc_grad
+#endif
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+c write (iout,*) "Number of loop steps in EGB:",ind
+cccc energy_dec=.false.
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine egbv(evdw,evdw_p,evdw_m)
+C
+C This subroutine calculates the interaction energy of nonbonded side chains
+C assuming the Gay-Berne-Vorobjev potential of interaction.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.NAMES'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CALC'
+ common /srutu/ icall
+ logical lprn
+ evdw=0.0D0
+c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
+ evdw=0.0D0
+ lprn=.false.
+c if (icall.eq.0) lprn=.true.
+ ind=0
+ do i=iatsc_s,iatsc_e
+ itypi=itype(i)
+ itypi1=itype(i+1)
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+ dxi=dc_norm(1,nres+i)
+ dyi=dc_norm(2,nres+i)
+ dzi=dc_norm(3,nres+i)
+c dsci_inv=dsc_inv(itypi)
+ dsci_inv=vbld_inv(i+nres)
+C
+C Calculate SC interaction energy.
+C
+ do iint=1,nint_gr(i)
+ do j=istart(i,iint),iend(i,iint)
+ ind=ind+1
+ itypj=itype(j)
+c dscj_inv=dsc_inv(itypj)
+ dscj_inv=vbld_inv(j+nres)
+ sig0ij=sigma(itypi,itypj)
+ r0ij=r0(itypi,itypj)
+ chi1=chi(itypi,itypj)
+ chi2=chi(itypj,itypi)
+ chi12=chi1*chi2
+ chip1=chip(itypi)
+ chip2=chip(itypj)
+ chip12=chip1*chip2
+ alf1=alp(itypi)
+ alf2=alp(itypj)
+ alf12=0.5D0*(alf1+alf2)
+C For diagnostics only!!!
+c chi1=0.0D0
+c chi2=0.0D0
+c chi12=0.0D0
+c chip1=0.0D0
+c chip2=0.0D0
+c chip12=0.0D0
+c alf1=0.0D0
+c alf2=0.0D0
+c alf12=0.0D0
+ xj=c(1,nres+j)-xi
+ yj=c(2,nres+j)-yi
+ zj=c(3,nres+j)-zi
+ dxj=dc_norm(1,nres+j)
+ dyj=dc_norm(2,nres+j)
+ dzj=dc_norm(3,nres+j)
+ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
+ rij=dsqrt(rrij)
+C Calculate angle-dependent terms of energy and contributions to their
+C derivatives.
+ call sc_angular
+ sigsq=1.0D0/sigsq
+ sig=sig0ij*dsqrt(sigsq)
+ rij_shift=1.0D0/rij-sig+r0ij
+C I hate to put IF's in the loops, but here don't have another choice!!!!
+ if (rij_shift.le.0.0D0) then
+ evdw=1.0D20
+ return
+ endif
+ sigder=-sig*sigsq
+c---------------------------------------------------------------
+ rij_shift=1.0D0/rij_shift
+ fac=rij_shift**expon
+ e1=fac*fac*aa(itypi,itypj)
+ e2=fac*bb(itypi,itypj)
+ evdwij=eps1*eps2rt*eps3rt*(e1+e2)
+ eps2der=evdwij*eps3rt
+ eps3der=evdwij*eps2rt
+ fac_augm=rrij**expon
+ e_augm=augm(itypi,itypj)*fac_augm
+ evdwij=evdwij*eps2rt*eps3rt
+#ifdef TSCSC
+ if (bb(itypi,itypj).gt.0) then
+ evdw_p=evdw_p+evdwij+e_augm
+ else
+ evdw_m=evdw_m+evdwij+e_augm
+ endif
+#else
+ evdw=evdw+evdwij+e_augm
+#endif
+ if (lprn) then
+ sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
+ epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
+ write (iout,'(2(a3,i3,2x),17(0pf7.3))')
+ & restyp(itypi),i,restyp(itypj),j,
+ & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
+ & chi1,chi2,chip1,chip2,
+ & eps1,eps2rt**2,eps3rt**2,
+ & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
+ & evdwij+e_augm
+ endif
+C Calculate gradient components.
+ e1=e1*eps1*eps2rt**2*eps3rt**2
+ fac=-expon*(e1+evdwij)*rij_shift
+ sigder=fac*sigder
+ fac=rij*fac-2*expon*rrij*e_augm
+C Calculate the radial part of the gradient
+ gg(1)=xj*fac
+ gg(2)=yj*fac
+ gg(3)=zj*fac
+C Calculate angular part of the gradient.
+#ifdef TSCSC
+ if (bb(itypi,itypj).gt.0) then
+ call sc_grad
+ else
+ call sc_grad_T
+ endif
+#else
+ call sc_grad
+#endif
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+ end
+C-----------------------------------------------------------------------------
+ subroutine sc_angular
+C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
+C om12. Called by ebp, egb, and egbv.
+ implicit none
+ include 'COMMON.CALC'
+ include 'COMMON.IOUNITS'
+ erij(1)=xj*rij
+ erij(2)=yj*rij
+ erij(3)=zj*rij
+ om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
+ om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
+ om12=dxi*dxj+dyi*dyj+dzi*dzj
+ chiom12=chi12*om12
+C Calculate eps1(om12) and its derivative in om12
+ faceps1=1.0D0-om12*chiom12
+ faceps1_inv=1.0D0/faceps1
+ eps1=dsqrt(faceps1_inv)
+C Following variable is eps1*deps1/dom12
+ eps1_om12=faceps1_inv*chiom12
+c diagnostics only
+c faceps1_inv=om12
+c eps1=om12
+c eps1_om12=1.0d0
+c write (iout,*) "om12",om12," eps1",eps1
+C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
+C and om12.
+ om1om2=om1*om2
+ chiom1=chi1*om1
+ chiom2=chi2*om2
+ facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
+ sigsq=1.0D0-facsig*faceps1_inv
+ sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
+ sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
+ sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
+c diagnostics only
+c sigsq=1.0d0
+c sigsq_om1=0.0d0
+c sigsq_om2=0.0d0
+c sigsq_om12=0.0d0
+c write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
+c write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
+c & " eps1",eps1
+C Calculate eps2 and its derivatives in om1, om2, and om12.
+ chipom1=chip1*om1
+ chipom2=chip2*om2
+ chipom12=chip12*om12
+ facp=1.0D0-om12*chipom12
+ facp_inv=1.0D0/facp
+ facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
+c write (iout,*) "chipom1",chipom1," chipom2",chipom2,
+c & " chipom12",chipom12," facp",facp," facp_inv",facp_inv
+C Following variable is the square root of eps2
+ eps2rt=1.0D0-facp1*facp_inv
+C Following three variables are the derivatives of the square root of eps
+C in om1, om2, and om12.
+ eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
+ eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
+ eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
+C Evaluate the "asymmetric" factor in the VDW constant, eps3
+ eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
+c write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
+c write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
+c & " eps2rt_om12",eps2rt_om12
+C Calculate whole angle-dependent part of epsilon and contributions
+C to its derivatives
+ return
+ end
+
+C----------------------------------------------------------------------------
+ subroutine sc_grad_T
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.CALC'
+ include 'COMMON.IOUNITS'
+ double precision dcosom1(3),dcosom2(3)
+ eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
+ eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
+ eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
+ & -2.0D0*alf12*eps3der+sigder*sigsq_om12
+c diagnostics only
+c eom1=0.0d0
+c eom2=0.0d0
+c eom12=evdwij*eps1_om12
+c end diagnostics
+c write (iout,*) "eps2der",eps2der," eps3der",eps3der,
+c & " sigder",sigder
+c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
+c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
+ do k=1,3
+ dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
+ dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
+ enddo
+ do k=1,3
+ gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
+ enddo
+c write (iout,*) "gg",(gg(k),k=1,3)
+ do k=1,3
+ gvdwxT(k,i)=gvdwxT(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
+ gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
+ & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
+ & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
+c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
+c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
+c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
+c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
+ enddo
+C
+C Calculate the components of the gradient in DC and X
+C
+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
+ gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
+ gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
+ enddo
+ return
+ end
+
+C----------------------------------------------------------------------------
+ subroutine sc_grad
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.CALC'
+ include 'COMMON.IOUNITS'
+ double precision dcosom1(3),dcosom2(3)
+ eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
+ eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
+ eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
+ & -2.0D0*alf12*eps3der+sigder*sigsq_om12
+c diagnostics only
+c eom1=0.0d0
+c eom2=0.0d0
+c eom12=evdwij*eps1_om12
+c end diagnostics
+c write (iout,*) "eps2der",eps2der," eps3der",eps3der,
+c & " sigder",sigder
+c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
+c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
+ do k=1,3
+ dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
+ dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
+ enddo
+ do k=1,3
+ gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
+ enddo
+c write (iout,*) "gg",(gg(k),k=1,3)
+ 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
+c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
+c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
+c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
+c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
+ enddo
+C
+C Calculate the components of the gradient in DC and X
+C
+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-----------------------------------------------------------------------
+ subroutine e_softsphere(evdw)
+C
+C This subroutine calculates the interaction energy of nonbonded side chains
+C assuming the LJ potential of interaction.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ 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)
+cd print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
+ evdw=0.0D0
+ do i=iatsc_s,iatsc_e
+ itypi=itype(i)
+ itypi1=itype(i+1)
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+C
+C Calculate SC interaction energy.
+C
+ do iint=1,nint_gr(i)
+cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
+cd & 'iend=',iend(i,iint)
+ do j=istart(i,iint),iend(i,iint)
+ itypj=itype(j)
+ xj=c(1,nres+j)-xi
+ yj=c(2,nres+j)-yi
+ zj=c(3,nres+j)-zi
+ rij=xj*xj+yj*yj+zj*zj
+c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
+ r0ij=r0(itypi,itypj)
+ r0ijsq=r0ij*r0ij
+c print *,i,j,r0ij,dsqrt(rij)
+ if (rij.lt.r0ijsq) then
+ evdwij=0.25d0*(rij-r0ijsq)**2
+ fac=rij-r0ijsq
+ else
+ evdwij=0.0d0
+ fac=0.0d0
+ endif
+ evdw=evdw+evdwij
+C
+C Calculate the components of the gradient in DC and X
+C
+ 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)
+ gvdwc(k,i)=gvdwc(k,i)-gg(k)
+ gvdwc(k,j)=gvdwc(k,j)+gg(k)
+ 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
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+ return
+ end
+C--------------------------------------------------------------------------
+ subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
+ & eello_turn4)
+C
+C Soft-sphere potential of p-p interaction
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.TORSION'
+ include 'COMMON.VECTORS'
+ include 'COMMON.FFIELD'
+ dimension ggg(3)
+cd write(iout,*) 'In EELEC_soft_sphere'
+ ees=0.0D0
+ evdw1=0.0D0
+ eel_loc=0.0d0
+ eello_turn3=0.0d0
+ eello_turn4=0.0d0
+ ind=0
+ do i=iatel_s,iatel_e
+ dxi=dc(1,i)
+ dyi=dc(2,i)
+ dzi=dc(3,i)
+ xmedi=c(1,i)+0.5d0*dxi
+ ymedi=c(2,i)+0.5d0*dyi
+ zmedi=c(3,i)+0.5d0*dzi
+ num_conti=0
+c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
+ do j=ielstart(i),ielend(i)
+ ind=ind+1
+ iteli=itel(i)
+ itelj=itel(j)
+ if (j.eq.i+2 .and. itelj.eq.2) iteli=2
+ r0ij=rpp(iteli,itelj)
+ r0ijsq=r0ij*r0ij
+ dxj=dc(1,j)
+ dyj=dc(2,j)
+ dzj=dc(3,j)
+ xj=c(1,j)+0.5D0*dxj-xmedi
+ yj=c(2,j)+0.5D0*dyj-ymedi
+ zj=c(3,j)+0.5D0*dzj-zmedi
+ rij=xj*xj+yj*yj+zj*zj
+ if (rij.lt.r0ijsq) then
+ evdw1ij=0.25d0*(rij-r0ijsq)**2
+ fac=rij-r0ijsq
+ else
+ evdw1ij=0.0d0
+ fac=0.0d0
+ endif
+ evdw1=evdw1+evdw1ij
+C
+C Calculate contributions to the Cartesian gradient.
+C
+ ggg(1)=fac*xj
+ ggg(2)=fac*yj
+ ggg(3)=fac*zj
+ do k=1,3
+ gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
+ gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
+ enddo
+*
+* Loop over residues i+1 thru j-1.
+*
+cgrad do k=i+1,j-1
+cgrad do l=1,3
+cgrad gelc(l,k)=gelc(l,k)+ggg(l)
+cgrad enddo
+cgrad enddo
+ enddo ! j
+ enddo ! i
+cgrad do i=nnt,nct-1
+cgrad do k=1,3
+cgrad gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
+cgrad enddo
+cgrad do j=i+1,nct-1
+cgrad do k=1,3
+cgrad gelc(k,i)=gelc(k,i)+gelc(k,j)
+cgrad enddo
+cgrad enddo
+cgrad enddo
+ return
+ end
+c------------------------------------------------------------------------------
+ subroutine vec_and_deriv
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.VECTORS'
+ include 'COMMON.SETUP'
+ include 'COMMON.TIME1'
+ dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
+C Compute the local reference systems. For reference system (i), the
+C X-axis points from CA(i) to CA(i+1), the Y axis is in the
+C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
+#ifdef PARVEC
+ do i=ivec_start,ivec_end
+#else
+ do i=1,nres-1
+#endif
+ if (i.eq.nres-1) then
+C Case of the last full residue
+C Compute the Z-axis
+ call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
+ costh=dcos(pi-theta(nres))
+ fac=1.0d0/dsqrt(1.0d0-costh*costh)
+ do k=1,3
+ uz(k,i)=fac*uz(k,i)
+ enddo
+C Compute the derivatives of uz
+ uzder(1,1,1)= 0.0d0
+ uzder(2,1,1)=-dc_norm(3,i-1)
+ uzder(3,1,1)= dc_norm(2,i-1)
+ uzder(1,2,1)= dc_norm(3,i-1)
+ uzder(2,2,1)= 0.0d0
+ uzder(3,2,1)=-dc_norm(1,i-1)
+ uzder(1,3,1)=-dc_norm(2,i-1)
+ uzder(2,3,1)= dc_norm(1,i-1)
+ uzder(3,3,1)= 0.0d0
+ uzder(1,1,2)= 0.0d0
+ uzder(2,1,2)= dc_norm(3,i)
+ uzder(3,1,2)=-dc_norm(2,i)
+ uzder(1,2,2)=-dc_norm(3,i)
+ uzder(2,2,2)= 0.0d0
+ uzder(3,2,2)= dc_norm(1,i)
+ uzder(1,3,2)= dc_norm(2,i)
+ uzder(2,3,2)=-dc_norm(1,i)
+ uzder(3,3,2)= 0.0d0
+C Compute the Y-axis
+ facy=fac
+ do k=1,3
+ uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
+ enddo
+C Compute the derivatives of uy
+ do j=1,3
+ do k=1,3
+ uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
+ & -dc_norm(k,i)*dc_norm(j,i-1)
+ uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
+ enddo
+ uyder(j,j,1)=uyder(j,j,1)-costh
+ uyder(j,j,2)=1.0d0+uyder(j,j,2)
+ enddo
+ do j=1,2
+ do k=1,3
+ do l=1,3
+ uygrad(l,k,j,i)=uyder(l,k,j)
+ uzgrad(l,k,j,i)=uzder(l,k,j)
+ enddo
+ enddo
+ enddo
+ call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
+ call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
+ call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
+ call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
+ else
+C Other residues
+C Compute the Z-axis
+ call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
+ costh=dcos(pi-theta(i+2))
+ fac=1.0d0/dsqrt(1.0d0-costh*costh)
+ do k=1,3
+ uz(k,i)=fac*uz(k,i)
+ enddo
+C Compute the derivatives of uz
+ uzder(1,1,1)= 0.0d0
+ uzder(2,1,1)=-dc_norm(3,i+1)
+ uzder(3,1,1)= dc_norm(2,i+1)
+ uzder(1,2,1)= dc_norm(3,i+1)
+ uzder(2,2,1)= 0.0d0
+ uzder(3,2,1)=-dc_norm(1,i+1)
+ uzder(1,3,1)=-dc_norm(2,i+1)
+ uzder(2,3,1)= dc_norm(1,i+1)
+ uzder(3,3,1)= 0.0d0
+ uzder(1,1,2)= 0.0d0
+ uzder(2,1,2)= dc_norm(3,i)
+ uzder(3,1,2)=-dc_norm(2,i)
+ uzder(1,2,2)=-dc_norm(3,i)
+ uzder(2,2,2)= 0.0d0
+ uzder(3,2,2)= dc_norm(1,i)
+ uzder(1,3,2)= dc_norm(2,i)
+ uzder(2,3,2)=-dc_norm(1,i)
+ uzder(3,3,2)= 0.0d0
+C Compute the Y-axis
+ facy=fac
+ do k=1,3
+ uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
+ enddo
+C Compute the derivatives of uy
+ do j=1,3
+ do k=1,3
+ uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
+ & -dc_norm(k,i)*dc_norm(j,i+1)
+ uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
+ enddo
+ uyder(j,j,1)=uyder(j,j,1)-costh
+ uyder(j,j,2)=1.0d0+uyder(j,j,2)
+ enddo
+ do j=1,2
+ do k=1,3
+ do l=1,3
+ uygrad(l,k,j,i)=uyder(l,k,j)
+ uzgrad(l,k,j,i)=uzder(l,k,j)
+ enddo
+ enddo
+ enddo
+ call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
+ call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
+ call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
+ call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
+ endif
+ enddo
+ do i=1,nres-1
+ vbld_inv_temp(1)=vbld_inv(i+1)
+ if (i.lt.nres-1) then
+ vbld_inv_temp(2)=vbld_inv(i+2)
+ else
+ vbld_inv_temp(2)=vbld_inv(i)
+ endif
+ do j=1,2
+ do k=1,3
+ do l=1,3
+ uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
+ uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
+ enddo
+ enddo
+ enddo
+ enddo
+#if defined(PARVEC) && defined(MPI)
+ if (nfgtasks1.gt.1) then
+ time00=MPI_Wtime()
+c print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
+c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
+c & " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
+ call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
+ & ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
+ & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
+ call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
+ & ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
+ & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
+ time_gather=time_gather+MPI_Wtime()-time00
+ endif
+c if (fg_rank.eq.0) then
+c write (iout,*) "Arrays UY and UZ"
+c do i=1,nres-1
+c write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
+c & (uz(k,i),k=1,3)
+c enddo
+c endif
+#endif
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine check_vecgrad
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.VECTORS'
+ dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
+ dimension uyt(3,maxres),uzt(3,maxres)
+ dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
+ double precision delta /1.0d-7/
+ call vec_and_deriv
+cd do i=1,nres
+crc write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
+crc write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
+crc write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
+cd write(iout,'(2i5,2(3f10.5,5x))') i,1,
+cd & (dc_norm(if90,i),if90=1,3)
+cd write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
+cd write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
+cd write(iout,'(a)')
+cd enddo
+ do i=1,nres
+ do j=1,2
+ do k=1,3
+ do l=1,3
+ uygradt(l,k,j,i)=uygrad(l,k,j,i)
+ uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
+ enddo
+ enddo
+ enddo
+ enddo
+ call vec_and_deriv
+ do i=1,nres
+ do j=1,3
+ uyt(j,i)=uy(j,i)
+ uzt(j,i)=uz(j,i)
+ enddo
+ enddo
+ do i=1,nres
+cd write (iout,*) 'i=',i
+ do k=1,3
+ erij(k)=dc_norm(k,i)
+ enddo
+ do j=1,3
+ do k=1,3
+ dc_norm(k,i)=erij(k)
+ enddo
+ dc_norm(j,i)=dc_norm(j,i)+delta
+c fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
+c do k=1,3
+c dc_norm(k,i)=dc_norm(k,i)/fac
+c enddo
+c write (iout,*) (dc_norm(k,i),k=1,3)
+c write (iout,*) (erij(k),k=1,3)
+ call vec_and_deriv
+ do k=1,3
+ uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
+ uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
+ uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
+ uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
+ enddo
+c write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
+c & j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
+c & (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
+ enddo
+ do k=1,3
+ dc_norm(k,i)=erij(k)
+ enddo
+cd do k=1,3
+cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
+cd & k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
+cd & (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
+cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
+cd & k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
+cd & (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
+cd write (iout,'(a)')
+cd enddo
+ enddo
+ return
+ end
+C--------------------------------------------------------------------------
+ subroutine set_matrices
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include "mpif.h"
+ include "COMMON.SETUP"
+ integer IERR
+ integer status(MPI_STATUS_SIZE)
+#endif
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.TORSION'
+ include 'COMMON.VECTORS'
+ include 'COMMON.FFIELD'
+ double precision auxvec(2),auxmat(2,2)
+C
+C Compute the virtual-bond-torsional-angle dependent quantities needed
+C to calculate the el-loc multibody terms of various order.
+C
+#ifdef PARMAT
+ do i=ivec_start+2,ivec_end+2
+#else
+ do i=3,nres+1
+#endif
+ if (i .lt. nres+1) then
+ sin1=dsin(phi(i))
+ cos1=dcos(phi(i))
+ sintab(i-2)=sin1
+ costab(i-2)=cos1
+ obrot(1,i-2)=cos1
+ obrot(2,i-2)=sin1
+ sin2=dsin(2*phi(i))
+ cos2=dcos(2*phi(i))
+ sintab2(i-2)=sin2
+ costab2(i-2)=cos2
+ obrot2(1,i-2)=cos2
+ obrot2(2,i-2)=sin2
+ Ug(1,1,i-2)=-cos1
+ Ug(1,2,i-2)=-sin1
+ Ug(2,1,i-2)=-sin1
+ Ug(2,2,i-2)= cos1
+ Ug2(1,1,i-2)=-cos2
+ Ug2(1,2,i-2)=-sin2
+ Ug2(2,1,i-2)=-sin2
+ Ug2(2,2,i-2)= cos2
+ else
+ costab(i-2)=1.0d0
+ sintab(i-2)=0.0d0
+ obrot(1,i-2)=1.0d0
+ obrot(2,i-2)=0.0d0
+ obrot2(1,i-2)=0.0d0
+ obrot2(2,i-2)=0.0d0
+ Ug(1,1,i-2)=1.0d0
+ Ug(1,2,i-2)=0.0d0
+ Ug(2,1,i-2)=0.0d0
+ Ug(2,2,i-2)=1.0d0
+ Ug2(1,1,i-2)=0.0d0
+ Ug2(1,2,i-2)=0.0d0
+ Ug2(2,1,i-2)=0.0d0
+ Ug2(2,2,i-2)=0.0d0
+ endif
+ if (i .gt. 3 .and. i .lt. nres+1) then
+ obrot_der(1,i-2)=-sin1
+ obrot_der(2,i-2)= cos1
+ Ugder(1,1,i-2)= sin1
+ Ugder(1,2,i-2)=-cos1
+ Ugder(2,1,i-2)=-cos1
+ Ugder(2,2,i-2)=-sin1
+ dwacos2=cos2+cos2
+ dwasin2=sin2+sin2
+ obrot2_der(1,i-2)=-dwasin2
+ obrot2_der(2,i-2)= dwacos2
+ Ug2der(1,1,i-2)= dwasin2
+ Ug2der(1,2,i-2)=-dwacos2
+ Ug2der(2,1,i-2)=-dwacos2
+ Ug2der(2,2,i-2)=-dwasin2
+ else
+ obrot_der(1,i-2)=0.0d0
+ obrot_der(2,i-2)=0.0d0
+ Ugder(1,1,i-2)=0.0d0
+ Ugder(1,2,i-2)=0.0d0
+ Ugder(2,1,i-2)=0.0d0
+ Ugder(2,2,i-2)=0.0d0
+ obrot2_der(1,i-2)=0.0d0
+ obrot2_der(2,i-2)=0.0d0
+ Ug2der(1,1,i-2)=0.0d0
+ Ug2der(1,2,i-2)=0.0d0
+ Ug2der(2,1,i-2)=0.0d0
+ Ug2der(2,2,i-2)=0.0d0
+ endif
+c if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
+ if (i.gt. nnt+2 .and. i.lt.nct+2) then
+ iti = itortyp(itype(i-2))
+ else
+ iti=ntortyp+1
+ endif
+c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
+ if (i.gt. nnt+1 .and. i.lt.nct+1) then
+ iti1 = itortyp(itype(i-1))
+ else
+ iti1=ntortyp+1
+ endif
+cd write (iout,*) '*******i',i,' iti1',iti
+cd write (iout,*) 'b1',b1(:,iti)
+cd write (iout,*) 'b2',b2(:,iti)
+cd write (iout,*) 'Ug',Ug(:,:,i-2)
+c if (i .gt. iatel_s+2) then
+ if (i .gt. nnt+2) then
+ call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
+ call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
+ if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
+ & then
+ call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
+ call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
+ call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
+ call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
+ call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
+ endif
+ else
+ do k=1,2
+ Ub2(k,i-2)=0.0d0
+ Ctobr(k,i-2)=0.0d0
+ Dtobr2(k,i-2)=0.0d0
+ do l=1,2
+ EUg(l,k,i-2)=0.0d0
+ CUg(l,k,i-2)=0.0d0
+ DUg(l,k,i-2)=0.0d0
+ DtUg2(l,k,i-2)=0.0d0
+ enddo
+ enddo
+ endif
+ call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
+ call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
+ do k=1,2
+ muder(k,i-2)=Ub2der(k,i-2)
+ enddo
+c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
+ if (i.gt. nnt+1 .and. i.lt.nct+1) then
+ iti1 = itortyp(itype(i-1))
+ else
+ iti1=ntortyp+1
+ endif
+ do k=1,2
+ mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
+ enddo
+cd write (iout,*) 'mu ',mu(:,i-2)
+cd write (iout,*) 'mu1',mu1(:,i-2)
+cd write (iout,*) 'mu2',mu2(:,i-2)
+ if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
+ & then
+ call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
+ call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
+ call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
+ call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
+ call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
+C Vectors and matrices dependent on a single virtual-bond dihedral.
+ call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
+ call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
+ call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
+ call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
+ call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
+ call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
+ call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
+ call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
+ call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
+ endif
+ enddo
+C Matrices dependent on two consecutive virtual-bond dihedrals.
+C The order of matrices is from left to right.
+ if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
+ &then
+c do i=max0(ivec_start,2),ivec_end
+ do i=2,nres-1
+ call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
+ call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
+ call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
+ call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
+ call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
+ call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
+ call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
+ call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
+ enddo
+ endif
+#if defined(MPI) && defined(PARMAT)
+#ifdef DEBUG
+c if (fg_rank.eq.0) then
+ write (iout,*) "Arrays UG and UGDER before GATHER"
+ do i=1,nres-1
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,
+ & ((ug(l,k,i),l=1,2),k=1,2),
+ & ((ugder(l,k,i),l=1,2),k=1,2)
+ enddo
+ write (iout,*) "Arrays UG2 and UG2DER"
+ do i=1,nres-1
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,
+ & ((ug2(l,k,i),l=1,2),k=1,2),
+ & ((ug2der(l,k,i),l=1,2),k=1,2)
+ enddo
+ write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
+ do i=1,nres-1
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,
+ & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
+ & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
+ enddo
+ write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
+ do i=1,nres-1
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,
+ & costab(i),sintab(i),costab2(i),sintab2(i)
+ enddo
+ write (iout,*) "Array MUDER"
+ do i=1,nres-1
+ write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
+ enddo
+c endif
+#endif
+ if (nfgtasks.gt.1) then
+ time00=MPI_Wtime()
+c write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
+c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
+c & " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
+#ifdef MATGATHER
+ call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
+ & MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
+ & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
+ call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
+ & MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
+ & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
+ call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
+ & MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
+ & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
+ call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
+ & MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
+ & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
+ if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
+ & then
+ call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
+ & ivec_count(fg_rank1),
+ & MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
+ & ivec_count(fg_rank1),
+ & MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
+ & ivec_count(fg_rank1),
+ & MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
+ & ivec_count(fg_rank1),
+ & MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
+ & ivec_count(fg_rank1),
+ & MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
+ & MPI_MAT2,FG_COMM1,IERR)
+ call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
+ & ivec_count(fg_rank1),
+ & MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
+ & MPI_MAT2,FG_COMM1,IERR)
+ endif
+#else
+c Passes matrix info through the ring
+ isend=fg_rank1
+ irecv=fg_rank1-1
+ if (irecv.lt.0) irecv=nfgtasks1-1
+ iprev=irecv
+ inext=fg_rank1+1
+ if (inext.ge.nfgtasks1) inext=0
+ do i=1,nfgtasks1-1
+c write (iout,*) "isend",isend," irecv",irecv
+c call flush(iout)
+ lensend=lentyp(isend)
+ lenrecv=lentyp(irecv)
+c write (iout,*) "lensend",lensend," lenrecv",lenrecv
+c call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
+c & MPI_ROTAT1(lensend),inext,2200+isend,
+c & ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
+c & iprev,2200+irecv,FG_COMM,status,IERR)
+c write (iout,*) "Gather ROTAT1"
+c call flush(iout)
+c call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
+c & MPI_ROTAT2(lensend),inext,3300+isend,
+c & obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
+c & iprev,3300+irecv,FG_COMM,status,IERR)
+c write (iout,*) "Gather ROTAT2"
+c call flush(iout)
+ call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
+ & MPI_ROTAT_OLD(lensend),inext,4400+isend,
+ & costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
+ & iprev,4400+irecv,FG_COMM,status,IERR)
+c write (iout,*) "Gather ROTAT_OLD"
+c call flush(iout)
+ call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
+ & MPI_PRECOMP11(lensend),inext,5500+isend,
+ & mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
+ & iprev,5500+irecv,FG_COMM,status,IERR)
+c write (iout,*) "Gather PRECOMP11"
+c call flush(iout)
+ call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
+ & MPI_PRECOMP12(lensend),inext,6600+isend,
+ & Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
+ & iprev,6600+irecv,FG_COMM,status,IERR)
+c write (iout,*) "Gather PRECOMP12"
+c call flush(iout)
+ if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
+ & then
+ call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
+ & MPI_ROTAT2(lensend),inext,7700+isend,
+ & ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
+ & iprev,7700+irecv,FG_COMM,status,IERR)
+c write (iout,*) "Gather PRECOMP21"
+c call flush(iout)
+ call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
+ & MPI_PRECOMP22(lensend),inext,8800+isend,
+ & EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
+ & iprev,8800+irecv,FG_COMM,status,IERR)
+c write (iout,*) "Gather PRECOMP22"
+c call flush(iout)
+ call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
+ & MPI_PRECOMP23(lensend),inext,9900+isend,
+ & Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
+ & MPI_PRECOMP23(lenrecv),
+ & iprev,9900+irecv,FG_COMM,status,IERR)
+c write (iout,*) "Gather PRECOMP23"
+c call flush(iout)
+ endif
+ isend=irecv
+ irecv=irecv-1
+ if (irecv.lt.0) irecv=nfgtasks1-1
+ enddo
+#endif
+ time_gather=time_gather+MPI_Wtime()-time00
+ endif
+#ifdef DEBUG
+c if (fg_rank.eq.0) then
+ write (iout,*) "Arrays UG and UGDER"
+ do i=1,nres-1
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,
+ & ((ug(l,k,i),l=1,2),k=1,2),
+ & ((ugder(l,k,i),l=1,2),k=1,2)
+ enddo
+ write (iout,*) "Arrays UG2 and UG2DER"
+ do i=1,nres-1
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,
+ & ((ug2(l,k,i),l=1,2),k=1,2),
+ & ((ug2der(l,k,i),l=1,2),k=1,2)
+ enddo
+ write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
+ do i=1,nres-1
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,
+ & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
+ & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
+ enddo
+ write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
+ do i=1,nres-1
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,
+ & costab(i),sintab(i),costab2(i),sintab2(i)
+ enddo
+ write (iout,*) "Array MUDER"
+ do i=1,nres-1
+ write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
+ enddo
+c endif
+#endif
+#endif
+cd do i=1,nres
+cd iti = itortyp(itype(i))
+cd write (iout,*) i
+cd do j=1,2
+cd write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
+cd & (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
+cd enddo
+cd enddo
+ return
+ end
+C--------------------------------------------------------------------------
+ subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
+C
+C This subroutine calculates the average interaction energy and its gradient
+C in the virtual-bond vectors between non-adjacent peptide groups, based on
+C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
+C The potential depends both on the distance of peptide-group centers and on
+C the orientation of the CA-CA virtual bonds.
+C
+ implicit real*8 (a-h,o-z)
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.SETUP'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.TORSION'
+ include 'COMMON.VECTORS'
+ include 'COMMON.FFIELD'
+ include 'COMMON.TIME1'
+ dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
+ & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
+ double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
+ & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
+ common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
+ & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
+ & num_conti,j1,j2
+c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
+#ifdef MOMENT
+ double precision scal_el /1.0d0/
+#else
+ double precision scal_el /0.5d0/
+#endif
+C 12/13/98
+C 13-go grudnia roku pamietnego...
+ double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
+ & 0.0d0,1.0d0,0.0d0,
+ & 0.0d0,0.0d0,1.0d0/
+cd write(iout,*) 'In EELEC'
+cd do i=1,nloctyp
+cd write(iout,*) 'Type',i
+cd write(iout,*) 'B1',B1(:,i)
+cd write(iout,*) 'B2',B2(:,i)
+cd write(iout,*) 'CC',CC(:,:,i)
+cd write(iout,*) 'DD',DD(:,:,i)
+cd write(iout,*) 'EE',EE(:,:,i)
+cd enddo
+cd call check_vecgrad
+cd stop
+ if (icheckgrad.eq.1) then
+ do i=1,nres-1
+ fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
+ do k=1,3
+ dc_norm(k,i)=dc(k,i)*fac
+ enddo
+c write (iout,*) 'i',i,' fac',fac
+ enddo
+ endif
+ if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
+ & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
+ & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
+c call vec_and_deriv
+#ifdef TIMING
+ time01=MPI_Wtime()
+#endif
+ call set_matrices
+#ifdef TIMING
+ time_mat=time_mat+MPI_Wtime()-time01
+#endif
+ endif
+cd do i=1,nres-1
+cd write (iout,*) 'i=',i
+cd do k=1,3
+cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
+cd enddo
+cd do k=1,3
+cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
+cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
+cd enddo
+cd enddo
+ t_eelecij=0.0d0
+ ees=0.0D0
+ evdw1=0.0D0
+ eel_loc=0.0d0
+ eello_turn3=0.0d0
+ eello_turn4=0.0d0
+ ind=0
+ do i=1,nres
+ num_cont_hb(i)=0
+ enddo
+cd print '(a)','Enter EELEC'
+cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
+ do i=1,nres
+ gel_loc_loc(i)=0.0d0
+ gcorr_loc(i)=0.0d0
+ enddo
+c
+c
+c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
+C
+C Loop over i,i+2 and i,i+3 pairs of the peptide groups
+C
+ do i=iturn3_start,iturn3_end
+ dxi=dc(1,i)
+ dyi=dc(2,i)
+ dzi=dc(3,i)
+ dx_normi=dc_norm(1,i)
+ dy_normi=dc_norm(2,i)
+ dz_normi=dc_norm(3,i)
+ xmedi=c(1,i)+0.5d0*dxi
+ ymedi=c(2,i)+0.5d0*dyi
+ zmedi=c(3,i)+0.5d0*dzi
+ num_conti=0
+ call eelecij(i,i+2,ees,evdw1,eel_loc)
+ if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
+ num_cont_hb(i)=num_conti
+ enddo
+ do i=iturn4_start,iturn4_end
+ dxi=dc(1,i)
+ dyi=dc(2,i)
+ dzi=dc(3,i)
+ dx_normi=dc_norm(1,i)
+ dy_normi=dc_norm(2,i)
+ dz_normi=dc_norm(3,i)
+ xmedi=c(1,i)+0.5d0*dxi
+ ymedi=c(2,i)+0.5d0*dyi
+ zmedi=c(3,i)+0.5d0*dzi
+ num_conti=num_cont_hb(i)
+ call eelecij(i,i+3,ees,evdw1,eel_loc)
+ if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
+ num_cont_hb(i)=num_conti
+ enddo ! i
+c
+c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
+c
+ do i=iatel_s,iatel_e
+ dxi=dc(1,i)
+ dyi=dc(2,i)
+ dzi=dc(3,i)
+ dx_normi=dc_norm(1,i)
+ dy_normi=dc_norm(2,i)
+ dz_normi=dc_norm(3,i)
+ xmedi=c(1,i)+0.5d0*dxi
+ ymedi=c(2,i)+0.5d0*dyi
+ zmedi=c(3,i)+0.5d0*dzi
+c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
+ num_conti=num_cont_hb(i)
+ do j=ielstart(i),ielend(i)
+ call eelecij(i,j,ees,evdw1,eel_loc)
+ enddo ! j
+ num_cont_hb(i)=num_conti
+ enddo ! i
+c write (iout,*) "Number of loop steps in EELEC:",ind
+cd do i=1,nres
+cd write (iout,'(i3,3f10.5,5x,3f10.5)')
+cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
+cd enddo
+c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
+ccc eel_loc=eel_loc+eello_turn3
+cd print *,"Processor",fg_rank," t_eelecij",t_eelecij
+ return
+ end
+C-------------------------------------------------------------------------------
+ subroutine eelecij(i,j,ees,evdw1,eel_loc)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include "mpif.h"
+#endif
+ include 'COMMON.CONTROL'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.TORSION'
+ include 'COMMON.VECTORS'
+ include 'COMMON.FFIELD'
+ include 'COMMON.TIME1'
+ dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
+ & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
+ double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
+ & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
+ common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
+ & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
+ & num_conti,j1,j2
+c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
+#ifdef MOMENT
+ double precision scal_el /1.0d0/
+#else
+ double precision scal_el /0.5d0/
+#endif
+C 12/13/98
+C 13-go grudnia roku pamietnego...
+ double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
+ & 0.0d0,1.0d0,0.0d0,
+ & 0.0d0,0.0d0,1.0d0/
+c time00=MPI_Wtime()
+cd write (iout,*) "eelecij",i,j
+c ind=ind+1
+ iteli=itel(i)
+ itelj=itel(j)
+ if (j.eq.i+2 .and. itelj.eq.2) iteli=2
+ aaa=app(iteli,itelj)
+ bbb=bpp(iteli,itelj)
+ ael6i=ael6(iteli,itelj)
+ ael3i=ael3(iteli,itelj)
+ dxj=dc(1,j)
+ dyj=dc(2,j)
+ dzj=dc(3,j)
+ dx_normj=dc_norm(1,j)
+ dy_normj=dc_norm(2,j)
+ dz_normj=dc_norm(3,j)
+ xj=c(1,j)+0.5D0*dxj-xmedi
+ yj=c(2,j)+0.5D0*dyj-ymedi
+ zj=c(3,j)+0.5D0*dzj-zmedi
+ rij=xj*xj+yj*yj+zj*zj
+ rrmij=1.0D0/rij
+ rij=dsqrt(rij)
+ rmij=1.0D0/rij
+ r3ij=rrmij*rmij
+ r6ij=r3ij*r3ij
+ cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
+ cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
+ cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
+ fac=cosa-3.0D0*cosb*cosg
+ ev1=aaa*r6ij*r6ij
+c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
+ if (j.eq.i+2) ev1=scal_el*ev1
+ ev2=bbb*r6ij
+ fac3=ael6i*r6ij
+ fac4=ael3i*r3ij
+ evdwij=ev1+ev2
+ el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
+ el2=fac4*fac
+ eesij=el1+el2
+C 12/26/95 - for the evaluation of multi-body H-bonding interactions
+ ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
+ ees=ees+eesij
+ evdw1=evdw1+evdwij
+cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
+cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
+cd & 1.0D0/dsqrt(rrmij),evdwij,eesij,
+cd & xmedi,ymedi,zmedi,xj,yj,zj
+
+ if (energy_dec) then
+ write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
+ write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
+ endif
+
+C
+C Calculate contributions to the Cartesian gradient.
+C
+#ifdef SPLITELE
+ facvdw=-6*rrmij*(ev1+evdwij)
+ facel=-3*rrmij*(el1+eesij)
+ fac1=fac
+ erij(1)=xj*rmij
+ erij(2)=yj*rmij
+ erij(3)=zj*rmij
+*
+* Radial derivatives. First process both termini of the fragment (i,j)
+*
+ ggg(1)=facel*xj
+ ggg(2)=facel*yj
+ ggg(3)=facel*zj
+c do k=1,3
+c ghalf=0.5D0*ggg(k)
+c gelc(k,i)=gelc(k,i)+ghalf
+c gelc(k,j)=gelc(k,j)+ghalf
+c enddo
+c 9/28/08 AL Gradient compotents will be summed only at the end
+ do k=1,3
+ gelc_long(k,j)=gelc_long(k,j)+ggg(k)
+ gelc_long(k,i)=gelc_long(k,i)-ggg(k)
+ enddo
+*
+* Loop over residues i+1 thru j-1.
+*
+cgrad do k=i+1,j-1
+cgrad do l=1,3
+cgrad gelc(l,k)=gelc(l,k)+ggg(l)
+cgrad enddo
+cgrad enddo
+ ggg(1)=facvdw*xj
+ ggg(2)=facvdw*yj
+ ggg(3)=facvdw*zj
+c do k=1,3
+c ghalf=0.5D0*ggg(k)
+c gvdwpp(k,i)=gvdwpp(k,i)+ghalf
+c gvdwpp(k,j)=gvdwpp(k,j)+ghalf
+c enddo
+c 9/28/08 AL Gradient compotents will be summed only at the end
+ do k=1,3
+ gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
+ gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
+ enddo
+*
+* Loop over residues i+1 thru j-1.
+*
+cgrad do k=i+1,j-1
+cgrad do l=1,3
+cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
+cgrad enddo
+cgrad enddo
+#else
+ facvdw=ev1+evdwij
+ facel=el1+eesij
+ fac1=fac
+ fac=-3*rrmij*(facvdw+facvdw+facel)
+ erij(1)=xj*rmij
+ erij(2)=yj*rmij
+ erij(3)=zj*rmij
+*
+* Radial derivatives. First process both termini of the fragment (i,j)
+*
+ ggg(1)=fac*xj
+ ggg(2)=fac*yj
+ ggg(3)=fac*zj
+c do k=1,3
+c ghalf=0.5D0*ggg(k)
+c gelc(k,i)=gelc(k,i)+ghalf
+c gelc(k,j)=gelc(k,j)+ghalf
+c enddo
+c 9/28/08 AL Gradient compotents will be summed only at the end
+ do k=1,3
+ gelc_long(k,j)=gelc(k,j)+ggg(k)
+ gelc_long(k,i)=gelc(k,i)-ggg(k)
+ enddo
+*
+* Loop over residues i+1 thru j-1.
+*
+cgrad do k=i+1,j-1
+cgrad do l=1,3
+cgrad gelc(l,k)=gelc(l,k)+ggg(l)
+cgrad enddo
+cgrad enddo
+c 9/28/08 AL Gradient compotents will be summed only at the end
+ ggg(1)=facvdw*xj
+ ggg(2)=facvdw*yj
+ ggg(3)=facvdw*zj
+ do k=1,3
+ gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
+ gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
+ enddo
+#endif
+*
+* Angular part
+*
+ ecosa=2.0D0*fac3*fac1+fac4
+ fac4=-3.0D0*fac4
+ fac3=-6.0D0*fac3
+ ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
+ ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
+ do k=1,3
+ dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
+ dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
+ enddo
+cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
+cd & (dcosg(k),k=1,3)
+ do k=1,3
+ ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
+ enddo
+c do k=1,3
+c ghalf=0.5D0*ggg(k)
+c gelc(k,i)=gelc(k,i)+ghalf
+c & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
+c & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
+c gelc(k,j)=gelc(k,j)+ghalf
+c & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
+c & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
+c enddo
+cgrad do k=i+1,j-1
+cgrad do l=1,3
+cgrad gelc(l,k)=gelc(l,k)+ggg(l)
+cgrad enddo
+cgrad enddo
+ do k=1,3
+ gelc(k,i)=gelc(k,i)
+ & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
+ & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
+ gelc(k,j)=gelc(k,j)
+ & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
+ & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
+ gelc_long(k,j)=gelc_long(k,j)+ggg(k)
+ gelc_long(k,i)=gelc_long(k,i)-ggg(k)
+ enddo
+ IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
+ & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
+ & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
+C
+C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
+C energy of a peptide unit is assumed in the form of a second-order
+C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
+C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
+C are computed for EVERY pair of non-contiguous peptide groups.
+C
+ if (j.lt.nres-1) then
+ j1=j+1
+ j2=j-1
+ else
+ j1=j-1
+ j2=j-2
+ endif
+ kkk=0
+ do k=1,2
+ do l=1,2
+ kkk=kkk+1
+ muij(kkk)=mu(k,i)*mu(l,j)
+ enddo
+ enddo
+cd write (iout,*) 'EELEC: i',i,' j',j
+cd write (iout,*) 'j',j,' j1',j1,' j2',j2
+cd write(iout,*) 'muij',muij
+ ury=scalar(uy(1,i),erij)
+ urz=scalar(uz(1,i),erij)
+ vry=scalar(uy(1,j),erij)
+ vrz=scalar(uz(1,j),erij)
+ a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
+ a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
+ a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
+ a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
+ fac=dsqrt(-ael6i)*r3ij
+ a22=a22*fac
+ a23=a23*fac
+ a32=a32*fac
+ a33=a33*fac
+cd write (iout,'(4i5,4f10.5)')
+cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
+cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
+cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
+cd & uy(:,j),uz(:,j)
+cd write (iout,'(4f10.5)')
+cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
+cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
+cd write (iout,'(4f10.5)') ury,urz,vry,vrz
+cd write (iout,'(9f10.5/)')
+cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
+C Derivatives of the elements of A in virtual-bond vectors
+ call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
+ do k=1,3
+ uryg(k,1)=scalar(erder(1,k),uy(1,i))
+ uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
+ uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
+ urzg(k,1)=scalar(erder(1,k),uz(1,i))
+ urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
+ urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
+ vryg(k,1)=scalar(erder(1,k),uy(1,j))
+ vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
+ vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
+ vrzg(k,1)=scalar(erder(1,k),uz(1,j))
+ vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
+ vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
+ enddo
+C Compute radial contributions to the gradient
+ facr=-3.0d0*rrmij
+ a22der=a22*facr
+ a23der=a23*facr
+ a32der=a32*facr
+ a33der=a33*facr
+ agg(1,1)=a22der*xj
+ agg(2,1)=a22der*yj
+ agg(3,1)=a22der*zj
+ agg(1,2)=a23der*xj
+ agg(2,2)=a23der*yj
+ agg(3,2)=a23der*zj
+ agg(1,3)=a32der*xj
+ agg(2,3)=a32der*yj
+ agg(3,3)=a32der*zj
+ agg(1,4)=a33der*xj
+ agg(2,4)=a33der*yj
+ agg(3,4)=a33der*zj
+C Add the contributions coming from er
+ fac3=-3.0d0*fac
+ do k=1,3
+ agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
+ agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
+ agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
+ agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
+ enddo
+ do k=1,3
+C Derivatives in DC(i)
+cgrad ghalf1=0.5d0*agg(k,1)
+cgrad ghalf2=0.5d0*agg(k,2)
+cgrad ghalf3=0.5d0*agg(k,3)
+cgrad ghalf4=0.5d0*agg(k,4)
+ aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
+ & -3.0d0*uryg(k,2)*vry)!+ghalf1
+ aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
+ & -3.0d0*uryg(k,2)*vrz)!+ghalf2
+ aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
+ & -3.0d0*urzg(k,2)*vry)!+ghalf3
+ aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
+ & -3.0d0*urzg(k,2)*vrz)!+ghalf4
+C Derivatives in DC(i+1)
+ aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
+ & -3.0d0*uryg(k,3)*vry)!+agg(k,1)
+ aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
+ & -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
+ aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
+ & -3.0d0*urzg(k,3)*vry)!+agg(k,3)
+ aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
+ & -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
+C Derivatives in DC(j)
+ aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
+ & -3.0d0*vryg(k,2)*ury)!+ghalf1
+ aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
+ & -3.0d0*vrzg(k,2)*ury)!+ghalf2
+ aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
+ & -3.0d0*vryg(k,2)*urz)!+ghalf3
+ aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
+ & -3.0d0*vrzg(k,2)*urz)!+ghalf4
+C Derivatives in DC(j+1) or DC(nres-1)
+ aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
+ & -3.0d0*vryg(k,3)*ury)
+ aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
+ & -3.0d0*vrzg(k,3)*ury)
+ aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
+ & -3.0d0*vryg(k,3)*urz)
+ aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
+ & -3.0d0*vrzg(k,3)*urz)
+cgrad if (j.eq.nres-1 .and. i.lt.j-2) then
+cgrad do l=1,4
+cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l)
+cgrad enddo
+cgrad endif
+ enddo
+ acipa(1,1)=a22
+ acipa(1,2)=a23
+ acipa(2,1)=a32
+ acipa(2,2)=a33
+ a22=-a22
+ a23=-a23
+ do l=1,2
+ do k=1,3
+ agg(k,l)=-agg(k,l)
+ aggi(k,l)=-aggi(k,l)
+ aggi1(k,l)=-aggi1(k,l)
+ aggj(k,l)=-aggj(k,l)
+ aggj1(k,l)=-aggj1(k,l)
+ enddo
+ enddo
+ if (j.lt.nres-1) then
+ a22=-a22
+ a32=-a32
+ do l=1,3,2
+ do k=1,3
+ agg(k,l)=-agg(k,l)
+ aggi(k,l)=-aggi(k,l)
+ aggi1(k,l)=-aggi1(k,l)
+ aggj(k,l)=-aggj(k,l)
+ aggj1(k,l)=-aggj1(k,l)
+ enddo
+ enddo
+ else
+ a22=-a22
+ a23=-a23
+ a32=-a32
+ a33=-a33
+ do l=1,4
+ do k=1,3
+ agg(k,l)=-agg(k,l)
+ aggi(k,l)=-aggi(k,l)
+ aggi1(k,l)=-aggi1(k,l)
+ aggj(k,l)=-aggj(k,l)
+ aggj1(k,l)=-aggj1(k,l)
+ enddo
+ enddo
+ endif
+ ENDIF ! WCORR
+ IF (wel_loc.gt.0.0d0) THEN
+C Contribution to the local-electrostatic energy coming from the i-j pair
+ eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
+ & +a33*muij(4)
+cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
+
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
+ & 'eelloc',i,j,eel_loc_ij
+
+ eel_loc=eel_loc+eel_loc_ij
+C Partial derivatives in virtual-bond dihedral angles gamma
+ if (i.gt.1)
+ & gel_loc_loc(i-1)=gel_loc_loc(i-1)+
+ & a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
+ & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
+ gel_loc_loc(j-1)=gel_loc_loc(j-1)+
+ & a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
+ & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
+C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
+ do l=1,3
+ ggg(l)=agg(l,1)*muij(1)+
+ & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
+ gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
+ gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
+cgrad ghalf=0.5d0*ggg(l)
+cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf
+cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf
+ enddo
+cgrad do k=i+1,j2
+cgrad do l=1,3
+cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l)
+cgrad enddo
+cgrad enddo
+C Remaining derivatives of eello
+ do l=1,3
+ gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
+ & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
+ gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
+ & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
+ gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
+ & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
+ gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
+ & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
+ enddo
+ ENDIF
+C Change 12/26/95 to calculate four-body contributions to H-bonding energy
+c if (j.gt.i+1 .and. num_conti.le.maxconts) then
+ if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
+ & .and. num_conti.le.maxconts) then
+c write (iout,*) i,j," entered corr"
+C
+C Calculate the contact function. The ith column of the array JCONT will
+C contain the numbers of atoms that make contacts with the atom I (of numbers
+C greater than I). The arrays FACONT and GACONT will contain the values of
+C the contact function and its derivative.
+c r0ij=1.02D0*rpp(iteli,itelj)
+c r0ij=1.11D0*rpp(iteli,itelj)
+ r0ij=2.20D0*rpp(iteli,itelj)
+c r0ij=1.55D0*rpp(iteli,itelj)
+ call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
+ if (fcont.gt.0.0D0) then
+ num_conti=num_conti+1
+ if (num_conti.gt.maxconts) then
+ write (iout,*) 'WARNING - max. # of contacts exceeded;',
+ & ' will skip next contacts for this conf.'
+ else
+ jcont_hb(num_conti,i)=j
+cd write (iout,*) "i",i," j",j," num_conti",num_conti,
+cd & " jcont_hb",jcont_hb(num_conti,i)
+ IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
+ & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
+C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
+C terms.
+ d_cont(num_conti,i)=rij
+cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
+C --- Electrostatic-interaction matrix ---
+ a_chuj(1,1,num_conti,i)=a22
+ a_chuj(1,2,num_conti,i)=a23
+ a_chuj(2,1,num_conti,i)=a32
+ a_chuj(2,2,num_conti,i)=a33
+C --- Gradient of rij
+ do kkk=1,3
+ grij_hb_cont(kkk,num_conti,i)=erij(kkk)
+ enddo
+ kkll=0
+ do k=1,2
+ do l=1,2
+ kkll=kkll+1
+ do m=1,3
+ a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
+ a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
+ a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
+ a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
+ a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
+ enddo
+ enddo
+ enddo
+ ENDIF
+ IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
+C Calculate contact energies
+ cosa4=4.0D0*cosa
+ wij=cosa-3.0D0*cosb*cosg
+ cosbg1=cosb+cosg
+ cosbg2=cosb-cosg
+c fac3=dsqrt(-ael6i)/r0ij**3
+ fac3=dsqrt(-ael6i)*r3ij
+c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
+ ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
+ if (ees0tmp.gt.0) then
+ ees0pij=dsqrt(ees0tmp)
+ else
+ ees0pij=0
+ endif
+c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
+ ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
+ if (ees0tmp.gt.0) then
+ ees0mij=dsqrt(ees0tmp)
+ else
+ ees0mij=0
+ endif
+c ees0mij=0.0D0
+ ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
+ ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
+C Diagnostics. Comment out or remove after debugging!
+c ees0p(num_conti,i)=0.5D0*fac3*ees0pij
+c ees0m(num_conti,i)=0.5D0*fac3*ees0mij
+c ees0m(num_conti,i)=0.0D0
+C End diagnostics.
+c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
+c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
+C Angular derivatives of the contact function
+ ees0pij1=fac3/ees0pij
+ ees0mij1=fac3/ees0mij
+ fac3p=-3.0D0*fac3*rrmij
+ ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
+ ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
+c ees0mij1=0.0D0
+ ecosa1= ees0pij1*( 1.0D0+0.5D0*wij)
+ ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
+ ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
+ ecosa2= ees0mij1*(-1.0D0+0.5D0*wij)
+ ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
+ ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
+ ecosap=ecosa1+ecosa2
+ ecosbp=ecosb1+ecosb2
+ ecosgp=ecosg1+ecosg2
+ ecosam=ecosa1-ecosa2
+ ecosbm=ecosb1-ecosb2
+ ecosgm=ecosg1-ecosg2
+C Diagnostics
+c ecosap=ecosa1
+c ecosbp=ecosb1
+c ecosgp=ecosg1
+c ecosam=0.0D0
+c ecosbm=0.0D0
+c ecosgm=0.0D0
+C End diagnostics
+ facont_hb(num_conti,i)=fcont
+ fprimcont=fprimcont/rij
+cd facont_hb(num_conti,i)=1.0D0
+C Following line is for diagnostics.
+cd fprimcont=0.0D0
+ do k=1,3
+ dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
+ dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
+ enddo
+ do k=1,3
+ gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
+ gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
+ enddo
+ gggp(1)=gggp(1)+ees0pijp*xj
+ gggp(2)=gggp(2)+ees0pijp*yj
+ gggp(3)=gggp(3)+ees0pijp*zj
+ gggm(1)=gggm(1)+ees0mijp*xj
+ gggm(2)=gggm(2)+ees0mijp*yj
+ gggm(3)=gggm(3)+ees0mijp*zj
+C Derivatives due to the contact function
+ gacont_hbr(1,num_conti,i)=fprimcont*xj
+ gacont_hbr(2,num_conti,i)=fprimcont*yj
+ gacont_hbr(3,num_conti,i)=fprimcont*zj
+ do k=1,3
+c
+c 10/24/08 cgrad and ! comments indicate the parts of the code removed
+c following the change of gradient-summation algorithm.
+c
+cgrad ghalfp=0.5D0*gggp(k)
+cgrad ghalfm=0.5D0*gggm(k)
+ gacontp_hb1(k,num_conti,i)=!ghalfp
+ & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
+ & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
+ gacontp_hb2(k,num_conti,i)=!ghalfp
+ & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
+ & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
+ gacontp_hb3(k,num_conti,i)=gggp(k)
+ gacontm_hb1(k,num_conti,i)=!ghalfm
+ & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
+ & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
+ gacontm_hb2(k,num_conti,i)=!ghalfm
+ & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
+ & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
+ gacontm_hb3(k,num_conti,i)=gggm(k)
+ enddo
+C Diagnostics. Comment out or remove after debugging!
+cdiag do k=1,3
+cdiag gacontp_hb1(k,num_conti,i)=0.0D0
+cdiag gacontp_hb2(k,num_conti,i)=0.0D0
+cdiag gacontp_hb3(k,num_conti,i)=0.0D0
+cdiag gacontm_hb1(k,num_conti,i)=0.0D0
+cdiag gacontm_hb2(k,num_conti,i)=0.0D0
+cdiag gacontm_hb3(k,num_conti,i)=0.0D0
+cdiag enddo
+ ENDIF ! wcorr
+ endif ! num_conti.le.maxconts
+ endif ! fcont.gt.0
+ endif ! j.gt.i+1
+ if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
+ do k=1,4
+ do l=1,3
+ ghalf=0.5d0*agg(l,k)
+ aggi(l,k)=aggi(l,k)+ghalf
+ aggi1(l,k)=aggi1(l,k)+agg(l,k)
+ aggj(l,k)=aggj(l,k)+ghalf
+ enddo
+ enddo
+ if (j.eq.nres-1 .and. i.lt.j-2) then
+ do k=1,4
+ do l=1,3
+ aggj1(l,k)=aggj1(l,k)+agg(l,k)
+ enddo
+ enddo
+ endif
+ endif
+c t_eelecij=t_eelecij+MPI_Wtime()-time00
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine eturn3(i,eello_turn3)
+C Third- and fourth-order contributions from turns
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.TORSION'
+ include 'COMMON.VECTORS'
+ include 'COMMON.FFIELD'
+ include 'COMMON.CONTROL'
+ dimension ggg(3)
+ double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
+ & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
+ & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
+ double precision agg(3,4),aggi(3,4),aggi1(3,4),
+ & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
+ common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
+ & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
+ & num_conti,j1,j2
+ j=i+2
+c write (iout,*) "eturn3",i,j,j1,j2
+ a_temp(1,1)=a22
+ a_temp(1,2)=a23
+ a_temp(2,1)=a32
+ a_temp(2,2)=a33
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C Third-order contributions
+C
+C (i+2)o----(i+3)
+C | |
+C | |
+C (i+1)o----i
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+cd call checkint_turn3(i,a_temp,eello_turn3_num)
+ call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
+ call transpose2(auxmat(1,1),auxmat1(1,1))
+ call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
+ eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
+ & 'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
+cd write (2,*) 'i,',i,' j',j,'eello_turn3',
+cd & 0.5d0*(pizda(1,1)+pizda(2,2)),
+cd & ' eello_turn3_num',4*eello_turn3_num
+C Derivatives in gamma(i)
+ call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
+ call transpose2(auxmat2(1,1),auxmat3(1,1))
+ call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
+ gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
+C Derivatives in gamma(i+1)
+ call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
+ call transpose2(auxmat2(1,1),auxmat3(1,1))
+ call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
+ gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
+ & +0.5d0*(pizda(1,1)+pizda(2,2))
+C Cartesian derivatives
+ do l=1,3
+c ghalf1=0.5d0*agg(l,1)
+c ghalf2=0.5d0*agg(l,2)
+c ghalf3=0.5d0*agg(l,3)
+c ghalf4=0.5d0*agg(l,4)
+ a_temp(1,1)=aggi(l,1)!+ghalf1
+ a_temp(1,2)=aggi(l,2)!+ghalf2
+ a_temp(2,1)=aggi(l,3)!+ghalf3
+ a_temp(2,2)=aggi(l,4)!+ghalf4
+ call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
+ gcorr3_turn(l,i)=gcorr3_turn(l,i)
+ & +0.5d0*(pizda(1,1)+pizda(2,2))
+ a_temp(1,1)=aggi1(l,1)!+agg(l,1)
+ a_temp(1,2)=aggi1(l,2)!+agg(l,2)
+ a_temp(2,1)=aggi1(l,3)!+agg(l,3)
+ a_temp(2,2)=aggi1(l,4)!+agg(l,4)
+ call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
+ gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
+ & +0.5d0*(pizda(1,1)+pizda(2,2))
+ a_temp(1,1)=aggj(l,1)!+ghalf1
+ a_temp(1,2)=aggj(l,2)!+ghalf2
+ a_temp(2,1)=aggj(l,3)!+ghalf3
+ a_temp(2,2)=aggj(l,4)!+ghalf4
+ call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
+ gcorr3_turn(l,j)=gcorr3_turn(l,j)
+ & +0.5d0*(pizda(1,1)+pizda(2,2))
+ a_temp(1,1)=aggj1(l,1)
+ a_temp(1,2)=aggj1(l,2)
+ a_temp(2,1)=aggj1(l,3)
+ a_temp(2,2)=aggj1(l,4)
+ call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
+ gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
+ & +0.5d0*(pizda(1,1)+pizda(2,2))
+ enddo
+ return
+ end
+C-------------------------------------------------------------------------------
+ subroutine eturn4(i,eello_turn4)
+C Third- and fourth-order contributions from turns
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.TORSION'
+ include 'COMMON.VECTORS'
+ include 'COMMON.FFIELD'
+ include 'COMMON.CONTROL'
+ dimension ggg(3)
+ double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
+ & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
+ & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
+ double precision agg(3,4),aggi(3,4),aggi1(3,4),
+ & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
+ common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
+ & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
+ & num_conti,j1,j2
+ j=i+3
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C Fourth-order contributions
+C
+C (i+3)o----(i+4)
+C / |
+C (i+2)o |
+C \ |
+C (i+1)o----i
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+cd call checkint_turn4(i,a_temp,eello_turn4_num)
+c write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
+ a_temp(1,1)=a22
+ a_temp(1,2)=a23
+ a_temp(2,1)=a32
+ a_temp(2,2)=a33
+ iti1=itortyp(itype(i+1))
+ iti2=itortyp(itype(i+2))
+ iti3=itortyp(itype(i+3))
+c write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
+ call transpose2(EUg(1,1,i+1),e1t(1,1))
+ call transpose2(Eug(1,1,i+2),e2t(1,1))
+ call transpose2(Eug(1,1,i+3),e3t(1,1))
+ call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
+ call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
+ s1=scalar2(b1(1,iti2),auxvec(1))
+ call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
+ call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
+ s2=scalar2(b1(1,iti1),auxvec(1))
+ call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
+ call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+ eello_turn4=eello_turn4-(s1+s2+s3)
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
+ & 'eturn4',i,j,-(s1+s2+s3)
+cd write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
+cd & ' eello_turn4_num',8*eello_turn4_num
+C Derivatives in gamma(i)
+ call transpose2(EUgder(1,1,i+1),e1tder(1,1))
+ call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
+ call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
+ s1=scalar2(b1(1,iti2),auxvec(1))
+ call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+ gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
+C Derivatives in gamma(i+1)
+ call transpose2(EUgder(1,1,i+2),e2tder(1,1))
+ call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
+ s2=scalar2(b1(1,iti1),auxvec(1))
+ call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
+ call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+ gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
+C Derivatives in gamma(i+2)
+ call transpose2(EUgder(1,1,i+3),e3tder(1,1))
+ call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
+ s1=scalar2(b1(1,iti2),auxvec(1))
+ call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
+ call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
+ s2=scalar2(b1(1,iti1),auxvec(1))
+ call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
+ call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+ gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
+C Cartesian derivatives
+C Derivatives of this turn contributions in DC(i+2)
+ if (j.lt.nres-1) then
+ do l=1,3
+ a_temp(1,1)=agg(l,1)
+ a_temp(1,2)=agg(l,2)
+ a_temp(2,1)=agg(l,3)
+ a_temp(2,2)=agg(l,4)
+ call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
+ call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
+ s1=scalar2(b1(1,iti2),auxvec(1))
+ call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
+ call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
+ s2=scalar2(b1(1,iti1),auxvec(1))
+ call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
+ call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+ ggg(l)=-(s1+s2+s3)
+ gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
+ enddo
+ endif
+C Remaining derivatives of this turn contribution
+ do l=1,3
+ a_temp(1,1)=aggi(l,1)
+ a_temp(1,2)=aggi(l,2)
+ a_temp(2,1)=aggi(l,3)
+ a_temp(2,2)=aggi(l,4)
+ call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
+ call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
+ s1=scalar2(b1(1,iti2),auxvec(1))
+ call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
+ call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
+ s2=scalar2(b1(1,iti1),auxvec(1))
+ call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
+ call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+ gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
+ a_temp(1,1)=aggi1(l,1)
+ a_temp(1,2)=aggi1(l,2)
+ a_temp(2,1)=aggi1(l,3)
+ a_temp(2,2)=aggi1(l,4)
+ call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
+ call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
+ s1=scalar2(b1(1,iti2),auxvec(1))
+ call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
+ call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
+ s2=scalar2(b1(1,iti1),auxvec(1))
+ call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
+ call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+ gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
+ a_temp(1,1)=aggj(l,1)
+ a_temp(1,2)=aggj(l,2)
+ a_temp(2,1)=aggj(l,3)
+ a_temp(2,2)=aggj(l,4)
+ call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
+ call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
+ s1=scalar2(b1(1,iti2),auxvec(1))
+ call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
+ call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
+ s2=scalar2(b1(1,iti1),auxvec(1))
+ call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
+ call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+ gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
+ a_temp(1,1)=aggj1(l,1)
+ a_temp(1,2)=aggj1(l,2)
+ a_temp(2,1)=aggj1(l,3)
+ a_temp(2,2)=aggj1(l,4)
+ call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
+ call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
+ s1=scalar2(b1(1,iti2),auxvec(1))
+ call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
+ call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
+ s2=scalar2(b1(1,iti1),auxvec(1))
+ call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
+ call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+c write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
+ gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
+ enddo
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine vecpr(u,v,w)
+ implicit real*8(a-h,o-z)
+ dimension u(3),v(3),w(3)
+ w(1)=u(2)*v(3)-u(3)*v(2)
+ w(2)=-u(1)*v(3)+u(3)*v(1)
+ w(3)=u(1)*v(2)-u(2)*v(1)
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine unormderiv(u,ugrad,unorm,ungrad)
+C This subroutine computes the derivatives of a normalized vector u, given
+C the derivatives computed without normalization conditions, ugrad. Returns
+C ungrad.
+ implicit none
+ double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
+ double precision vec(3)
+ double precision scalar
+ integer i,j
+c write (2,*) 'ugrad',ugrad
+c write (2,*) 'u',u
+ do i=1,3
+ vec(i)=scalar(ugrad(1,i),u(1))
+ enddo
+c write (2,*) 'vec',vec
+ do i=1,3
+ do j=1,3
+ ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
+ enddo
+ enddo
+c write (2,*) 'ungrad',ungrad
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine escp_soft_sphere(evdw2,evdw2_14)
+C
+C This subroutine calculates the excluded-volume interaction energy between
+C peptide-group centers and side chains and its gradient in virtual-bond and
+C side-chain vectors.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.FFIELD'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CONTROL'
+ dimension ggg(3)
+ evdw2=0.0D0
+ evdw2_14=0.0d0
+ r0_scp=4.5d0
+cd print '(a)','Enter ESCP'
+cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
+ do i=iatscp_s,iatscp_e
+ iteli=itel(i)
+ xi=0.5D0*(c(1,i)+c(1,i+1))
+ yi=0.5D0*(c(2,i)+c(2,i+1))
+ zi=0.5D0*(c(3,i)+c(3,i+1))
+
+ do iint=1,nscp_gr(i)
+
+ do j=iscpstart(i,iint),iscpend(i,iint)
+ itypj=itype(j)
+C Uncomment following three lines for SC-p interactions
+c xj=c(1,nres+j)-xi
+c yj=c(2,nres+j)-yi
+c zj=c(3,nres+j)-zi
+C Uncomment following three lines for Ca-p interactions
+ xj=c(1,j)-xi
+ yj=c(2,j)-yi
+ zj=c(3,j)-zi
+ rij=xj*xj+yj*yj+zj*zj
+ r0ij=r0_scp
+ r0ijsq=r0ij*r0ij
+ if (rij.lt.r0ijsq) then
+ evdwij=0.25d0*(rij-r0ijsq)**2
+ fac=rij-r0ijsq
+ else
+ evdwij=0.0d0
+ fac=0.0d0
+ endif
+ evdw2=evdw2+evdwij
+C
+C Calculate contributions to the gradient in the virtual-bond and SC vectors.
+C
+ ggg(1)=xj*fac
+ ggg(2)=yj*fac
+ ggg(3)=zj*fac
+cgrad if (j.lt.i) then
+cd write (iout,*) 'j<i'
+C Uncomment following three lines for SC-p interactions
+c do k=1,3
+c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
+c enddo
+cgrad else
+cd write (iout,*) 'j>i'
+cgrad do k=1,3
+cgrad ggg(k)=-ggg(k)
+C Uncomment following line for SC-p interactions
+c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
+cgrad enddo
+cgrad endif
+cgrad do k=1,3
+cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
+cgrad enddo
+cgrad kstart=min0(i+1,j)
+cgrad 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)
+cgrad do k=kstart,kend
+cgrad do l=1,3
+cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
+cgrad enddo
+cgrad enddo
+ do k=1,3
+ gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
+ gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
+ enddo
+ enddo
+
+ enddo ! iint
+ enddo ! i
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine escp(evdw2,evdw2_14)
+C
+C This subroutine calculates the excluded-volume interaction energy between
+C peptide-group centers and side chains and its gradient in virtual-bond and
+C side-chain vectors.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.FFIELD'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CONTROL'
+ dimension ggg(3)
+ evdw2=0.0D0
+ evdw2_14=0.0d0
+cd print '(a)','Enter ESCP'
+cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
+ do i=iatscp_s,iatscp_e
+ iteli=itel(i)
+ xi=0.5D0*(c(1,i)+c(1,i+1))
+ yi=0.5D0*(c(2,i)+c(2,i+1))
+ zi=0.5D0*(c(3,i)+c(3,i+1))
+
+ do iint=1,nscp_gr(i)
+
+ do j=iscpstart(i,iint),iscpend(i,iint)
+ itypj=itype(j)
+C Uncomment following three lines for SC-p interactions
+c xj=c(1,nres+j)-xi
+c yj=c(2,nres+j)-yi
+c zj=c(3,nres+j)-zi
+C Uncomment following three lines for Ca-p interactions
+ xj=c(1,j)-xi
+ yj=c(2,j)-yi
+ zj=c(3,j)-zi
+ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
+ fac=rrij**expon2
+ e1=fac*fac*aad(itypj,iteli)
+ e2=fac*bad(itypj,iteli)
+ if (iabs(j-i) .le. 2) then
+ e1=scal14*e1
+ e2=scal14*e2
+ evdw2_14=evdw2_14+e1+e2
+ endif
+ evdwij=e1+e2
+ evdw2=evdw2+evdwij
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
+ & 'evdw2',i,j,evdwij
+C
+C Calculate contributions to the gradient in the virtual-bond and SC vectors.
+C
+ fac=-(evdwij+e1)*rrij
+ ggg(1)=xj*fac
+ ggg(2)=yj*fac
+ ggg(3)=zj*fac
+cgrad if (j.lt.i) then
+cd write (iout,*) 'j<i'
+C Uncomment following three lines for SC-p interactions
+c do k=1,3
+c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
+c enddo
+cgrad else
+cd write (iout,*) 'j>i'
+cgrad do k=1,3
+cgrad ggg(k)=-ggg(k)
+C Uncomment following line for SC-p interactions
+ccgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
+c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
+cgrad enddo
+cgrad endif
+cgrad do k=1,3
+cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
+cgrad enddo
+cgrad kstart=min0(i+1,j)
+cgrad 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)
+cgrad do k=kstart,kend
+cgrad do l=1,3
+cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
+cgrad enddo
+cgrad enddo
+ do k=1,3
+ gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
+ gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
+ enddo
+ enddo
+
+ enddo ! iint
+ enddo ! i
+ do i=1,nct
+ do j=1,3
+ gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
+ gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
+ gradx_scp(j,i)=expon*gradx_scp(j,i)
+ enddo
+ enddo
+C******************************************************************************
+C
+C N O T E !!!
+C
+C To save time the factor EXPON has been extracted from ALL components
+C of GVDWC and GRADX. Remember to multiply them by this factor before further
+C use!
+C
+C******************************************************************************
+ return
+ end
+C--------------------------------------------------------------------------
+ subroutine edis(ehpb)
+C
+C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.VAR'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ dimension ggg(3)
+ ehpb=0.0D0
+cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
+cd write(iout,*)'link_start=',link_start,' link_end=',link_end
+ if (link_end.eq.0) return
+ do i=link_start,link_end
+C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
+C CA-CA distance used in regularization of structure.
+ ii=ihpb(i)
+ jj=jhpb(i)
+C iii and jjj point to the residues for which the distance is assigned.
+ if (ii.gt.nres) then
+ iii=ii-nres
+ jjj=jj-nres
+ else
+ iii=ii
+ jjj=jj
+ endif
+c write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
+c & dhpb(i),dhpb1(i),forcon(i)
+C 24/11/03 AL: SS bridges handled separately because of introducing a specific
+C distance and angle dependent SS bond potential.
+ if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
+ call ssbond_ene(iii,jjj,eij)
+ ehpb=ehpb+2*eij
+cd write (iout,*) "eij",eij
+ else if (ii.gt.nres .and. jj.gt.nres) then
+c Restraints from contact prediction
+ dd=dist(ii,jj)
+ if (dhpb1(i).gt.0.0d0) then
+ ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
+ fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
+c write (iout,*) "beta nmr",
+c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
+ else
+ dd=dist(ii,jj)
+ rdis=dd-dhpb(i)
+C Get the force constant corresponding to this distance.
+ waga=forcon(i)
+C Calculate the contribution to energy.
+ ehpb=ehpb+waga*rdis*rdis
+c write (iout,*) "beta reg",dd,waga*rdis*rdis
+C
+C Evaluate gradient.
+C
+ fac=waga*rdis/dd
+ endif
+ do j=1,3
+ ggg(j)=fac*(c(j,jj)-c(j,ii))
+ enddo
+ do j=1,3
+ ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
+ ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
+ enddo
+ do k=1,3
+ ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
+ ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
+ enddo
+ else
+C Calculate the distance between the two points and its difference from the
+C target distance.
+ dd=dist(ii,jj)
+ if (dhpb1(i).gt.0.0d0) then
+ ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
+ fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
+c write (iout,*) "alph nmr",
+c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
+ else
+ rdis=dd-dhpb(i)
+C Get the force constant corresponding to this distance.
+ waga=forcon(i)
+C Calculate the contribution to energy.
+ ehpb=ehpb+waga*rdis*rdis
+c write (iout,*) "alpha reg",dd,waga*rdis*rdis
+C
+C Evaluate gradient.
+C
+ fac=waga*rdis/dd
+ endif
+cd print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
+cd & ' waga=',waga,' fac=',fac
+ do j=1,3
+ ggg(j)=fac*(c(j,jj)-c(j,ii))
+ enddo
+cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
+C If this is a SC-SC distance, we need to calculate the contributions to the
+C Cartesian gradient in the SC vectors (ghpbx).
+ if (iii.lt.ii) then
+ do j=1,3
+ ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
+ ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
+ enddo
+ endif
+cgrad do j=iii,jjj-1
+cgrad do k=1,3
+cgrad ghpbc(k,j)=ghpbc(k,j)+ggg(k)
+cgrad enddo
+cgrad enddo
+ do k=1,3
+ ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
+ ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
+ enddo
+ endif
+ enddo
+ ehpb=0.5D0*ehpb
+ return
+ end
+C--------------------------------------------------------------------------
+ subroutine ssbond_ene(i,j,eij)
+C
+C Calculate the distance and angle dependent SS-bond potential energy
+C using a free-energy function derived based on RHF/6-31G** ab initio
+C calculations of diethyl disulfide.
+C
+C A. Liwo and U. Kozlowska, 11/24/03
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.VAR'
+ include 'COMMON.IOUNITS'
+ double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
+ itypi=itype(i)
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+ dxi=dc_norm(1,nres+i)
+ dyi=dc_norm(2,nres+i)
+ dzi=dc_norm(3,nres+i)
+c dsci_inv=dsc_inv(itypi)
+ dsci_inv=vbld_inv(nres+i)
+ itypj=itype(j)
+c dscj_inv=dsc_inv(itypj)
+ dscj_inv=vbld_inv(nres+j)
+ 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
+ ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
+ ghpbx(k,i)=ghpbx(k,i)-ggk
+ & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
+ & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
+ ghpbx(k,j)=ghpbx(k,j)+ggk
+ & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
+ & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
+ ghpbc(k,i)=ghpbc(k,i)-ggk
+ ghpbc(k,j)=ghpbc(k,j)+ggk
+ enddo
+C
+C Calculate the components of the gradient in DC and X
+C
+cgrad do k=i,j-1
+cgrad do l=1,3
+cgrad ghpbc(l,k)=ghpbc(l,k)+gg(l)
+cgrad enddo
+cgrad 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'
+ include 'COMMON.SETUP'
+ double precision u(3),ud(3)
+ estr=0.0d0
+ do i=ibondp_start,ibondp_end
+ diff = vbld(i)-vbldp0
+c write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
+ estr=estr+diff*diff
+ do j=1,3
+ gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
+ enddo
+c write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
+ enddo
+ estr=0.5d0*AKP*estr
+c
+c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
+c
+ do i=ibond_start,ibond_end
+ iti=itype(i)
+ if (iti.ne.10) then
+ nbi=nbondterm(iti)
+ if (nbi.eq.1) then
+ diff=vbld(i+nres)-vbldsc0(1,iti)
+c write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
+c & AKSC(1,iti),AKSC(1,iti)*diff*diff
+ estr=estr+0.5d0*AKSC(1,iti)*diff*diff
+ do j=1,3
+ gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
+ enddo
+ else
+ do j=1,nbi
+ diff=vbld(i+nres)-vbldsc0(j,iti)
+ ud(j)=aksc(j,iti)*diff
+ u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
+ enddo
+ uprod=u(1)
+ do j=2,nbi
+ uprod=uprod*u(j)
+ enddo
+ usum=0.0d0
+ usumsqder=0.0d0
+ do j=1,nbi
+ uprod1=1.0d0
+ uprod2=1.0d0
+ do k=1,nbi
+ if (k.ne.j) then
+ uprod1=uprod1*u(k)
+ uprod2=uprod2*u(k)*u(k)
+ endif
+ enddo
+ usum=usum+uprod1
+ usumsqder=usumsqder+ud(j)*uprod2
+ enddo
+ estr=estr+uprod/usum
+ do j=1,3
+ gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
+ enddo
+ endif
+ endif
+ enddo
+ return
+ end
+#ifdef CRYST_THETA
+C--------------------------------------------------------------------------
+ subroutine ebend(etheta)
+C
+C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
+C angles gamma and its derivatives in consecutive thetas and gammas.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include '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'
+ 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 (*,'(a,i2)') 'EBEND ICG=',icg
+ do i=ithet_start,ithet_end
+C Zero the energy function and its derivative at 0 or pi.
+ call splinthet(theta(i),0.5d0*delta,ss,ssd)
+ it=itype(i-1)
+ if (i.gt.3) then
+#ifdef OSF
+ phii=phi(i)
+ if (phii.ne.phii) phii=150.0
+#else
+ phii=phi(i)
+#endif
+ y(1)=dcos(phii)
+ y(2)=dsin(phii)
+ else
+ y(1)=0.0D0
+ y(2)=0.0D0
+ endif
+ if (i.lt.nres) then
+#ifdef OSF
+ phii1=phi(i+1)
+ if (phii1.ne.phii1) phii1=150.0
+ phii1=pinorm(phii1)
+ z(1)=cos(phii1)
+#else
+ phii1=phi(i+1)
+ z(1)=dcos(phii1)
+#endif
+ z(2)=dsin(phii1)
+ else
+ z(1)=0.0D0
+ z(2)=0.0D0
+ endif
+C Calculate the "mean" value of theta from the part of the distribution
+C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
+C In following comments this theta will be referred to as t_c.
+ thet_pred_mean=0.0d0
+ do k=1,2
+ athetk=athet(k,it)
+ bthetk=bthet(k,it)
+ thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
+ enddo
+ dthett=thet_pred_mean*ssd
+ thet_pred_mean=thet_pred_mean*ss+a0thet(it)
+C Derivatives of the "mean" values in gamma1 and gamma2.
+ dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
+ dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
+ if (theta(i).gt.pi-delta) then
+ call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
+ & E_tc0)
+ call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
+ call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
+ call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
+ & E_theta)
+ call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
+ & E_tc)
+ else if (theta(i).lt.delta) then
+ call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
+ call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
+ call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
+ & E_theta)
+ call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
+ call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
+ & E_tc)
+ else
+ call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
+ & E_theta,E_tc)
+ endif
+ etheta=etheta+ethetai
+ if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
+ & 'ebend',i,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)
+ 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'
+ 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
+ do i=ithet_start,ithet_end
+ dethetai=0.0d0
+ dephii=0.0d0
+ dephii1=0.0d0
+ theti2=0.5d0*theta(i)
+ ityp2=ithetyp(itype(i-1))
+ do k=1,nntheterm
+ coskt(k)=dcos(k*theti2)
+ sinkt(k)=dsin(k*theti2)
+ enddo
+ if (i.gt.3) then
+#ifdef OSF
+ phii=phi(i)
+ if (phii.ne.phii) phii=150.0
+#else
+ phii=phi(i)
+#endif
+ ityp1=ithetyp(itype(i-2))
+ do k=1,nsingle
+ cosph1(k)=dcos(k*phii)
+ sinph1(k)=dsin(k*phii)
+ enddo
+ else
+ phii=0.0d0
+ ityp1=nthetyp+1
+ do k=1,nsingle
+ cosph1(k)=0.0d0
+ sinph1(k)=0.0d0
+ enddo
+ endif
+ if (i.lt.nres) then
+#ifdef OSF
+ phii1=phi(i+1)
+ if (phii1.ne.phii1) phii1=150.0
+ phii1=pinorm(phii1)
+#else
+ phii1=phi(i+1)
+#endif
+ ityp3=ithetyp(itype(i))
+ do k=1,nsingle
+ cosph2(k)=dcos(k*phii1)
+ sinph2(k)=dsin(k*phii1)
+ enddo
+ else
+ phii1=0.0d0
+ ityp3=nthetyp+1
+ do k=1,nsingle
+ cosph2(k)=0.0d0
+ sinph2(k)=0.0d0
+ enddo
+ endif
+ ethetai=aa0thet(ityp1,ityp2,ityp3)
+ do k=1,ndouble
+ do l=1,k-1
+ ccl=cosph1(l)*cosph2(k-l)
+ ssl=sinph1(l)*sinph2(k-l)
+ scl=sinph1(l)*cosph2(k-l)
+ csl=cosph1(l)*sinph2(k-l)
+ cosph1ph2(l,k)=ccl-ssl
+ cosph1ph2(k,l)=ccl+ssl
+ sinph1ph2(l,k)=scl+csl
+ sinph1ph2(k,l)=scl-csl
+ enddo
+ enddo
+ if (lprn) then
+ write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
+ & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
+ write (iout,*) "coskt and sinkt"
+ do k=1,nntheterm
+ write (iout,*) k,coskt(k),sinkt(k)
+ enddo
+ endif
+ do k=1,ntheterm
+ ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
+ dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
+ & *coskt(k)
+ if (lprn)
+ & write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
+ & " ethetai",ethetai
+ enddo
+ if (lprn) then
+ write (iout,*) "cosph and sinph"
+ do k=1,nsingle
+ write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
+ enddo
+ write (iout,*) "cosph1ph2 and sinph2ph2"
+ do k=2,ndouble
+ do l=1,k-1
+ write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
+ & sinph1ph2(l,k),sinph1ph2(k,l)
+ enddo
+ enddo
+ write(iout,*) "ethetai",ethetai
+ endif
+ do m=1,ntheterm2
+ do k=1,nsingle
+ aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
+ & +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
+ & +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
+ & +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
+ ethetai=ethetai+sinkt(m)*aux
+ dethetai=dethetai+0.5d0*m*aux*coskt(m)
+ dephii=dephii+k*sinkt(m)*(
+ & ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
+ & bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
+ dephii1=dephii1+k*sinkt(m)*(
+ & eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
+ & ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
+ if (lprn)
+ & write (iout,*) "m",m," k",k," bbthet",
+ & bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
+ & ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
+ & ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
+ & eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
+ enddo
+ enddo
+ if (lprn)
+ & write(iout,*) "ethetai",ethetai
+ do m=1,ntheterm3
+ do k=2,ndouble
+ do l=1,k-1
+ aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
+ & ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
+ & ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
+ & ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
+ ethetai=ethetai+sinkt(m)*aux
+ dethetai=dethetai+0.5d0*m*coskt(m)*aux
+ dephii=dephii+l*sinkt(m)*(
+ & -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
+ & ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
+ & ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
+ & ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
+ dephii1=dephii1+(k-l)*sinkt(m)*(
+ & -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
+ & ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
+ & ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
+ & ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
+ if (lprn) then
+ write (iout,*) "m",m," k",k," l",l," ffthet",
+ & ffthet(l,k,m,ityp1,ityp2,ityp3),
+ & ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
+ & ggthet(l,k,m,ityp1,ityp2,ityp3),
+ & ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
+ write (iout,*) cosph1ph2(l,k)*sinkt(m),
+ & cosph1ph2(k,l)*sinkt(m),
+ & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
+ endif
+ enddo
+ enddo
+ enddo
+10 continue
+ if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
+ & i,theta(i)*rad2deg,phii*rad2deg,
+ & phii1*rad2deg,ethetai
+ etheta=etheta+ethetai
+ if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
+ if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
+ gloc(nphi+i-2,icg)=wang*dethetai
+ enddo
+ return
+ end
+#endif
+#ifdef CRYST_SC
+c-----------------------------------------------------------------------------
+ subroutine esc(escloc)
+C Calculate the local energy of a side chain and its derivatives in the
+C corresponding virtual-bond valence angles THETA and the spherical angles
+C ALPHA and OMEGA.
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include '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'
+ include 'COMMON.CONTROL'
+ double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
+ & ddersc0(3),ddummy(3),xtemp(3),temp(3)
+ common /sccalc/ time11,time12,time112,theti,it,nlobit
+ delta=0.02d0*pi
+ escloc=0.0D0
+c write (iout,'(a)') 'ESC'
+ do i=loc_start,loc_end
+ it=itype(i)
+ if (it.eq.10) goto 1
+ nlobit=nlob(it)
+c print *,'i=',i,' it=',it,' nlobit=',nlobit
+c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
+ theti=theta(i+1)-pipol
+ x(1)=dtan(theti)
+ x(2)=alph(i)
+ x(3)=omeg(i)
+
+ if (x(2).gt.pi-delta) then
+ xtemp(1)=x(1)
+ xtemp(2)=pi-delta
+ xtemp(3)=x(3)
+ call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
+ xtemp(2)=pi
+ call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
+ call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
+ & escloci,dersc(2))
+ call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
+ & ddersc0(1),dersc(1))
+ call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
+ & ddersc0(3),dersc(3))
+ xtemp(2)=pi-delta
+ call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
+ xtemp(2)=pi
+ call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
+ call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
+ & dersc0(2),esclocbi,dersc02)
+ call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
+ & dersc12,dersc01)
+ call splinthet(x(2),0.5d0*delta,ss,ssd)
+ dersc0(1)=dersc01
+ dersc0(2)=dersc02
+ dersc0(3)=0.0d0
+ do k=1,3
+ dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
+ enddo
+ dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
+c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
+c & esclocbi,ss,ssd
+ escloci=ss*escloci+(1.0d0-ss)*esclocbi
+c escloci=esclocbi
+c write (iout,*) escloci
+ else if (x(2).lt.delta) then
+ xtemp(1)=x(1)
+ xtemp(2)=delta
+ xtemp(3)=x(3)
+ call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
+ xtemp(2)=0.0d0
+ call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
+ call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
+ & escloci,dersc(2))
+ call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
+ & ddersc0(1),dersc(1))
+ call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
+ & ddersc0(3),dersc(3))
+ xtemp(2)=delta
+ call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
+ xtemp(2)=0.0d0
+ call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
+ call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
+ & dersc0(2),esclocbi,dersc02)
+ call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
+ & dersc12,dersc01)
+ dersc0(1)=dersc01
+ dersc0(2)=dersc02
+ dersc0(3)=0.0d0
+ call splinthet(x(2),0.5d0*delta,ss,ssd)
+ do k=1,3
+ dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
+ enddo
+ dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
+c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
+c & esclocbi,ss,ssd
+ escloci=ss*escloci+(1.0d0-ss)*esclocbi
+c write (iout,*) escloci
+ else
+ call enesc(x,escloci,dersc,ddummy,.false.)
+ endif
+
+ escloc=escloc+escloci
+ if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
+ & 'escloc',i,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
+#ifdef OSF
+ adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
+ if(adexp.ne.adexp) adexp=1.0
+ expfac=dexp(adexp)
+#else
+ expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
+#endif
+cd print *,'j=',j,' expfac=',expfac
+ escloc_i=escloc_i+expfac
+ do k=1,3
+ dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
+ enddo
+ if (mixed) then
+ do k=1,3,2
+ ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
+ & +gaussc(k,2,j,it))*expfac
+ enddo
+ endif
+ enddo
+
+ enddo ! iii
+
+ dersc(1)=dersc(1)/cos(theti)**2
+ ddersc(1)=ddersc(1)/cos(theti)**2
+ ddersc(3)=ddersc(3)
+
+ escloci=-(dlog(escloc_i)-emin)
+ do j=1,3
+ dersc(j)=dersc(j)/escloc_i
+ enddo
+ if (mixed) then
+ do j=1,3,2
+ ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
+ enddo
+ endif
+ return
+ end
+C------------------------------------------------------------------------------
+ subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.IOUNITS'
+ common /sccalc/ time11,time12,time112,theti,it,nlobit
+ double precision x(3),z(3),Ax(3,maxlob),dersc(3)
+ double precision contr(maxlob)
+ logical mixed
+
+ escloc_i=0.0D0
+
+ do j=1,3
+ dersc(j)=0.0D0
+ enddo
+
+ do j=1,nlobit
+ do k=1,2
+ z(k)=x(k)-censc(k,j,it)
+ enddo
+ z(3)=dwapi
+ do k=1,3
+ Axk=0.0D0
+ do l=1,3
+ Axk=Axk+gaussc(l,k,j,it)*z(l)
+ enddo
+ Ax(k,j)=Axk
+ enddo
+ expfac=0.0D0
+ do k=1,3
+ expfac=expfac+Ax(k,j)*z(k)
+ enddo
+ contr(j)=expfac
+ enddo ! j
+
+C As in the case of ebend, we want to avoid underflows in exponentiation and
+C subsequent NaNs and INFs in energy calculation.
+C Find the largest exponent
+ emin=contr(1)
+ do j=1,nlobit
+ if (emin.gt.contr(j)) emin=contr(j)
+ enddo
+ emin=0.5D0*emin
+
+C Compute the contribution to SC energy and derivatives
+
+ dersc12=0.0d0
+ do j=1,nlobit
+ expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
+ escloc_i=escloc_i+expfac
+ do k=1,2
+ dersc(k)=dersc(k)+Ax(k,j)*expfac
+ enddo
+ if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
+ & +gaussc(1,2,j,it))*expfac
+ dersc(3)=0.0d0
+ enddo
+
+ dersc(1)=dersc(1)/cos(theti)**2
+ dersc12=dersc12/cos(theti)**2
+ escloci=-(dlog(escloc_i)-emin)
+ do j=1,2
+ dersc(j)=dersc(j)/escloc_i
+ enddo
+ if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
+ return
+ end
+#else
+c----------------------------------------------------------------------------------
+ subroutine esc(escloc)
+C Calculate the local energy of a side chain and its derivatives in the
+C corresponding virtual-bond valence angles THETA and the spherical angles
+C ALPHA and OMEGA derived from AM1 all-atom calculations.
+C added by Urszula Kozlowska. 07/11/2007
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.VAR'
+ include 'COMMON.SCROT'
+ include 'COMMON.INTERACT'
+ include 'COMMON.DERIV'
+ include 'COMMON.CHAIN'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ include 'COMMON.FFIELD'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VECTORS'
+ double precision x_prime(3),y_prime(3),z_prime(3)
+ & , sumene,dsc_i,dp2_i,x(65),
+ & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
+ & de_dxx,de_dyy,de_dzz,de_dt
+ double precision s1_t,s1_6_t,s2_t,s2_6_t
+ double precision
+ & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
+ & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
+ & dt_dCi(3),dt_dCi1(3)
+ common /sccalc/ time11,time12,time112,theti,it,nlobit
+ delta=0.02d0*pi
+ escloc=0.0D0
+ do i=loc_start,loc_end
+ costtab(i+1) =dcos(theta(i+1))
+ sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
+ cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
+ sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
+ cosfac2=0.5d0/(1.0d0+costtab(i+1))
+ cosfac=dsqrt(cosfac2)
+ sinfac2=0.5d0/(1.0d0-costtab(i+1))
+ sinfac=dsqrt(sinfac2)
+ it=itype(i)
+ if (it.eq.10) goto 1
+c
+C Compute the axes of tghe local cartesian coordinates system; store in
+c x_prime, y_prime and z_prime
+c
+ do j=1,3
+ x_prime(j) = 0.00
+ y_prime(j) = 0.00
+ z_prime(j) = 0.00
+ enddo
+C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
+C & dc_norm(3,i+nres)
+ do j = 1,3
+ x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
+ y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
+ enddo
+ do j = 1,3
+ z_prime(j) = -uz(j,i-1)
+ enddo
+c write (2,*) "i",i
+c write (2,*) "x_prime",(x_prime(j),j=1,3)
+c write (2,*) "y_prime",(y_prime(j),j=1,3)
+c write (2,*) "z_prime",(z_prime(j),j=1,3)
+c write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
+c & " xy",scalar(x_prime(1),y_prime(1)),
+c & " xz",scalar(x_prime(1),z_prime(1)),
+c & " yy",scalar(y_prime(1),y_prime(1)),
+c & " yz",scalar(y_prime(1),z_prime(1)),
+c & " zz",scalar(z_prime(1),z_prime(1))
+c
+C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
+C to local coordinate system. Store in xx, yy, zz.
+c
+ xx=0.0d0
+ yy=0.0d0
+ zz=0.0d0
+ do j = 1,3
+ xx = xx + x_prime(j)*dc_norm(j,i+nres)
+ yy = yy + y_prime(j)*dc_norm(j,i+nres)
+ zz = zz + z_prime(j)*dc_norm(j,i+nres)
+ enddo
+
+ xxtab(i)=xx
+ yytab(i)=yy
+ zztab(i)=zz
+C
+C Compute the energy of the ith side cbain
+C
+c write (2,*) "xx",xx," yy",yy," zz",zz
+ it=itype(i)
+ do j = 1,65
+ x(j) = sc_parmin(j,it)
+ enddo
+#ifdef CHECK_COORD
+Cc diagnostics - remove later
+ xx1 = dcos(alph(2))
+ yy1 = dsin(alph(2))*dcos(omeg(2))
+ zz1 = -dsin(alph(2))*dsin(omeg(2))
+ write(2,'(3f8.1,3f9.3,1x,3f9.3)')
+ & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
+ & xx1,yy1,zz1
+C," --- ", xx_w,yy_w,zz_w
+c end diagnostics
+#endif
+ sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
+ & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
+ & + x(10)*yy*zz
+ sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
+ & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
+ & + x(20)*yy*zz
+ sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
+ & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
+ & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
+ & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
+ & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
+ & +x(40)*xx*yy*zz
+ sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
+ & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
+ & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
+ & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
+ & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
+ & +x(60)*xx*yy*zz
+ dsc_i = 0.743d0+x(61)
+ dp2_i = 1.9d0+x(62)
+ dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
+ & *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
+ dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
+ & *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
+ s1=(1+x(63))/(0.1d0 + dscp1)
+ s1_6=(1+x(64))/(0.1d0 + dscp1**6)
+ s2=(1+x(65))/(0.1d0 + dscp2)
+ s2_6=(1+x(65))/(0.1d0 + dscp2**6)
+ sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
+ & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
+c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
+c & sumene4,
+c & dscp1,dscp2,sumene
+c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
+ escloc = escloc + sumene
+c write (2,*) "i",i," escloc",sumene,escloc
+#ifdef DEBUG
+C
+C This section to check the numerical derivatives of the energy of ith side
+C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
+C #define DEBUG in the code to turn it on.
+C
+ write (2,*) "sumene =",sumene
+ aincr=1.0d-7
+ xxsave=xx
+ xx=xx+aincr
+ write (2,*) xx,yy,zz
+ sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
+ de_dxx_num=(sumenep-sumene)/aincr
+ xx=xxsave
+ write (2,*) "xx+ sumene from enesc=",sumenep
+ yysave=yy
+ yy=yy+aincr
+ write (2,*) xx,yy,zz
+ sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
+ de_dyy_num=(sumenep-sumene)/aincr
+ yy=yysave
+ write (2,*) "yy+ sumene from enesc=",sumenep
+ zzsave=zz
+ zz=zz+aincr
+ write (2,*) xx,yy,zz
+ sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
+ de_dzz_num=(sumenep-sumene)/aincr
+ zz=zzsave
+ write (2,*) "zz+ sumene from enesc=",sumenep
+ costsave=cost2tab(i+1)
+ sintsave=sint2tab(i+1)
+ cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
+ sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
+ sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
+ de_dt_num=(sumenep-sumene)/aincr
+ write (2,*) " t+ sumene from enesc=",sumenep
+ cost2tab(i+1)=costsave
+ sint2tab(i+1)=sintsave
+C End of diagnostics section.
+#endif
+C
+C Compute the gradient of esc
+C
+ pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
+ pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
+ pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
+ pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
+ pom_dx=dsc_i*dp2_i*cost2tab(i+1)
+ pom_dy=dsc_i*dp2_i*sint2tab(i+1)
+ pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
+ pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
+ pom1=(sumene3*sint2tab(i+1)+sumene1)
+ & *(pom_s1/dscp1+pom_s16*dscp1**4)
+ pom2=(sumene4*cost2tab(i+1)+sumene2)
+ & *(pom_s2/dscp2+pom_s26*dscp2**4)
+ sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
+ sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
+ & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
+ & +x(40)*yy*zz
+ sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
+ sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
+ & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
+ & +x(60)*yy*zz
+ de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
+ & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
+ & +(pom1+pom2)*pom_dx
+#ifdef DEBUG
+ write(2,*), "de_dxx = ", de_dxx,de_dxx_num
+#endif
+C
+ sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
+ sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
+ & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
+ & +x(40)*xx*zz
+ sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
+ sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
+ & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
+ & +x(59)*zz**2 +x(60)*xx*zz
+ de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
+ & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
+ & +(pom1-pom2)*pom_dy
+#ifdef DEBUG
+ write(2,*), "de_dyy = ", de_dyy,de_dyy_num
+#endif
+C
+ de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
+ & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
+ & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
+ & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6)
+ & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2
+ & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
+ & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
+ & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6)
+#ifdef DEBUG
+ write(2,*), "de_dzz = ", de_dzz,de_dzz_num
+#endif
+C
+ de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
+ & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
+ & +pom1*pom_dt1+pom2*pom_dt2
+#ifdef DEBUG
+ write(2,*), "de_dt = ", de_dt,de_dt_num
+#endif
+c
+C
+ cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
+ cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
+ cosfac2xx=cosfac2*xx
+ sinfac2yy=sinfac2*yy
+ do k = 1,3
+ dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
+ & vbld_inv(i+1)
+ dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
+ & vbld_inv(i)
+ pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
+ pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
+c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
+c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
+c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
+c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
+ dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
+ dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
+ dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
+ dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
+ dZZ_Ci1(k)=0.0d0
+ dZZ_Ci(k)=0.0d0
+ do j=1,3
+ dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
+ dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
+ enddo
+
+ dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
+ dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
+ dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
+c
+ dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
+ dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
+ enddo
+
+ do k=1,3
+ dXX_Ctab(k,i)=dXX_Ci(k)
+ dXX_C1tab(k,i)=dXX_Ci1(k)
+ dYY_Ctab(k,i)=dYY_Ci(k)
+ dYY_C1tab(k,i)=dYY_Ci1(k)
+ dZZ_Ctab(k,i)=dZZ_Ci(k)
+ dZZ_C1tab(k,i)=dZZ_Ci1(k)
+ dXX_XYZtab(k,i)=dXX_XYZ(k)
+ dYY_XYZtab(k,i)=dYY_XYZ(k)
+ dZZ_XYZtab(k,i)=dZZ_XYZ(k)
+ enddo
+
+ do k = 1,3
+c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
+c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
+c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
+c & dyy_ci(k)," dzz_ci",dzz_ci(k)
+c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
+c & dt_dci(k)
+c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
+c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
+ gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
+ & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
+ gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
+ & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
+ gsclocx(k,i)= de_dxx*dxx_XYZ(k)
+ & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
+ enddo
+c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
+c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
+
+C to check gradient call subroutine check_grad
+
+ 1 continue
+ enddo
+ return
+ end
+c------------------------------------------------------------------------------
+ double precision function enesc(x,xx,yy,zz,cost2,sint2)
+ implicit none
+ double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
+ & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
+ 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*cost2+yy*sint2))
+ dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
+ & *(xx*cost2-yy*sint2))
+ 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*sint2 + sumene1)*(s1+s1_6)
+ & + (sumene4*cost2 +sumene2)*(s2+s2_6)
+ enesc=sumene
+ 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,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'
+ logical lprn
+C Set lprn=.true. for debugging
+ lprn=.false.
+c lprn=.true.
+ etors=0.0D0
+ do i=iphi_start,iphi_end
+ etors_ii=0.0D0
+ 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)
+ if (energy_dec) etors_ii=etors_ii+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)
+ if (energy_dec) etors_ii=etors_ii+
+ & 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)
+ if (energy_dec) etors_ii=etors_ii+
+ & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
+ gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
+ enddo
+ endif
+ if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
+ & 'etor',i,etors_ii
+ if (lprn)
+ & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
+ & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
+ & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
+ gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
+ write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
+ enddo
+! 6/20/98 - dihedral angle constraints
+ edihcnstr=0.0d0
+ do i=1,ndih_constr
+ itori=idih_constr(i)
+ phii=phi(itori)
+ difi=phii-phi0(i)
+ if (difi.gt.drange(i)) then
+ difi=difi-drange(i)
+ edihcnstr=edihcnstr+0.25d0*ftors*difi**4
+ gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
+ else if (difi.lt.-drange(i)) then
+ difi=difi+drange(i)
+ edihcnstr=edihcnstr+0.25d0*ftors*difi**4
+ gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
+ endif
+! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
+! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
+ enddo
+! write (iout,*) 'edihcnstr',edihcnstr
+ return
+ end
+c------------------------------------------------------------------------------
+ subroutine etor_d(etors_d)
+ etors_d=0.0d0
+ return
+ end
+c----------------------------------------------------------------------------
+#else
+ subroutine etor(etors,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'
+ logical lprn
+C Set lprn=.true. for debugging
+ lprn=.false.
+c lprn=.true.
+ etors=0.0D0
+ do i=iphi_start,iphi_end
+ etors_ii=0.0D0
+ itori=itortyp(itype(i-2))
+ itori1=itortyp(itype(i-1))
+ phii=phi(i)
+ gloci=0.0D0
+C Regular cosine and sine terms
+ do j=1,nterm(itori,itori1)
+ v1ij=v1(j,itori,itori1)
+ v2ij=v2(j,itori,itori1)
+ cosphi=dcos(j*phii)
+ sinphi=dsin(j*phii)
+ etors=etors+v1ij*cosphi+v2ij*sinphi
+ if (energy_dec) etors_ii=etors_ii+
+ & v1ij*cosphi+v2ij*sinphi
+ gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
+ enddo
+C Lorentz terms
+C v1
+C E = SUM ----------------------------------- - v1
+C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
+C
+ cosphi=dcos(0.5d0*phii)
+ sinphi=dsin(0.5d0*phii)
+ do j=1,nlor(itori,itori1)
+ vl1ij=vlor1(j,itori,itori1)
+ vl2ij=vlor2(j,itori,itori1)
+ vl3ij=vlor3(j,itori,itori1)
+ pom=vl2ij*cosphi+vl3ij*sinphi
+ pom1=1.0d0/(pom*pom+1.0d0)
+ etors=etors+vl1ij*pom1
+ if (energy_dec) etors_ii=etors_ii+
+ & vl1ij*pom1
+ pom=-pom*pom1*pom1
+ gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
+ enddo
+C Subtract the constant term
+ etors=etors-v0(itori,itori1)
+ if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
+ & 'etor',i,etors_ii-v0(itori,itori1)
+ if (lprn)
+ & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
+ & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
+ & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
+ gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
+c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
+ enddo
+! 6/20/98 - dihedral angle constraints
+ edihcnstr=0.0d0
+c do i=1,ndih_constr
+ 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*difi**4
+ gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
+ else if (difi.lt.-drange(i)) then
+ difi=difi+drange(i)
+ edihcnstr=edihcnstr+0.25d0*ftors*difi**4
+ gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
+ else
+ difi=0.0
+ endif
+c write (iout,*) "gloci", gloc(i-3,icg)
+cd write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
+cd & rad2deg*phi0(i), rad2deg*drange(i),
+cd & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
+ enddo
+cd write (iout,*) 'edihcnstr',edihcnstr
+ return
+ end
+c----------------------------------------------------------------------------
+ subroutine etor_d(etors_d)
+C 6/23/01 Compute double torsional energy
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include '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=iphid_start,iphid_end
+ 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
+ do j=1,ntermd_1(itori,itori1,itori2)
+ v1cij=v1c(1,j,itori,itori1,itori2)
+ v1sij=v1s(1,j,itori,itori1,itori2)
+ v2cij=v1c(2,j,itori,itori1,itori2)
+ v2sij=v1s(2,j,itori,itori1,itori2)
+ cosphi1=dcos(j*phii)
+ sinphi1=dsin(j*phii)
+ cosphi2=dcos(j*phii1)
+ sinphi2=dsin(j*phii1)
+ etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
+ & v2cij*cosphi2+v2sij*sinphi2
+ gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
+ gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
+ enddo
+ do k=2,ntermd_2(itori,itori1,itori2)
+ do l=1,k-1
+ v1cdij = v2c(k,l,itori,itori1,itori2)
+ v2cdij = v2c(l,k,itori,itori1,itori2)
+ v1sdij = v2s(k,l,itori,itori1,itori2)
+ v2sdij = v2s(l,k,itori,itori1,itori2)
+ cosphi1p2=dcos(l*phii+(k-l)*phii1)
+ cosphi1m2=dcos(l*phii-(k-l)*phii1)
+ sinphi1p2=dsin(l*phii+(k-l)*phii1)
+ sinphi1m2=dsin(l*phii-(k-l)*phii1)
+ etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
+ & v1sdij*sinphi1p2+v2sdij*sinphi1m2
+ gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
+ & -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
+ gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
+ & -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
+ enddo
+ enddo
+ gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
+ gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
+c write (iout,*) "gloci", gloc(i-3,icg)
+ 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 '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
+ esccor_ii=0.0D0
+ isccori=isccortyp(itype(i-2))
+ isccori1=isccortyp(itype(i-1))
+ phii=phi(i)
+cccc Added 9 May 2012
+cc Tauangle is torsional engle depending on the value of first digit
+c(see comment below)
+cc Omicron is flat angle depending on the value of first digit
+c(see comment below)
+
+
+ do intertyp=1,3 !intertyp
+cc Added 09 May 2012 (Adasko)
+cc Intertyp means interaction type of backbone mainchain correlation:
+c 1 = SC...Ca...Ca...Ca
+c 2 = Ca...Ca...Ca...SC
+c 3 = SC...Ca...Ca...SCi
+ gloci=0.0D0
+ if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
+ & (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
+ & (itype(i-1).eq.21)))
+ & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
+ & .or.(itype(i-2).eq.21)))
+ & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
+ & (itype(i-1).eq.21)))) cycle
+ if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
+ if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
+ & cycle
+ do j=1,nterm_sccor(isccori,isccori1)
+ v1ij=v1sccor(j,intertyp,isccori,isccori1)
+ v2ij=v2sccor(j,intertyp,isccori,isccori1)
+ cosphi=dcos(j*tauangle(intertyp,i))
+ sinphi=dsin(j*tauangle(intertyp,i))
+ esccor=esccor+v1ij*cosphi+v2ij*sinphi
+ gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
+ enddo
+ gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
+c write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
+c &gloc_sc(intertyp,i-3,icg)
+ if (lprn)
+ & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
+ & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
+ & (v1sccor(j,intertyp,itori,itori1),j=1,6)
+ & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
+ gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
+ enddo !intertyp
+ enddo
+c do i=1,nres
+c write (iout,*) "W@T@F", gloc_sc(1,i,icg),gloc(i,icg)
+c enddo
+ return
+ end
+c----------------------------------------------------------------------------
+ subroutine multibody(ecorr)
+C This subroutine calculates multi-body contributions to energy following
+C the idea of Skolnick et al. If side chains I and J make a contact and
+C at the same time side chains I+1 and J+1 make a contact, an extra
+C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTACTS'
+ double precision gx(3),gx1(3)
+ logical lprn
+
+C Set lprn=.true. for debugging
+ lprn=.false.
+
+ if (lprn) then
+ write (iout,'(a)') 'Contact function values:'
+ do i=nnt,nct-2
+ write (iout,'(i2,20(1x,i2,f10.5))')
+ & i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
+ enddo
+ endif
+ ecorr=0.0D0
+ do i=nnt,nct
+ do j=1,3
+ gradcorr(j,i)=0.0D0
+ gradxorr(j,i)=0.0D0
+ enddo
+ enddo
+ do i=nnt,nct-2
+
+ DO ISHIFT = 3,4
+
+ i1=i+ishift
+ num_conti=num_cont(i)
+ num_conti1=num_cont(i1)
+ do jj=1,num_conti
+ j=jcont(jj,i)
+ do kk=1,num_conti1
+ j1=jcont(kk,i1)
+ if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
+cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
+cd & ' ishift=',ishift
+C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
+C The system gains extra energy.
+ ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
+ endif ! j1==j+-ishift
+ enddo ! kk
+ enddo ! jj
+
+ ENDDO ! ISHIFT
+
+ enddo ! i
+ return
+ end
+c------------------------------------------------------------------------------
+ double precision function esccorr(i,j,k,l,jj,kk)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTACTS'
+ double precision gx(3),gx1(3)
+ logical lprn
+ lprn=.false.
+ eij=facont(jj,i)
+ ekl=facont(kk,k)
+cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
+C Calculate the multi-body contribution to energy.
+C Calculate multi-body contributions to the gradient.
+cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
+cd & k,l,(gacont(m,kk,k),m=1,3)
+ do m=1,3
+ gx(m) =ekl*gacont(m,jj,i)
+ gx1(m)=eij*gacont(m,kk,k)
+ gradxorr(m,i)=gradxorr(m,i)-gx(m)
+ gradxorr(m,j)=gradxorr(m,j)+gx(m)
+ gradxorr(m,k)=gradxorr(m,k)-gx1(m)
+ gradxorr(m,l)=gradxorr(m,l)+gx1(m)
+ enddo
+ do m=i,j-1
+ do ll=1,3
+ gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
+ enddo
+ enddo
+ do m=k,l-1
+ do ll=1,3
+ gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
+ enddo
+ enddo
+ esccorr=-eij*ekl
+ return
+ end
+c------------------------------------------------------------------------------
+ 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'
+#ifdef MPI
+ include "mpif.h"
+ parameter (max_cont=maxconts)
+ parameter (max_dim=26)
+ integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
+ double precision zapas(max_dim,maxconts,max_fg_procs),
+ & zapas_recv(max_dim,maxconts,max_fg_procs)
+ common /przechowalnia/ zapas
+ integer status(MPI_STATUS_SIZE),req(maxconts*2),
+ & status_array(MPI_STATUS_SIZE,maxconts*2)
+#endif
+ include 'COMMON.SETUP'
+ include 'COMMON.FFIELD'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.LOCAL'
+ double precision gx(3),gx1(3),time00
+ logical lprn,ldone
+
+C Set lprn=.true. for debugging
+ lprn=.false.
+#ifdef MPI
+ n_corr=0
+ n_corr1=0
+ if (nfgtasks.le.1) goto 30
+ if (lprn) then
+ write (iout,'(a)') 'Contact function values before RECEIVE:'
+ 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
+ call flush(iout)
+ do i=1,ntask_cont_from
+ ncont_recv(i)=0
+ enddo
+ do i=1,ntask_cont_to
+ ncont_sent(i)=0
+ enddo
+c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
+c & ntask_cont_to
+C Make the list of contacts to send to send to other procesors
+c write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
+c call flush(iout)
+ do i=iturn3_start,iturn3_end
+c write (iout,*) "make contact list turn3",i," num_cont",
+c & num_cont_hb(i)
+ call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
+ enddo
+ do i=iturn4_start,iturn4_end
+c write (iout,*) "make contact list turn4",i," num_cont",
+c & num_cont_hb(i)
+ call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
+ enddo
+ do ii=1,nat_sent
+ i=iat_sent(ii)
+c write (iout,*) "make contact list longrange",i,ii," num_cont",
+c & num_cont_hb(i)
+ do j=1,num_cont_hb(i)
+ do k=1,4
+ jjc=jcont_hb(j,i)
+ iproc=iint_sent_local(k,jjc,ii)
+c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
+ if (iproc.gt.0) then
+ ncont_sent(iproc)=ncont_sent(iproc)+1
+ nn=ncont_sent(iproc)
+ zapas(1,nn,iproc)=i
+ zapas(2,nn,iproc)=jjc
+ zapas(3,nn,iproc)=facont_hb(j,i)
+ zapas(4,nn,iproc)=ees0p(j,i)
+ zapas(5,nn,iproc)=ees0m(j,i)
+ zapas(6,nn,iproc)=gacont_hbr(1,j,i)
+ zapas(7,nn,iproc)=gacont_hbr(2,j,i)
+ zapas(8,nn,iproc)=gacont_hbr(3,j,i)
+ zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
+ zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
+ zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
+ zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
+ zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
+ zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
+ zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
+ zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
+ zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
+ zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
+ zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
+ zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
+ zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
+ zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
+ zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
+ zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
+ zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
+ zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
+ endif
+ enddo
+ enddo
+ enddo
+ if (lprn) then
+ write (iout,*)
+ & "Numbers of contacts to be sent to other processors",
+ & (ncont_sent(i),i=1,ntask_cont_to)
+ write (iout,*) "Contacts sent"
+ do ii=1,ntask_cont_to
+ nn=ncont_sent(ii)
+ iproc=itask_cont_to(ii)
+ write (iout,*) nn," contacts to processor",iproc,
+ & " of CONT_TO_COMM group"
+ do i=1,nn
+ write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
+ enddo
+ enddo
+ call flush(iout)
+ endif
+ CorrelType=477
+ CorrelID=fg_rank+1
+ CorrelType1=478
+ CorrelID1=nfgtasks+fg_rank+1
+ ireq=0
+C Receive the numbers of needed contacts from other processors
+ do ii=1,ntask_cont_from
+ iproc=itask_cont_from(ii)
+ ireq=ireq+1
+ call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
+ & FG_COMM,req(ireq),IERR)
+ enddo
+c write (iout,*) "IRECV ended"
+c call flush(iout)
+C Send the number of contacts needed by other processors
+ do ii=1,ntask_cont_to
+ iproc=itask_cont_to(ii)
+ ireq=ireq+1
+ call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
+ & FG_COMM,req(ireq),IERR)
+ enddo
+c write (iout,*) "ISEND ended"
+c write (iout,*) "number of requests (nn)",ireq
+ call flush(iout)
+ if (ireq.gt.0)
+ & call MPI_Waitall(ireq,req,status_array,ierr)
+c write (iout,*)
+c & "Numbers of contacts to be received from other processors",
+c & (ncont_recv(i),i=1,ntask_cont_from)
+c call flush(iout)
+C Receive contacts
+ ireq=0
+ do ii=1,ntask_cont_from
+ iproc=itask_cont_from(ii)
+ nn=ncont_recv(ii)
+c write (iout,*) "Receiving",nn," contacts from processor",iproc,
+c & " of CONT_TO_COMM group"
+ call flush(iout)
+ if (nn.gt.0) then
+ ireq=ireq+1
+ call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
+ & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
+c write (iout,*) "ireq,req",ireq,req(ireq)
+ endif
+ enddo
+C Send the contacts to processors that need them
+ do ii=1,ntask_cont_to
+ iproc=itask_cont_to(ii)
+ nn=ncont_sent(ii)
+c write (iout,*) nn," contacts to processor",iproc,
+c & " of CONT_TO_COMM group"
+ if (nn.gt.0) then
+ ireq=ireq+1
+ call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
+ & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
+c write (iout,*) "ireq,req",ireq,req(ireq)
+c do i=1,nn
+c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
+c enddo
+ endif
+ enddo
+c write (iout,*) "number of requests (contacts)",ireq
+c write (iout,*) "req",(req(i),i=1,4)
+c call flush(iout)
+ if (ireq.gt.0)
+ & call MPI_Waitall(ireq,req,status_array,ierr)
+ do iii=1,ntask_cont_from
+ iproc=itask_cont_from(iii)
+ nn=ncont_recv(iii)
+ if (lprn) then
+ write (iout,*) "Received",nn," contacts from processor",iproc,
+ & " of CONT_FROM_COMM group"
+ call flush(iout)
+ do i=1,nn
+ write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
+ enddo
+ call flush(iout)
+ endif
+ do i=1,nn
+ ii=zapas_recv(1,i,iii)
+c Flag the received contacts to prevent double-counting
+ jj=-zapas_recv(2,i,iii)
+c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
+c call flush(iout)
+ nnn=num_cont_hb(ii)+1
+ num_cont_hb(ii)=nnn
+ jcont_hb(nnn,ii)=jj
+ facont_hb(nnn,ii)=zapas_recv(3,i,iii)
+ ees0p(nnn,ii)=zapas_recv(4,i,iii)
+ ees0m(nnn,ii)=zapas_recv(5,i,iii)
+ gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
+ gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
+ gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
+ gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
+ gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
+ gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
+ gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
+ gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
+ gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
+ gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
+ gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
+ gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
+ gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
+ gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
+ gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
+ gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
+ gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
+ gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
+ gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
+ gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
+ gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
+ enddo
+ enddo
+ call flush(iout)
+ if (lprn) then
+ write (iout,'(a)') 'Contact function values after receive:'
+ do i=nnt,nct-2
+ write (iout,'(2i3,50(1x,i3,f5.2))')
+ & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
+ & j=1,num_cont_hb(i))
+ enddo
+ call flush(iout)
+ endif
+ 30 continue
+#endif
+ if (lprn) then
+ write (iout,'(a)') 'Contact function values:'
+ do i=nnt,nct-2
+ write (iout,'(2i3,50(1x,i3,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=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
+ 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
+ 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.
+ ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
+ & 'ecorrh',i,j,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 add_hb_contact(ii,jj,itask)
+ implicit real*8 (a-h,o-z)
+ include "DIMENSIONS"
+ include "COMMON.IOUNITS"
+ integer max_cont
+ integer max_dim
+ parameter (max_cont=maxconts)
+ parameter (max_dim=26)
+ include "COMMON.CONTACTS"
+ double precision zapas(max_dim,maxconts,max_fg_procs),
+ & zapas_recv(max_dim,maxconts,max_fg_procs)
+ common /przechowalnia/ zapas
+ integer i,j,ii,jj,iproc,itask(4),nn
+c write (iout,*) "itask",itask
+ do i=1,2
+ iproc=itask(i)
+ if (iproc.gt.0) then
+ do j=1,num_cont_hb(ii)
+ jjc=jcont_hb(j,ii)
+c write (iout,*) "i",ii," j",jj," jjc",jjc
+ if (jjc.eq.jj) then
+ ncont_sent(iproc)=ncont_sent(iproc)+1
+ nn=ncont_sent(iproc)
+ zapas(1,nn,iproc)=ii
+ zapas(2,nn,iproc)=jjc
+ zapas(3,nn,iproc)=facont_hb(j,ii)
+ zapas(4,nn,iproc)=ees0p(j,ii)
+ zapas(5,nn,iproc)=ees0m(j,ii)
+ zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
+ zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
+ zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
+ zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
+ zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
+ zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
+ zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
+ zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
+ zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
+ zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
+ zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
+ zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
+ zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
+ zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
+ zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
+ zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
+ zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
+ zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
+ zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
+ zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
+ zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
+ exit
+ endif
+ enddo
+ endif
+ enddo
+ 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"
+ parameter (max_cont=maxconts)
+ parameter (max_dim=70)
+ integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
+ double precision zapas(max_dim,maxconts,max_fg_procs),
+ & zapas_recv(max_dim,maxconts,max_fg_procs)
+ common /przechowalnia/ zapas
+ integer status(MPI_STATUS_SIZE),req(maxconts*2),
+ & status_array(MPI_STATUS_SIZE,maxconts*2)
+#endif
+ include 'COMMON.SETUP'
+ include 'COMMON.FFIELD'
+ include 'COMMON.DERIV'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.CONTROL'
+ 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
+#ifdef MPI
+ do i=1,nres
+ num_cont_hb_old(i)=num_cont_hb(i)
+ enddo
+ n_corr=0
+ n_corr1=0
+ if (nfgtasks.le.1) goto 30
+ if (lprn) then
+ write (iout,'(a)') 'Contact function values before RECEIVE:'
+ 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
+ call flush(iout)
+ do i=1,ntask_cont_from
+ ncont_recv(i)=0
+ enddo
+ do i=1,ntask_cont_to
+ ncont_sent(i)=0
+ enddo
+c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
+c & ntask_cont_to
+C Make the list of contacts to send to send to other procesors
+ do i=iturn3_start,iturn3_end
+c write (iout,*) "make contact list turn3",i," num_cont",
+c & num_cont_hb(i)
+ call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
+ enddo
+ do i=iturn4_start,iturn4_end
+c write (iout,*) "make contact list turn4",i," num_cont",
+c & num_cont_hb(i)
+ call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
+ enddo
+ do ii=1,nat_sent
+ i=iat_sent(ii)
+c write (iout,*) "make contact list longrange",i,ii," num_cont",
+c & num_cont_hb(i)
+ do j=1,num_cont_hb(i)
+ do k=1,4
+ jjc=jcont_hb(j,i)
+ iproc=iint_sent_local(k,jjc,ii)
+c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
+ if (iproc.ne.0) then
+ ncont_sent(iproc)=ncont_sent(iproc)+1
+ nn=ncont_sent(iproc)
+ zapas(1,nn,iproc)=i
+ zapas(2,nn,iproc)=jjc
+ zapas(3,nn,iproc)=d_cont(j,i)
+ ind=3
+ do kk=1,3
+ ind=ind+1
+ zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
+ enddo
+ do kk=1,2
+ do ll=1,2
+ ind=ind+1
+ zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
+ enddo
+ enddo
+ do jj=1,5
+ do kk=1,3
+ do ll=1,2
+ do mm=1,2
+ ind=ind+1
+ zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
+ enddo
+ enddo
+ enddo
+ enddo
+ endif
+ enddo
+ enddo
+ enddo
+ if (lprn) then
+ write (iout,*)
+ & "Numbers of contacts to be sent to other processors",
+ & (ncont_sent(i),i=1,ntask_cont_to)
+ write (iout,*) "Contacts sent"
+ do ii=1,ntask_cont_to
+ nn=ncont_sent(ii)
+ iproc=itask_cont_to(ii)
+ write (iout,*) nn," contacts to processor",iproc,
+ & " of CONT_TO_COMM group"
+ do i=1,nn
+ write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
+ enddo
+ enddo
+ call flush(iout)
+ endif
+ CorrelType=477
+ CorrelID=fg_rank+1
+ CorrelType1=478
+ CorrelID1=nfgtasks+fg_rank+1
+ ireq=0
+C Receive the numbers of needed contacts from other processors
+ do ii=1,ntask_cont_from
+ iproc=itask_cont_from(ii)
+ ireq=ireq+1
+ call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
+ & FG_COMM,req(ireq),IERR)
+ enddo
+c write (iout,*) "IRECV ended"
+c call flush(iout)
+C Send the number of contacts needed by other processors
+ do ii=1,ntask_cont_to
+ iproc=itask_cont_to(ii)
+ ireq=ireq+1
+ call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
+ & FG_COMM,req(ireq),IERR)
+ enddo
+c write (iout,*) "ISEND ended"
+c write (iout,*) "number of requests (nn)",ireq
+ call flush(iout)
+ if (ireq.gt.0)
+ & call MPI_Waitall(ireq,req,status_array,ierr)
+c write (iout,*)
+c & "Numbers of contacts to be received from other processors",
+c & (ncont_recv(i),i=1,ntask_cont_from)
+c call flush(iout)
+C Receive contacts
+ ireq=0
+ do ii=1,ntask_cont_from
+ iproc=itask_cont_from(ii)
+ nn=ncont_recv(ii)
+c write (iout,*) "Receiving",nn," contacts from processor",iproc,
+c & " of CONT_TO_COMM group"
+ call flush(iout)
+ if (nn.gt.0) then
+ ireq=ireq+1
+ call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
+ & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
+c write (iout,*) "ireq,req",ireq,req(ireq)
+ endif
+ enddo
+C Send the contacts to processors that need them
+ do ii=1,ntask_cont_to
+ iproc=itask_cont_to(ii)
+ nn=ncont_sent(ii)
+c write (iout,*) nn," contacts to processor",iproc,
+c & " of CONT_TO_COMM group"
+ if (nn.gt.0) then
+ ireq=ireq+1
+ call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
+ & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
+c write (iout,*) "ireq,req",ireq,req(ireq)
+c do i=1,nn
+c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
+c enddo
+ endif
+ enddo
+c write (iout,*) "number of requests (contacts)",ireq
+c write (iout,*) "req",(req(i),i=1,4)
+c call flush(iout)
+ if (ireq.gt.0)
+ & call MPI_Waitall(ireq,req,status_array,ierr)
+ do iii=1,ntask_cont_from
+ iproc=itask_cont_from(iii)
+ nn=ncont_recv(iii)
+ if (lprn) then
+ write (iout,*) "Received",nn," contacts from processor",iproc,
+ & " of CONT_FROM_COMM group"
+ call flush(iout)
+ do i=1,nn
+ write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
+ enddo
+ call flush(iout)
+ endif
+ do i=1,nn
+ ii=zapas_recv(1,i,iii)
+c Flag the received contacts to prevent double-counting
+ jj=-zapas_recv(2,i,iii)
+c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
+c call flush(iout)
+ nnn=num_cont_hb(ii)+1
+ num_cont_hb(ii)=nnn
+ jcont_hb(nnn,ii)=jj
+ d_cont(nnn,ii)=zapas_recv(3,i,iii)
+ ind=3
+ do kk=1,3
+ ind=ind+1
+ grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
+ enddo
+ do kk=1,2
+ do ll=1,2
+ ind=ind+1
+ a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
+ enddo
+ enddo
+ do jj=1,5
+ do kk=1,3
+ do ll=1,2
+ do mm=1,2
+ ind=ind+1
+ a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ call flush(iout)
+ if (lprn) then
+ write (iout,'(a)') 'Contact function values after receive:'
+ do i=nnt,nct-2
+ write (iout,'(2i3,50(1x,i3,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
+ call flush(iout)
+ endif
+ 30 continue
+#endif
+ 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)
+ 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------------------------------------------------------------------------------
+ subroutine add_hb_contact_eello(ii,jj,itask)
+ implicit real*8 (a-h,o-z)
+ include "DIMENSIONS"
+ include "COMMON.IOUNITS"
+ integer max_cont
+ integer max_dim
+ parameter (max_cont=maxconts)
+ parameter (max_dim=70)
+ include "COMMON.CONTACTS"
+ double precision zapas(max_dim,maxconts,max_fg_procs),
+ & zapas_recv(max_dim,maxconts,max_fg_procs)
+ common /przechowalnia/ zapas
+ integer i,j,ii,jj,iproc,itask(4),nn
+c write (iout,*) "itask",itask
+ do i=1,2
+ iproc=itask(i)
+ if (iproc.gt.0) then
+ do j=1,num_cont_hb(ii)
+ jjc=jcont_hb(j,ii)
+c write (iout,*) "send turns i",ii," j",jj," jjc",jjc
+ if (jjc.eq.jj) then
+ ncont_sent(iproc)=ncont_sent(iproc)+1
+ nn=ncont_sent(iproc)
+ zapas(1,nn,iproc)=ii
+ zapas(2,nn,iproc)=jjc
+ zapas(3,nn,iproc)=d_cont(j,ii)
+ ind=3
+ do kk=1,3
+ ind=ind+1
+ zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
+ enddo
+ do kk=1,2
+ do ll=1,2
+ ind=ind+1
+ zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
+ enddo
+ enddo
+ do jj=1,5
+ do kk=1,3
+ do ll=1,2
+ do mm=1,2
+ ind=ind+1
+ zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
+ enddo
+ enddo
+ enddo
+ enddo
+ exit
+ endif
+ enddo
+ endif
+ 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'
+ 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,'(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
+ ehbcorr=ekont*ees
+ 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 = itortyp(itype(j+1))
+ else
+ itj1=ntortyp+1
+ endif
+ do iii=1,2
+ dipi(iii,1)=Ub2(iii,i)
+ dipderi(iii)=Ub2der(iii,i)
+ dipi(iii,2)=b1(iii,iti1)
+ dipj(iii,1)=Ub2(iii,j)
+ dipderj(iii)=Ub2der(iii,j)
+ dipj(iii,2)=b1(iii,itj1)
+ enddo
+ kkk=0
+ do iii=1,2
+ call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
+ do jjj=1,2
+ kkk=kkk+1
+ dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
+ enddo
+ enddo
+ 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=itortyp(itype(i))
+ else
+ iti=ntortyp+1
+ endif
+ itk1=itortyp(itype(k+1))
+ itj=itortyp(itype(j))
+ if (l.lt.nres-1) then
+ itl1=itortyp(itype(l+1))
+ else
+ itl1=ntortyp+1
+ endif
+C A1 kernel(j+1) A2T
+cd do iii=1,2
+cd write (iout,'(3f10.5,5x,3f10.5)')
+cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
+cd enddo
+ call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
+ & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
+ & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
+C Following matrices are needed only for 6-th order cumulants
+ IF (wcorr6.gt.0.0d0) THEN
+ call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
+ & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
+ & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
+ call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
+ & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
+ & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
+ & ADtEAderx(1,1,1,1,1,1))
+ lprn=.false.
+ call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
+ & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
+ & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
+ & ADtEA1derx(1,1,1,1,1,1))
+ ENDIF
+C End 6-th order cumulants
+cd lprn=.false.
+cd if (lprn) then
+cd write (2,*) 'In calc_eello6'
+cd do iii=1,2
+cd write (2,*) 'iii=',iii
+cd do kkk=1,5
+cd write (2,*) 'kkk=',kkk
+cd do jjj=1,2
+cd write (2,'(3(2f10.5),5x)')
+cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
+cd enddo
+cd enddo
+cd enddo
+cd endif
+ call transpose2(EUgder(1,1,k),auxmat(1,1))
+ call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
+ call transpose2(EUg(1,1,k),auxmat(1,1))
+ call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
+ call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
+ do iii=1,2
+ do kkk=1,5
+ do lll=1,3
+ call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
+ & EAEAderx(1,1,lll,kkk,iii,1))
+ enddo
+ enddo
+ enddo
+C A1T kernel(i+1) A2
+ call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
+ & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
+ & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
+C Following matrices are needed only for 6-th order cumulants
+ IF (wcorr6.gt.0.0d0) THEN
+ call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
+ & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
+ & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
+ call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
+ & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
+ & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
+ & ADtEAderx(1,1,1,1,1,2))
+ call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
+ & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
+ & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
+ & ADtEA1derx(1,1,1,1,1,2))
+ ENDIF
+C End 6-th order cumulants
+ call transpose2(EUgder(1,1,l),auxmat(1,1))
+ call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
+ call transpose2(EUg(1,1,l),auxmat(1,1))
+ call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
+ call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
+ do iii=1,2
+ do kkk=1,5
+ do lll=1,3
+ call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
+ & EAEAderx(1,1,lll,kkk,iii,2))
+ enddo
+ enddo
+ enddo
+C AEAb1 and AEAb2
+C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
+C They are needed only when the fifth- or the sixth-order cumulants are
+C indluded.
+ IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
+ call transpose2(AEA(1,1,1),auxmat(1,1))
+ call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
+ call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
+ call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
+ call transpose2(AEAderg(1,1,1),auxmat(1,1))
+ call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
+ call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
+ call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
+ call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
+ call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
+ call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
+ call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
+ call transpose2(AEA(1,1,2),auxmat(1,1))
+ call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
+ call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
+ call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
+ call transpose2(AEAderg(1,1,2),auxmat(1,1))
+ call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
+ call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
+ call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
+ call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
+ call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
+ call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
+ call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
+C Calculate the Cartesian derivatives of the vectors.
+ do iii=1,2
+ do kkk=1,5
+ do lll=1,3
+ call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
+ call matvec2(auxmat(1,1),b1(1,iti),
+ & AEAb1derx(1,lll,kkk,iii,1,1))
+ call matvec2(auxmat(1,1),Ub2(1,i),
+ & AEAb2derx(1,lll,kkk,iii,1,1))
+ call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
+ & AEAb1derx(1,lll,kkk,iii,2,1))
+ call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
+ & AEAb2derx(1,lll,kkk,iii,2,1))
+ call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
+ call matvec2(auxmat(1,1),b1(1,itj),
+ & AEAb1derx(1,lll,kkk,iii,1,2))
+ call matvec2(auxmat(1,1),Ub2(1,j),
+ & AEAb2derx(1,lll,kkk,iii,1,2))
+ call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
+ & AEAb1derx(1,lll,kkk,iii,2,2))
+ call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
+ & AEAb2derx(1,lll,kkk,iii,2,2))
+ enddo
+ enddo
+ enddo
+ ENDIF
+C End vectors
+ else
+C Antiparallel orientation of the two CA-CA-CA frames.
+ if (i.gt.1) then
+ iti=itortyp(itype(i))
+ else
+ iti=ntortyp+1
+ endif
+ itk1=itortyp(itype(k+1))
+ itl=itortyp(itype(l))
+ itj=itortyp(itype(j))
+ if (j.lt.nres-1) then
+ itj1=itortyp(itype(j+1))
+ else
+ itj1=ntortyp+1
+ endif
+C A2 kernel(j-1)T A1T
+ call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
+ & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
+ & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
+C Following matrices are needed only for 6-th order cumulants
+ IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
+ & j.eq.i+4 .and. l.eq.i+3)) THEN
+ call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
+ & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
+ & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
+ call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
+ & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
+ & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
+ & ADtEAderx(1,1,1,1,1,1))
+ call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
+ & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
+ & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
+ & ADtEA1derx(1,1,1,1,1,1))
+ ENDIF
+C End 6-th order cumulants
+ call transpose2(EUgder(1,1,k),auxmat(1,1))
+ call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
+ call transpose2(EUg(1,1,k),auxmat(1,1))
+ call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
+ call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
+ do iii=1,2
+ do kkk=1,5
+ do lll=1,3
+ call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
+ & EAEAderx(1,1,lll,kkk,iii,1))
+ enddo
+ enddo
+ enddo
+C A2T kernel(i+1)T A1
+ call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
+ & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
+ & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
+C Following matrices are needed only for 6-th order cumulants
+ IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
+ & j.eq.i+4 .and. l.eq.i+3)) THEN
+ call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
+ & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
+ & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
+ call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
+ & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
+ & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
+ & ADtEAderx(1,1,1,1,1,2))
+ call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
+ & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
+ & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
+ & ADtEA1derx(1,1,1,1,1,2))
+ ENDIF
+C End 6-th order cumulants
+ call transpose2(EUgder(1,1,j),auxmat(1,1))
+ call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
+ call transpose2(EUg(1,1,j),auxmat(1,1))
+ call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
+ call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
+ do iii=1,2
+ do kkk=1,5
+ do lll=1,3
+ call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
+ & EAEAderx(1,1,lll,kkk,iii,2))
+ enddo
+ enddo
+ enddo
+C AEAb1 and AEAb2
+C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
+C They are needed only when the fifth- or the sixth-order cumulants are
+C indluded.
+ IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
+ & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
+ call transpose2(AEA(1,1,1),auxmat(1,1))
+ call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
+ call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
+ call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
+ call transpose2(AEAderg(1,1,1),auxmat(1,1))
+ call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
+ call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
+ call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
+ call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
+ call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
+ call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
+ call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
+ call transpose2(AEA(1,1,2),auxmat(1,1))
+ call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
+ call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
+ call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
+ call transpose2(AEAderg(1,1,2),auxmat(1,1))
+ call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
+ call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
+ call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
+ call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
+ call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
+ call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
+ call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
+C Calculate the Cartesian derivatives of the vectors.
+ do iii=1,2
+ do kkk=1,5
+ do lll=1,3
+ call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
+ call matvec2(auxmat(1,1),b1(1,iti),
+ & AEAb1derx(1,lll,kkk,iii,1,1))
+ call matvec2(auxmat(1,1),Ub2(1,i),
+ & AEAb2derx(1,lll,kkk,iii,1,1))
+ call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
+ & AEAb1derx(1,lll,kkk,iii,2,1))
+ call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
+ & AEAb2derx(1,lll,kkk,iii,2,1))
+ call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
+ call matvec2(auxmat(1,1),b1(1,itl),
+ & AEAb1derx(1,lll,kkk,iii,1,2))
+ call matvec2(auxmat(1,1),Ub2(1,l),
+ & AEAb2derx(1,lll,kkk,iii,1,2))
+ call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
+ & AEAb1derx(1,lll,kkk,iii,2,2))
+ call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
+ & AEAb2derx(1,lll,kkk,iii,2,2))
+ enddo
+ enddo
+ enddo
+ ENDIF
+C End vectors
+ endif
+ return
+ end
+C---------------------------------------------------------------------------
+ subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
+ & KK,KKderg,AKA,AKAderg,AKAderx)
+ implicit none
+ integer nderg
+ logical transp
+ double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
+ & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
+ & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
+ integer iii,kkk,lll
+ integer jjj,mmm
+ logical lprn
+ common /kutas/ lprn
+ call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
+ do iii=1,nderg
+ call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
+ & AKAderg(1,1,iii))
+ enddo
+cd if (lprn) write (2,*) 'In kernel'
+ do kkk=1,5
+cd if (lprn) write (2,*) 'kkk=',kkk
+ do lll=1,3
+ call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
+ & KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
+cd if (lprn) then
+cd write (2,*) 'lll=',lll
+cd write (2,*) 'iii=1'
+cd do jjj=1,2
+cd write (2,'(3(2f10.5),5x)')
+cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
+cd enddo
+cd endif
+ call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
+ & KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
+cd if (lprn) then
+cd write (2,*) 'lll=',lll
+cd write (2,*) 'iii=2'
+cd do jjj=1,2
+cd write (2,'(3(2f10.5),5x)')
+cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
+cd enddo
+cd endif
+ enddo
+ enddo
+ return
+ end
+C---------------------------------------------------------------------------
+ double precision function eello4(i,j,k,l,jj,kk)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.TORSION'
+ include 'COMMON.VAR'
+ include 'COMMON.GEO'
+ double precision pizda(2,2),ggg1(3),ggg2(3)
+cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
+cd eello4=0.0d0
+cd return
+cd endif
+cd print *,'eello4:',i,j,k,l,jj,kk
+cd write (2,*) 'i',i,' j',j,' k',k,' l',l
+cd call checkint4(i,j,k,l,jj,kk,eel4_num)
+cold eij=facont_hb(jj,i)
+cold ekl=facont_hb(kk,k)
+cold ekont=eij*ekl
+ eel4=-EAEA(1,1,1)-EAEA(2,2,1)
+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
+ eello4=ekont*eel4
+cd write (2,*) 'ekont',ekont
+cd write (iout,*) 'eello4',ekont*eel4
+ return
+ end
+C---------------------------------------------------------------------------
+ double precision function eello5(i,j,k,l,jj,kk)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.TORSION'
+ include 'COMMON.VAR'
+ include 'COMMON.GEO'
+ double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
+ double precision ggg1(3),ggg2(3)
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C C
+C Parallel chains C
+C C
+C o o o o C
+C /l\ / \ \ / \ / \ / C
+C / \ / \ \ / \ / \ / C
+C j| o |l1 | o | o| o | | o |o C
+C \ |/k\| |/ \| / |/ \| |/ \| C
+C \i/ \ / \ / / \ / \ C
+C o k1 o C
+C (I) (II) (III) (IV) C
+C C
+C eello5_1 eello5_2 eello5_3 eello5_4 C
+C C
+C Antiparallel chains C
+C C
+C o o o o C
+C /j\ / \ \ / \ / \ / C
+C / \ / \ \ / \ / \ / C
+C j1| o |l | o | o| o | | o |o C
+C \ |/k\| |/ \| / |/ \| |/ \| C
+C \i/ \ / \ / / \ / \ C
+C o k1 o C
+C (I) (II) (III) (IV) C
+C C
+C eello5_1 eello5_2 eello5_3 eello5_4 C
+C C
+C o denotes a local interaction, vertical lines an electrostatic interaction. C
+C C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
+cd eello5=0.0d0
+cd return
+cd endif
+cd write (iout,*)
+cd & 'EELLO5: Contacts have occurred for peptide groups',i,j,
+cd & ' and',k,l
+ itk=itortyp(itype(k))
+ itl=itortyp(itype(l))
+ itj=itortyp(itype(j))
+ eello5_1=0.0d0
+ eello5_2=0.0d0
+ eello5_3=0.0d0
+ eello5_4=0.0d0
+cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
+cd & eel5_3_num,eel5_4_num)
+ do iii=1,2
+ do kkk=1,5
+ do lll=1,3
+ derx(lll,kkk,iii)=0.0d0
+ enddo
+ enddo
+ enddo
+cd eij=facont_hb(jj,i)
+cd ekl=facont_hb(kk,k)
+cd ekont=eij*ekl
+cd write (iout,*)'Contacts have occurred for peptide groups',
+cd & i,j,' fcont:',eij,' eij',' and ',k,l
+cd goto 1111
+C Contribution from the graph I.
+cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
+cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
+ call transpose2(EUg(1,1,k),auxmat(1,1))
+ call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
+ vv(1)=pizda(1,1)-pizda(2,2)
+ vv(2)=pizda(1,2)+pizda(2,1)
+ eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
+ & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
+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
+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))
+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
+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))
+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,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))
+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
+ 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))
+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
+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))
+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
+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 (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)+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)
+ gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
+ gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
+ enddo
+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 (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
+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 Parallel Antiparallel
+C
+C o o
+C /l\ /j\
+C / \ / \
+C /| o | | o |\
+C \ j|/k\| / \ |/k\|l /
+C \ / \ / \ / \ /
+C o o o o
+C i i
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ itk=itortyp(itype(k))
+ s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
+ s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
+ s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
+ call transpose2(EUgC(1,1,k),auxmat(1,1))
+ call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
+ vv1(1)=pizda1(1,1)-pizda1(2,2)
+ vv1(2)=pizda1(1,2)+pizda1(2,1)
+ s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
+ vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
+ vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
+ s5=scalar2(vv(1),Dtobr2(1,i))
+cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
+ eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
+ if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
+ & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
+ & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
+ & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
+ & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
+ & +scalar2(vv(1),Dtobr2der(1,i)))
+ call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
+ vv1(1)=pizda1(1,1)-pizda1(2,2)
+ vv1(2)=pizda1(1,2)+pizda1(2,1)
+ vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
+ vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
+ if (l.eq.j+1) then
+ g_corr6_loc(l-1)=g_corr6_loc(l-1)
+ & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
+ & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
+ & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
+ & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
+ else
+ g_corr6_loc(j-1)=g_corr6_loc(j-1)
+ & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
+ & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
+ & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
+ & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
+ endif
+ call transpose2(EUgCder(1,1,k),auxmat(1,1))
+ call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
+ vv1(1)=pizda1(1,1)-pizda1(2,2)
+ vv1(2)=pizda1(1,2)+pizda1(2,1)
+ if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
+ & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
+ & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
+ & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
+ do iii=1,2
+ if (swap) then
+ ind=3-iii
+ else
+ ind=iii
+ endif
+ do kkk=1,5
+ do lll=1,3
+ s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
+ s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
+ s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
+ call transpose2(EUgC(1,1,k),auxmat(1,1))
+ call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
+ & pizda1(1,1))
+ vv1(1)=pizda1(1,1)-pizda1(2,2)
+ vv1(2)=pizda1(1,2)+pizda1(2,1)
+ s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
+ vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
+ & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
+ vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
+ & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
+ s5=scalar2(vv(1),Dtobr2(1,i))
+ derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
+ enddo
+ enddo
+ enddo
+ return
+ end
+c----------------------------------------------------------------------------
+ double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.TORSION'
+ include 'COMMON.VAR'
+ include 'COMMON.GEO'
+ logical swap
+ double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
+ & auxvec1(2),auxvec2(1),auxmat1(2,2)
+ logical lprn
+ common /kutas/ lprn
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C C
+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 (i.gt.1) then
+#ifdef MOMENT
+ s1=dipderg(1,jj,i)*dip(1,kk,k)
+#endif
+ s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
+ call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
+ s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
+ s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
+#ifdef MOMENT
+ g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
+#else
+ g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
+#endif
+c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
+ endif
+C Derivatives in gamma(k-1)
+#ifdef MOMENT
+ s1=dip(1,jj,i)*dipderg(1,kk,k)
+#endif
+ call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
+ s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
+ call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
+ s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
+ call transpose2(EUgder(1,1,k),auxmat1(1,1))
+ call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
+ vv(1)=pizda(1,1)-pizda(2,2)
+ vv(2)=pizda(1,2)+pizda(2,1)
+ s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
+#ifdef MOMENT
+ g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
+#else
+ g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
+#endif
+c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
+C Derivatives in gamma(j-1) or gamma(l-1)
+ if (j.gt.1) then
+#ifdef MOMENT
+ s1=dipderg(3,jj,i)*dip(1,kk,k)
+#endif
+ call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
+ s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
+ s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
+ call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
+ vv(1)=pizda(1,1)-pizda(2,2)
+ vv(2)=pizda(1,2)+pizda(2,1)
+ s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
+#ifdef MOMENT
+ if (swap) then
+ g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
+ else
+ g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
+ endif
+#endif
+ g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
+c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
+ endif
+C Derivatives in gamma(l-1) or gamma(j-1)
+ if (l.gt.1) then
+#ifdef MOMENT
+ s1=dip(1,jj,i)*dipderg(3,kk,k)
+#endif
+ call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
+ s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
+ call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
+ s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
+ call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
+ vv(1)=pizda(1,1)-pizda(2,2)
+ vv(2)=pizda(1,2)+pizda(2,1)
+ s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
+#ifdef MOMENT
+ if (swap) then
+ g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
+ else
+ g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
+ endif
+#endif
+ g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
+c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
+ endif
+C Cartesian derivatives.
+ if (lprn) then
+ write (2,*) 'In eello6_graph2'
+ do iii=1,2
+ write (2,*) 'iii=',iii
+ do kkk=1,5
+ write (2,*) 'kkk=',kkk
+ do jjj=1,2
+ write (2,'(3(2f10.5),5x)')
+ & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
+ enddo
+ enddo
+ enddo
+ endif
+ do iii=1,2
+ do kkk=1,5
+ do lll=1,3
+#ifdef MOMENT
+ if (iii.eq.1) then
+ s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
+ else
+ s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
+ endif
+#endif
+ call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
+ & auxvec(1))
+ s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
+ call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
+ & auxvec(1))
+ s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
+ call transpose2(EUg(1,1,k),auxmat(1,1))
+ call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
+ & pizda(1,1))
+ vv(1)=pizda(1,1)-pizda(2,2)
+ vv(2)=pizda(1,2)+pizda(2,1)
+ s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
+cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
+#ifdef MOMENT
+ derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
+#else
+ derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
+#endif
+ if (swap) then
+ derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
+ else
+ derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
+ endif
+ enddo
+ enddo
+ enddo
+ return
+ end
+c----------------------------------------------------------------------------
+ double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.TORSION'
+ include 'COMMON.VAR'
+ include 'COMMON.GEO'
+ double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
+ logical swap
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C C
+C Parallel Antiparallel C
+C C
+C o o C
+C /l\ / \ /j\ C
+C / \ / \ / \ C
+C /| o |o o| o |\ C
+C j|/k\| / |/k\|l / C
+C / \ / / \ / C
+C / o / o C
+C i i C
+C C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C 4/7/01 AL Component s1 was removed, because it pertains to the respective
+C energy moment and not to the cluster cumulant.
+ iti=itortyp(itype(i))
+ if (j.lt.nres-1) then
+ itj1=itortyp(itype(j+1))
+ else
+ itj1=ntortyp+1
+ endif
+ itk=itortyp(itype(k))
+ itk1=itortyp(itype(k+1))
+ if (l.lt.nres-1) then
+ itl1=itortyp(itype(l+1))
+ else
+ itl1=ntortyp+1
+ endif
+#ifdef MOMENT
+ s1=dip(4,jj,i)*dip(4,kk,k)
+#endif
+ call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
+ s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
+ call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
+ s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
+ call transpose2(EE(1,1,itk),auxmat(1,1))
+ call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
+ vv(1)=pizda(1,1)+pizda(2,2)
+ vv(2)=pizda(2,1)-pizda(1,2)
+ s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
+cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
+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)
+ 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 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.TORSION'
+ include 'COMMON.VAR'
+ include 'COMMON.GEO'
+ include 'COMMON.FFIELD'
+ double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
+ & auxvec1(2),auxmat1(2,2)
+ logical swap
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C C
+C Parallel Antiparallel C
+C C
+C o o C
+C /l\ / \ /j\ C
+C / \ / \ / \ C
+C /| o |o o| o |\ C
+C \ j|/k\| \ |/k\|l C
+C \ / \ \ / \ C
+C o \ o \ C
+C i i C
+C C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C 4/7/01 AL Component s1 was removed, because it pertains to the respective
+C energy moment and not to the cluster cumulant.
+cd write (2,*) 'eello_graph4: wturn6',wturn6
+ iti=itortyp(itype(i))
+ itj=itortyp(itype(j))
+ if (j.lt.nres-1) then
+ itj1=itortyp(itype(j+1))
+ else
+ itj1=ntortyp+1
+ endif
+ itk=itortyp(itype(k))
+ if (k.lt.nres-1) then
+ itk1=itortyp(itype(k+1))
+ else
+ itk1=ntortyp+1
+ endif
+ itl=itortyp(itype(l))
+ if (l.lt.nres-1) then
+ itl1=itortyp(itype(l+1))
+ else
+ itl1=ntortyp+1
+ endif
+cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
+cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
+cd & ' itl',itl,' itl1',itl1
+#ifdef MOMENT
+ if (imat.eq.1) then
+ s1=dip(3,jj,i)*dip(3,kk,k)
+ else
+ s1=dip(2,jj,j)*dip(2,kk,l)
+ endif
+#endif
+ call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
+ s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
+ if (j.eq.l+1) then
+ call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
+ s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
+ else
+ call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
+ s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
+ endif
+ call transpose2(EUg(1,1,k),auxmat(1,1))
+ call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
+ vv(1)=pizda(1,1)-pizda(2,2)
+ vv(2)=pizda(2,1)+pizda(1,2)
+ s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
+cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
+#ifdef MOMENT
+ eello6_graph4=-(s1+s2+s3+s4)
+#else
+ eello6_graph4=-(s2+s3+s4)
+#endif
+C Derivatives in gamma(i-1)
+ if (i.gt.1) then
+#ifdef MOMENT
+ if (imat.eq.1) then
+ s1=dipderg(2,jj,i)*dip(3,kk,k)
+ else
+ s1=dipderg(4,jj,j)*dip(2,kk,l)
+ endif
+#endif
+ s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
+ if (j.eq.l+1) then
+ call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
+ s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
+ else
+ call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
+ s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
+ endif
+ s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
+ if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
+cd write (2,*) 'turn6 derivatives'
+#ifdef MOMENT
+ gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
+#else
+ gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
+#endif
+ else
+#ifdef MOMENT
+ g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
+#else
+ g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
+#endif
+ endif
+ endif
+C Derivatives in gamma(k-1)
+#ifdef MOMENT
+ if (imat.eq.1) then
+ s1=dip(3,jj,i)*dipderg(2,kk,k)
+ else
+ s1=dip(2,jj,j)*dipderg(4,kk,l)
+ endif
+#endif
+ call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
+ s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
+ if (j.eq.l+1) then
+ call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
+ s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
+ else
+ call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
+ s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
+ endif
+ call transpose2(EUgder(1,1,k),auxmat1(1,1))
+ call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
+ vv(1)=pizda(1,1)-pizda(2,2)
+ vv(2)=pizda(2,1)+pizda(1,2)
+ s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
+ if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
+#ifdef MOMENT
+ gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
+#else
+ gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
+#endif
+ else
+#ifdef MOMENT
+ g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
+#else
+ g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
+#endif
+ endif
+C Derivatives in gamma(j-1) or gamma(l-1)
+ if (l.eq.j+1 .and. l.gt.1) then
+ call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
+ s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
+ call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
+ vv(1)=pizda(1,1)-pizda(2,2)
+ vv(2)=pizda(2,1)+pizda(1,2)
+ s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
+ g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
+ else if (j.gt.1) then
+ call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
+ s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
+ call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
+ vv(1)=pizda(1,1)-pizda(2,2)
+ vv(2)=pizda(2,1)+pizda(1,2)
+ s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
+ if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
+ gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
+ else
+ g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
+ endif
+ endif
+C Cartesian derivatives.
+ do iii=1,2
+ do kkk=1,5
+ do lll=1,3
+#ifdef MOMENT
+ if (iii.eq.1) then
+ if (imat.eq.1) then
+ s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
+ else
+ s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
+ endif
+ else
+ if (imat.eq.1) then
+ s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
+ else
+ s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
+ endif
+ endif
+#endif
+ call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
+ & auxvec(1))
+ s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
+ if (j.eq.l+1) then
+ call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
+ & b1(1,itj1),auxvec(1))
+ s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
+ else
+ call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
+ & b1(1,itl1),auxvec(1))
+ s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
+ endif
+ call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
+ & pizda(1,1))
+ vv(1)=pizda(1,1)-pizda(2,2)
+ vv(2)=pizda(2,1)+pizda(1,2)
+ s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
+ if (swap) then
+ if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
+#ifdef MOMENT
+ derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
+ & -(s1+s2+s4)
+#else
+ derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
+ & -(s2+s4)
+#endif
+ derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
+ else
+#ifdef MOMENT
+ derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
+#else
+ derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
+#endif
+ derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
+ endif
+ else
+#ifdef MOMENT
+ derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
+#else
+ derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
+#endif
+ if (l.eq.j+1) then
+ derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
+ else
+ derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+ return
+ end
+c----------------------------------------------------------------------------
+ double precision function eello_turn6(i,jj,kk)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.TORSION'
+ include 'COMMON.VAR'
+ include 'COMMON.GEO'
+ double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
+ & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
+ & ggg1(3),ggg2(3)
+ double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
+ & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
+C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
+C the respective energy moment and not to the cluster cumulant.
+ s1=0.0d0
+ s8=0.0d0
+ s13=0.0d0
+c
+ eello_turn6=0.0d0
+ j=i+4
+ k=i+1
+ l=i+3
+ iti=itortyp(itype(i))
+ itk=itortyp(itype(k))
+ itk1=itortyp(itype(k+1))
+ itl=itortyp(itype(l))
+ itj=itortyp(itype(j))
+cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
+cd write (2,*) 'i',i,' k',k,' j',j,' l',l
+cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
+cd eello6=0.0d0
+cd return
+cd endif
+cd write (iout,*)
+cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
+cd & ' and',k,l
+cd call checkint_turn6(i,jj,kk,eel_turn6_num)
+ do iii=1,2
+ do kkk=1,5
+ do lll=1,3
+ derx_turn(lll,kkk,iii)=0.0d0
+ enddo
+ enddo
+ enddo
+cd eij=1.0d0
+cd ekl=1.0d0
+cd ekont=1.0d0
+ eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
+cd eello6_5=0.0d0
+cd write (2,*) 'eello6_5',eello6_5
+#ifdef MOMENT
+ call transpose2(AEA(1,1,1),auxmat(1,1))
+ call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
+ ss1=scalar2(Ub2(1,i+2),b1(1,itl))
+ s1 = (auxmat(1,1)+auxmat(2,2))*ss1
+#endif
+ call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
+ call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
+ s2 = scalar2(b1(1,itk),vtemp1(1))
+#ifdef MOMENT
+ call transpose2(AEA(1,1,2),atemp(1,1))
+ call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
+ call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
+ s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
+#endif
+ call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
+ call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
+ s12 = scalar2(Ub2(1,i+2),vtemp3(1))
+#ifdef MOMENT
+ call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
+ call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
+ call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
+ call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
+ ss13 = scalar2(b1(1,itk),vtemp4(1))
+ s13 = (gtemp(1,1)+gtemp(2,2))*ss13
+#endif
+c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
+c s1=0.0d0
+c s2=0.0d0
+c s8=0.0d0
+c s12=0.0d0
+c s13=0.0d0
+ eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
+C Derivatives in gamma(i+2)
+ 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,itl),vtemp2(1))
+#endif
+ call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
+ call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
+ s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
+c s1d=0.0d0
+c s2d=0.0d0
+c s8d=0.0d0
+c s12d=0.0d0
+c s13d=0.0d0
+ gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
+C Derivatives in gamma(i+3)
+#ifdef MOMENT
+ call transpose2(AEA(1,1,1),auxmatd(1,1))
+ call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
+ ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
+ s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
+#endif
+ call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
+ call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
+ s2d = scalar2(b1(1,itk),vtemp1d(1))
+#ifdef MOMENT
+ call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
+ s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
+#endif
+ s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
+#ifdef MOMENT
+ call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
+ call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
+ s13d = (gtempd(1,1)+gtempd(2,2))*ss13
+#endif
+c s1d=0.0d0
+c s2d=0.0d0
+c s8d=0.0d0
+c s12d=0.0d0
+c s13d=0.0d0
+#ifdef MOMENT
+ gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
+ & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
+#else
+ gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
+ & -0.5d0*ekont*(s2d+s12d)
+#endif
+C Derivatives in gamma(i+4)
+ call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
+ call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
+ s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
+#ifdef MOMENT
+ call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
+ call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
+ s13d = (gtempd(1,1)+gtempd(2,2))*ss13
+#endif
+c s1d=0.0d0
+c s2d=0.0d0
+c s8d=0.0d0
+C s12d=0.0d0
+c s13d=0.0d0
+#ifdef MOMENT
+ gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
+#else
+ gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
+#endif
+C Derivatives in gamma(i+5)
+#ifdef MOMENT
+ call transpose2(AEAderg(1,1,1),auxmatd(1,1))
+ call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
+ s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
+#endif
+ call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
+ call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
+ s2d = scalar2(b1(1,itk),vtemp1d(1))
+#ifdef MOMENT
+ call transpose2(AEA(1,1,2),atempd(1,1))
+ call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
+ s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
+#endif
+ call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
+ s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
+#ifdef MOMENT
+ call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
+ ss13d = scalar2(b1(1,itk),vtemp4d(1))
+ s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
+#endif
+c s1d=0.0d0
+c s2d=0.0d0
+c s8d=0.0d0
+c s12d=0.0d0
+c s13d=0.0d0
+#ifdef MOMENT
+ gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
+ & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
+#else
+ gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
+ & -0.5d0*ekont*(s2d+s12d)
+#endif
+C Cartesian derivatives
+ do iii=1,2
+ do kkk=1,5
+ do lll=1,3
+#ifdef MOMENT
+ call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
+ call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
+ s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
+#endif
+ call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
+ call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
+ & vtemp1d(1))
+ s2d = scalar2(b1(1,itk),vtemp1d(1))
+#ifdef MOMENT
+ call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
+ call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
+ s8d = -(atempd(1,1)+atempd(2,2))*
+ & scalar2(cc(1,1,itl),vtemp2(1))
+#endif
+ call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
+ & auxmatd(1,1))
+ call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
+ s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
+c s1d=0.0d0
+c s2d=0.0d0
+c s8d=0.0d0
+c s12d=0.0d0
+c s13d=0.0d0
+#ifdef MOMENT
+ derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
+ & - 0.5d0*(s1d+s2d)
+#else
+ derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
+ & - 0.5d0*s2d
+#endif
+#ifdef MOMENT
+ derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
+ & - 0.5d0*(s8d+s12d)
+#else
+ derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
+ & - 0.5d0*s12d
+#endif
+ enddo
+ enddo
+ enddo
+#ifdef MOMENT
+ do kkk=1,5
+ do lll=1,3
+ call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
+ & achuj_tempd(1,1))
+ call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
+ call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
+ s13d=(gtempd(1,1)+gtempd(2,2))*ss13
+ derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
+ call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
+ & vtemp4d(1))
+ ss13d = scalar2(b1(1,itk),vtemp4d(1))
+ s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
+ derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
+ enddo
+ enddo
+#endif
+cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
+cd & 16*eel_turn6_num
+cd goto 1112
+ if (j.lt.nres-1) then
+ j1=j+1
+ j2=j-1
+ else
+ j1=j-1
+ j2=j-2
+ endif
+ if (l.lt.nres-1) then
+ l1=l+1
+ l2=l-1
+ else
+ l1=l-1
+ l2=l-2
+ endif
+ do ll=1,3
+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
+ eello_turn6=ekont*eel_turn6
+cd write (2,*) 'ekont',ekont
+cd write (2,*) 'eel_turn6',ekont*eel_turn6
+ return
+ end
+
+C-----------------------------------------------------------------------------
+ double precision function scalar(u,v)
+!DIR$ INLINEALWAYS scalar
+#ifndef OSF
+cDEC$ ATTRIBUTES FORCEINLINE::scalar
+#endif
+ implicit none
+ double precision u(3),v(3)
+cd double precision sc
+cd integer i
+cd sc=0.0d0
+cd do i=1,3
+cd sc=sc+u(i)*v(i)
+cd enddo
+cd scalar=sc
+
+ scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
+ return
+ end
+crc-------------------------------------------------
+ SUBROUTINE MATVEC2(A1,V1,V2)
+!DIR$ INLINEALWAYS MATVEC2
+#ifndef OSF
+cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
+#endif
+ 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)
+#ifndef OSF
+cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
+#endif
+ 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)
+!DIR$ INLINEALWAYS scalar2
+ 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)
+!DIR$ INLINEALWAYS transpose2
+#ifndef OSF
+cDEC$ ATTRIBUTES FORCEINLINE::transpose2
+#endif
+ 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)
+!DIR$ INLINEALWAYS prodmat3
+#ifndef OSF
+cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
+#endif
+ 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
+
--- /dev/null
+ subroutine etotal_long(energia)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+c
+c Compute the long-range slow-varying contributions to the energy
+c
+#ifndef ISNAN
+ external proc_proc
+#ifdef WINPGI
+cMS$ATTRIBUTES C :: proc_proc
+#endif
+#endif
+#ifdef MPI
+ include "mpif.h"
+ double precision weights_(n_ene)
+#endif
+ include 'COMMON.SETUP'
+ include 'COMMON.IOUNITS'
+ double precision energia(0:n_ene)
+ include 'COMMON.FFIELD'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.CHAIN'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.MD'
+c write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
+ if (modecalc.eq.12.or.modecalc.eq.14) then
+#ifdef MPI
+c if (fg_rank.eq.0) call int_from_cart1(.false.)
+#else
+ call int_from_cart1(.false.)
+#endif
+ endif
+#ifdef MPI
+c write(iout,*) "ETOTAL_LONG Processor",fg_rank,
+c & " absolute rank",myrank," nfgtasks",nfgtasks
+ call flush(iout)
+ if (nfgtasks.gt.1) then
+ time00=MPI_Wtime()
+C FG slaves call the following matching MPI_Bcast in ERGASTULUM
+ if (fg_rank.eq.0) then
+ call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
+c write (iout,*) "Processor",myrank," BROADCAST iorder"
+c call flush(iout)
+C FG master sets up the WEIGHTS_ array which will be broadcast to the
+C FG slaves as WEIGHTS array.
+ 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)=wbond
+ weights_(18)=scal14
+ weights_(21)=wsccor
+C FG Master broadcasts the WEIGHTS_ array
+ call MPI_Bcast(weights_(1),n_ene,
+ & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
+ else
+C FG slaves receive the WEIGHTS array
+ call MPI_Bcast(weights(1),n_ene,
+ & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
+ wsc=weights(1)
+ wscp=weights(2)
+ welec=weights(3)
+ wcorr=weights(4)
+ wcorr5=weights(5)
+ wcorr6=weights(6)
+ wel_loc=weights(7)
+ wturn3=weights(8)
+ wturn4=weights(9)
+ wturn6=weights(10)
+ wang=weights(11)
+ wscloc=weights(12)
+ wtor=weights(13)
+ wtor_d=weights(14)
+ wstrain=weights(15)
+ wvdwpp=weights(16)
+ wbond=weights(17)
+ scal14=weights(18)
+ wsccor=weights(21)
+ endif
+ call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,
+ & king,FG_COMM,IERR)
+ time_Bcast=time_Bcast+MPI_Wtime()-time00
+ time_Bcastw=time_Bcastw+MPI_Wtime()-time00
+c call chainbuild_cart
+c call int_from_cart1(.false.)
+ endif
+c write (iout,*) 'Processor',myrank,
+c & ' calling etotal_short ipot=',ipot
+c call flush(iout)
+c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
+#endif
+cd print *,'nnt=',nnt,' nct=',nct
+C
+C Compute the side-chain and electrostatic interaction energy
+C
+ goto (101,102,103,104,105,106) ipot
+C Lennard-Jones potential.
+ 101 call elj_long(evdw)
+cd print '(a)','Exit ELJ'
+ goto 107
+C Lennard-Jones-Kihara potential (shifted).
+ 102 call eljk_long(evdw)
+ goto 107
+C Berne-Pechukas potential (dilated LJ, angular dependence).
+ 103 call ebp_long(evdw)
+ goto 107
+C Gay-Berne potential (shifted LJ, angular dependence).
+ 104 call egb_long(evdw,evdw_p,evdw_m)
+ goto 107
+C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
+ 105 call egbv_long(evdw)
+ goto 107
+C Soft-sphere potential
+ 106 call e_softsphere(evdw)
+C
+C Calculate electrostatic (H-bonding) energy of the main chain.
+C
+ 107 continue
+ call vec_and_deriv
+ if (ipot.lt.6) then
+#ifdef SPLITELE
+ if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
+ & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
+ & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
+ & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
+#else
+ if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
+ & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
+ & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
+ & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
+#endif
+ call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
+ else
+ ees=0
+ evdw1=0
+ eel_loc=0
+ eello_turn3=0
+ eello_turn4=0
+ endif
+ else
+c write (iout,*) "Soft-spheer ELEC potential"
+ call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
+ & eello_turn4)
+ endif
+C
+C Calculate excluded-volume interaction energy between peptide groups
+C and side chains.
+C
+ if (ipot.lt.6) then
+ if(wscp.gt.0d0) then
+ call escp_long(evdw2,evdw2_14)
+ else
+ evdw2=0
+ evdw2_14=0
+ endif
+ else
+ call escp_soft_sphere(evdw2,evdw2_14)
+ 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) .and. ipot.lt.6) then
+ call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
+c write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
+c &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",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) .and. ipot.lt.6) then
+ call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
+ endif
+C
+C If performing constraint dynamics, call the constraint energy
+C after the equilibration time
+ if(usampl.and.totT.gt.eq_time) then
+ call EconstrQ
+ call Econstr_back
+ else
+ Uconst=0.0d0
+ Uconst_back=0.0d0
+ endif
+C
+C Sum the energies
+C
+ do i=1,n_ene
+ energia(i)=0.0d0
+ enddo
+ energia(1)=evdw
+#ifdef SCP14
+ energia(2)=evdw2-evdw2_14
+ energia(18)=evdw2_14
+#else
+ energia(2)=evdw2
+ energia(18)=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(20)=Uconst+Uconst_back
+ energia(22)=evdw_p
+ energia(23)=evdw_m
+ call sum_energy(energia,.true.)
+c write (iout,*) "Exit ETOTAL_LONG"
+ call flush(iout)
+ return
+ end
+c------------------------------------------------------------------------------
+ subroutine etotal_short(energia)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+c
+c Compute the short-range fast-varying contributions to the energy
+c
+#ifndef ISNAN
+ external proc_proc
+#ifdef WINPGI
+cMS$ATTRIBUTES C :: proc_proc
+#endif
+#endif
+#ifdef MPI
+ include "mpif.h"
+ double precision weights_(n_ene)
+#endif
+ include 'COMMON.SETUP'
+ include 'COMMON.IOUNITS'
+ double precision energia(0:n_ene)
+ include 'COMMON.FFIELD'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.CHAIN'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+
+c write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
+c call flush(iout)
+ if (modecalc.eq.12.or.modecalc.eq.14) then
+#ifdef MPI
+ if (fg_rank.eq.0) call int_from_cart1(.false.)
+#else
+ call int_from_cart1(.false.)
+#endif
+ endif
+#ifdef MPI
+c write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
+c & " absolute rank",myrank," nfgtasks",nfgtasks
+c call flush(iout)
+ if (nfgtasks.gt.1) then
+ time00=MPI_Wtime()
+C FG slaves call the following matching MPI_Bcast in ERGASTULUM
+ if (fg_rank.eq.0) then
+ call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
+c write (iout,*) "Processor",myrank," BROADCAST iorder"
+c call flush(iout)
+C FG master sets up the WEIGHTS_ array which will be broadcast to the
+C FG slaves as WEIGHTS array.
+ 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)=wbond
+ weights_(18)=scal14
+ weights_(21)=wsccor
+C FG Master broadcasts the WEIGHTS_ array
+ call MPI_Bcast(weights_(1),n_ene,
+ & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
+ else
+C FG slaves receive the WEIGHTS array
+ call MPI_Bcast(weights(1),n_ene,
+ & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
+ wsc=weights(1)
+ wscp=weights(2)
+ welec=weights(3)
+ wcorr=weights(4)
+ wcorr5=weights(5)
+ wcorr6=weights(6)
+ wel_loc=weights(7)
+ wturn3=weights(8)
+ wturn4=weights(9)
+ wturn6=weights(10)
+ wang=weights(11)
+ wscloc=weights(12)
+ wtor=weights(13)
+ wtor_d=weights(14)
+ wstrain=weights(15)
+ wvdwpp=weights(16)
+ wbond=weights(17)
+ scal14=weights(18)
+ wsccor=weights(21)
+ endif
+c write (iout,*),"Processor",myrank," BROADCAST weights"
+ call MPI_Bcast(c(1,1),maxres6,MPI_DOUBLE_PRECISION,
+ & king,FG_COMM,IERR)
+c write (iout,*) "Processor",myrank," BROADCAST c"
+ call MPI_Bcast(dc(1,1),maxres6,MPI_DOUBLE_PRECISION,
+ & king,FG_COMM,IERR)
+c write (iout,*) "Processor",myrank," BROADCAST dc"
+ call MPI_Bcast(dc_norm(1,1),maxres6,MPI_DOUBLE_PRECISION,
+ & king,FG_COMM,IERR)
+c write (iout,*) "Processor",myrank," BROADCAST dc_norm"
+ call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,
+ & king,FG_COMM,IERR)
+c write (iout,*) "Processor",myrank," BROADCAST theta"
+ call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,
+ & king,FG_COMM,IERR)
+c write (iout,*) "Processor",myrank," BROADCAST phi"
+ call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,
+ & king,FG_COMM,IERR)
+c write (iout,*) "Processor",myrank," BROADCAST alph"
+ call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,
+ & king,FG_COMM,IERR)
+c write (iout,*) "Processor",myrank," BROADCAST omeg"
+ call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,
+ & king,FG_COMM,IERR)
+c write (iout,*) "Processor",myrank," BROADCAST vbld"
+ call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,
+ & king,FG_COMM,IERR)
+ time_Bcast=time_Bcast+MPI_Wtime()-time00
+c write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
+ endif
+c write (iout,*) 'Processor',myrank,
+c & ' calling etotal_short ipot=',ipot
+c call flush(iout)
+c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
+#endif
+c call int_from_cart1(.false.)
+C
+C Compute the side-chain and electrostatic interaction energy
+C
+ goto (101,102,103,104,105,106) ipot
+C Lennard-Jones potential.
+ 101 call elj_short(evdw)
+cd print '(a)','Exit ELJ'
+ goto 107
+C Lennard-Jones-Kihara potential (shifted).
+ 102 call eljk_short(evdw)
+ goto 107
+C Berne-Pechukas potential (dilated LJ, angular dependence).
+ 103 call ebp_short(evdw)
+ goto 107
+C Gay-Berne potential (shifted LJ, angular dependence).
+ 104 call egb_short(evdw,evdw_p,evdw_m)
+ goto 107
+C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
+ 105 call egbv_short(evdw)
+ goto 107
+C Soft-sphere potential - already dealt with in the long-range part
+ 106 evdw=0.0d0
+c 106 call e_softsphere_short(evdw)
+C
+C Calculate electrostatic (H-bonding) energy of the main chain.
+C
+ 107 continue
+c
+c Calculate the short-range part of Evdwpp
+c
+ call evdwpp_short(evdw1)
+c
+c Calculate the short-range part of ESCp
+c
+ if (ipot.lt.6) then
+ call escp_short(evdw2,evdw2_14)
+ endif
+c
+c Calculate the bond-stretching energy
+c
+ call ebond(estr)
+C
+C Calculate the disulfide-bridge and other energy and the contributions
+C from other distance constraints.
+ call edis(ehpb)
+C
+C Calculate the virtual-bond-angle energy.
+C
+ call ebend(ebe)
+C
+C Calculate the SC local energy.
+C
+ call vec_and_deriv
+ call esc(escloc)
+C
+C Calculate the virtual-bond torsional energy.
+C
+ call etor(etors,edihcnstr)
+C
+C 6/23/01 Calculate double-torsional energy
+C
+ call etor_d(etors_d)
+C
+C 21/5/07 Calculate local sicdechain correlation energy
+C
+ if (wsccor.gt.0.0d0) then
+ call eback_sc_corr(esccor)
+ else
+ esccor=0.0d0
+ endif
+C
+C Put energy components into an array
+C
+ do i=1,n_ene
+ energia(i)=0.0d0
+ enddo
+ energia(1)=evdw
+#ifdef SCP14
+ energia(2)=evdw2-evdw2_14
+ energia(18)=evdw2_14
+#else
+ energia(2)=evdw2
+ energia(18)=0.0d0
+#endif
+#ifdef SPLITELE
+ energia(16)=evdw1
+#else
+ energia(3)=evdw1
+#endif
+ energia(11)=ebe
+ energia(12)=escloc
+ energia(13)=etors
+ energia(14)=etors_d
+ energia(15)=ehpb
+ energia(17)=estr
+ energia(19)=edihcnstr
+ energia(21)=esccor
+ energia(22)=evdw_p
+ energia(23)=evdw_m
+c write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
+ call flush(iout)
+ call sum_energy(energia,.true.)
+c write (iout,*) "Exit ETOTAL_SHORT"
+ call flush(iout)
+ return
+ end
--- /dev/null
+ subroutine entmcm
+C Does modified entropic sampling in the space of minima.
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+#ifdef MPL
+ include 'COMMON.INFO'
+#endif
+ include 'COMMON.GEO'
+ include 'COMMON.CHAIN'
+ include 'COMMON.MCM'
+ include 'COMMON.MCE'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.INTERACT'
+ include 'COMMON.THREAD'
+ include 'COMMON.NAMES'
+ logical accepted,not_done,over,ovrtim,error,lprint
+ integer MoveType,nbond
+ integer conf_comp
+ double precision RandOrPert
+ double precision varia(maxvar),elowest,ehighest,eold
+ double precision przes(3),obr(3,3)
+ double precision varold(maxvar)
+ logical non_conv
+ double precision energia(0:n_ene),energia_ave(0:n_ene)
+C
+cd write (iout,*) 'print_mc=',print_mc
+ WhatsUp=0
+ maxtrial_iter=50
+c---------------------------------------------------------------------------
+C Initialize counters.
+c---------------------------------------------------------------------------
+C Total number of generated confs.
+ ngen=0
+C Total number of moves. In general this won't be equal to the number of
+C attempted moves, because we may want to reject some "bad" confs just by
+C overlap check.
+ nmove=0
+C Total number of shift (nbond_move(1)), spike, crankshaft, three-bond,...
+C motions.
+ do i=1,nres
+ nbond_move(i)=0
+ enddo
+C Initialize total and accepted number of moves of various kind.
+ do i=0,MaxMoveType
+ moves(i)=0
+ moves_acc(i)=0
+ enddo
+C Total number of energy evaluations.
+ neneval=0
+ nfun=0
+ indminn=-max_ene
+ indmaxx=max_ene
+ delte=0.5D0
+ facee=1.0D0/(maxacc*delte)
+ conste=dlog(facee)
+C Read entropy from previous simulations.
+ if (ent_read) then
+ read (ientin,*) indminn,indmaxx,emin,emax
+ print *,'indminn=',indminn,' indmaxx=',indmaxx,' emin=',emin,
+ & ' emax=',emax
+ do i=-max_ene,max_ene
+ entropy(i)=(emin+i*delte)*betbol
+ enddo
+ read (ientin,*) (ijunk,ejunk,entropy(i),i=indminn,indmaxx)
+ indmin=indminn
+ indmax=indmaxx
+ write (iout,*) 'indminn=',indminn,' indmaxx=',indmaxx,
+ & ' emin=',emin,' emax=',emax
+ write (iout,'(/a)') 'Initial entropy'
+ do i=indminn,indmaxx
+ write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i)
+ enddo
+ endif ! ent_read
+C Read the pool of conformations
+ call read_pool
+C----------------------------------------------------------------------------
+C Entropy-sampling simulations with continually updated entropy
+C Loop thru simulations
+C----------------------------------------------------------------------------
+ DO ISWEEP=1,NSWEEP
+C----------------------------------------------------------------------------
+C Take a conformation from the pool
+C----------------------------------------------------------------------------
+ if (npool.gt.0) then
+ ii=iran_num(1,npool)
+ do i=1,nvar
+ varia(i)=xpool(i,ii)
+ enddo
+ write (iout,*) 'Took conformation',ii,' from the pool energy=',
+ & epool(ii)
+ call var_to_geom(nvar,varia)
+C Print internal coordinates of the initial conformation
+ call intout
+ else
+ call gen_rand_conf(1,*20)
+ endif
+C----------------------------------------------------------------------------
+C Compute and print initial energies.
+C----------------------------------------------------------------------------
+ nsave=0
+#ifdef MPL
+ if (MyID.eq.MasterID) then
+ do i=1,nctasks
+ nsave_part(i)=0
+ enddo
+ endif
+#endif
+ Kwita=0
+ WhatsUp=0
+ write (iout,'(/80(1h*)/a,i2/80(1h*)/)') 'MCE iteration #',isweep
+ write (iout,'(/80(1h*)/a)') 'Initial energies:'
+ call chainbuild
+ call etotal(energia(0))
+ etot = energia(0)
+ call enerprint(energia(0))
+C Minimize the energy of the first conformation.
+ if (minim) then
+ call geom_to_var(nvar,varia)
+ call minimize(etot,varia,iretcode,nfun)
+ call etotal(energia(0))
+ etot = energia(0)
+ write (iout,'(/80(1h*)/a/80(1h*))')
+ & 'Results of the first energy minimization:'
+ call enerprint(energia(0))
+ endif
+ if (refstr) then
+ call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup),nsup,przes,
+ & obr,non_conv)
+ rms=dsqrt(rms)
+ call contact(.false.,ncont,icont,co)
+ frac=contact_fract(ncont,ncont_ref,icont,icont_ref)
+ write (iout,'(a,f8.3,a,f8.3,a,f8.3)')
+ & 'RMS deviation from the reference structure:',rms,
+ & ' % of native contacts:',frac*100,' contact order:',co
+ write (istat,'(i5,11(1pe14.5))') 0,
+ & (energia(print_order(i)),i=1,nprint_ene),etot,rms,frac,co
+ else
+ write (istat,'(i5,9(1pe14.5))') 0,
+ & (energia(print_order(i)),i=1,nprint_ene),etot
+ endif
+ close(istat)
+ neneval=neneval+nfun+1
+ if (.not. ent_read) then
+C Initialize the entropy array
+ do i=-max_ene,max_ene
+ emin=etot
+C Uncomment the line below for actual entropic sampling (start with uniform
+C energy distribution).
+c entropy(i)=0.0D0
+C Uncomment the line below for multicanonical sampling (start with Boltzmann
+C distribution).
+ entropy(i)=(emin+i*delte)*betbol
+ enddo
+ emax=10000000.0D0
+ emin=etot
+ write (iout,'(/a)') 'Initial entropy'
+ do i=indminn,indmaxx
+ write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i)
+ enddo
+ endif ! ent_read
+#ifdef MPL
+ call recv_stop_sig(Kwita)
+ if (whatsup.eq.1) then
+ call send_stop_sig(-2)
+ not_done=.false.
+ else if (whatsup.le.-2) then
+ not_done=.false.
+ else if (whatsup.eq.2) then
+ not_done=.false.
+ else
+ not_done=.true.
+ endif
+#else
+ not_done = (iretcode.ne.11)
+#endif
+ write (iout,'(/80(1h*)/20x,a/80(1h*))')
+ & 'Enter Monte Carlo procedure.'
+ close(igeom)
+ call briefout(0,etot)
+ do i=1,nvar
+ varold(i)=varia(i)
+ enddo
+ eold=etot
+ indeold=(eold-emin)/delte
+ deix=eold-(emin+indeold*delte)
+ dent=entropy(indeold+1)-entropy(indeold)
+cd write (iout,*) 'indeold=',indeold,' deix=',deix,' dent=',dent
+cd write (*,*) 'Processor',MyID,' indeold=',indeold,' deix=',deix,
+cd & ' dent=',dent
+ sold=entropy(indeold)+(dent/delte)*deix
+ elowest=etot
+ write (iout,*) 'eold=',eold,' sold=',sold,' elowest=',etot
+ write (*,*) 'Processor',MyID,' eold=',eold,' sold=',sold,
+ & ' elowest=',etot
+ if (minim) call zapis(varia,etot)
+ nminima(1)=1.0D0
+C NACC is the counter for the accepted conformations of a given processor
+ nacc=0
+C NACC_TOT counts the total number of accepted conformations
+ nacc_tot=0
+#ifdef MPL
+ if (MyID.eq.MasterID) then
+ call receive_MCM_info
+ else
+ call send_MCM_info(2)
+ endif
+#endif
+ do iene=indminn,indmaxx
+ nhist(iene)=0.0D0
+ enddo
+ do i=2,maxsave
+ nminima(i)=0.0D0
+ enddo
+C Main loop.
+c----------------------------------------------------------------------------
+ elowest=1.0D10
+ ehighest=-1.0D10
+ it=0
+ do while (not_done)
+ it=it+1
+ if (print_mc.gt.0) write (iout,'(80(1h*)/20x,a,i7)')
+ & 'Beginning iteration #',it
+C Initialize local counter.
+ ntrial=0 ! # of generated non-overlapping confs.
+ noverlap=0 ! # of overlapping confs.
+ accepted=.false.
+ do while (.not. accepted .and. WhatsUp.eq.0 .and. Kwita.eq.0)
+ ntrial=ntrial+1
+C Retrieve the angles of previously accepted conformation
+ do j=1,nvar
+ varia(j)=varold(j)
+ enddo
+cd write (iout,'(a)') 'Old variables:'
+cd write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar)
+ call var_to_geom(nvar,varia)
+C Rebuild the chain.
+ call chainbuild
+ MoveType=0
+ nbond=0
+ lprint=.true.
+C Decide whether to generate a random conformation or perturb the old one
+ RandOrPert=ran_number(0.0D0,1.0D0)
+ if (RandOrPert.gt.RanFract) then
+ if (print_mc.gt.0)
+ & write (iout,'(a)') 'Perturbation-generated conformation.'
+ call perturb(error,lprint,MoveType,nbond,1.0D0)
+ if (error) goto 20
+ if (MoveType.lt.1 .or. MoveType.gt.MaxMoveType) then
+ write (iout,'(/a,i7,a/)') 'Error - unknown MoveType=',
+ & MoveType,' returned from PERTURB.'
+ goto 20
+ endif
+ call chainbuild
+ else
+ MoveType=0
+ moves(0)=moves(0)+1
+ nstart_grow=iran_num(3,nres)
+ if (print_mc.gt.0)
+ & write (iout,'(2a,i3)') 'Random-generated conformation',
+ & ' - chain regrown from residue',nstart_grow
+ call gen_rand_conf(nstart_grow,*30)
+ endif
+ call geom_to_var(nvar,varia)
+cd write (iout,'(a)') 'New variables:'
+cd write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar)
+ ngen=ngen+1
+ if (print_mc.gt.0) write (iout,'(a,i5,a,i10,a,i10)')
+ & 'Processor',MyId,' trial move',ntrial,' total generated:',ngen
+ if (print_mc.gt.0) write (*,'(a,i5,a,i10,a,i10)')
+ & 'Processor',MyId,' trial move',ntrial,' total generated:',ngen
+ call etotal(energia(0))
+ etot = energia(0)
+c call enerprint(energia(0))
+c write (iout,'(2(a,1pe14.5))') 'Etot=',Etot,' Elowest=',Elowest
+ if (etot-elowest.gt.overlap_cut) then
+ write (iout,'(a,i5,a,1pe14.5)') 'Iteration',it,
+ & ' Overlap detected in the current conf.; energy is',etot
+ neneval=neneval+1
+ accepted=.false.
+ noverlap=noverlap+1
+ if (noverlap.gt.maxoverlap) then
+ write (iout,'(a)') 'Too many overlapping confs.'
+ goto 20
+ endif
+ else
+ if (minim) then
+ call minimize(etot,varia,iretcode,nfun)
+cd write (iout,'(a)') 'Variables after minimization:'
+cd write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar)
+ call etotal(energia(0))
+ etot = energia(0)
+ neneval=neneval+nfun+1
+ endif
+ if (print_mc.gt.2) then
+ write (iout,'(a)') 'Total energies of trial conf:'
+ call enerprint(energia(0))
+ else if (print_mc.eq.1) then
+ write (iout,'(a,i6,a,1pe16.6)')
+ & 'Trial conformation:',ngen,' energy:',etot
+ endif
+C--------------------------------------------------------------------------
+C... Acceptance test
+C--------------------------------------------------------------------------
+ accepted=.false.
+ if (WhatsUp.eq.0)
+ & call accepting(etot,eold,scur,sold,varia,varold,
+ & accepted)
+ if (accepted) then
+ nacc=nacc+1
+ nacc_tot=nacc_tot+1
+ if (elowest.gt.etot) elowest=etot
+ if (ehighest.lt.etot) ehighest=etot
+ moves_acc(MoveType)=moves_acc(MoveType)+1
+ if (MoveType.eq.1) then
+ nbond_acc(nbond)=nbond_acc(nbond)+1
+ endif
+C Check against conformation repetitions.
+ irep=conf_comp(varia,etot)
+#if defined(AIX) || defined(PGI)
+ open (istat,file=statname,position='append')
+#else
+ open (istat,file=statname,access='append')
+#endif
+ if (refstr) then
+ call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup),nsup,
+ & przes,obr,non_conv)
+ rms=dsqrt(rms)
+ call contact(.false.,ncont,icont,co)
+ frac=contact_fract(ncont,ncont_ref,icont,icont_ref)
+ if (print_mc.gt.0)
+ & write (iout,'(a,f8.3,a,f8.3,a,f8.3)')
+ & 'RMS deviation from the reference structure:',rms,
+ & ' % of native contacts:',frac*100,' contact order:',co
+ if (print_stat)
+ & write (istat,'(i5,11(1pe14.5))') it,
+ & (energia(print_order(i)),i=1,nprint_ene),etot,
+ & rms,frac,co
+ elseif (print_stat) then
+ write (istat,'(i5,10(1pe14.5))') it,
+ & (energia(print_order(i)),i=1,nprint_ene),etot
+ endif
+ close(istat)
+ if (print_mc.gt.1)
+ & call statprint(nacc,nfun,iretcode,etot,elowest)
+C Print internal coordinates.
+ if (print_int) call briefout(nacc,etot)
+#ifdef MPL
+ if (MyID.ne.MasterID) then
+ call recv_stop_sig(Kwita)
+cd print *,'Processor:',MyID,' STOP=',Kwita
+ if (irep.eq.0) then
+ call send_MCM_info(2)
+ else
+ call send_MCM_info(1)
+ endif
+ endif
+#endif
+C Store the accepted conf. and its energy.
+ eold=etot
+ sold=scur
+ do i=1,nvar
+ varold(i)=varia(i)
+ enddo
+ if (irep.eq.0) then
+ irep=nsave+1
+cd write (iout,*) 'Accepted conformation:'
+cd write (iout,*) (rad2deg*varia(i),i=1,nphi)
+ if (minim) call zapis(varia,etot)
+ do i=1,n_ene
+ ener(i,nsave)=energia(i)
+ enddo
+ ener(n_ene+1,nsave)=etot
+ ener(n_ene+2,nsave)=frac
+ endif
+ nminima(irep)=nminima(irep)+1.0D0
+c print *,'irep=',irep,' nminima=',nminima(irep)
+#ifdef MPL
+ if (Kwita.eq.0) call recv_stop_sig(kwita)
+#endif
+ endif ! accepted
+ endif ! overlap
+#ifdef MPL
+ if (MyID.eq.MasterID) then
+ call receive_MCM_info
+ if (nacc_tot.ge.maxacc) accepted=.true.
+ endif
+#endif
+ if (ntrial.gt.maxtrial_iter .and. npool.gt.0) then
+C Take a conformation from the pool
+ ii=iran_num(1,npool)
+ do i=1,nvar
+ varia(i)=xpool(i,ii)
+ enddo
+ write (iout,*) 'Iteration',it,' max. # of trials exceeded.'
+ write (iout,*)
+ & 'Take conformation',ii,' from the pool energy=',epool(ii)
+ if (print_mc.gt.2)
+ & write (iout,'(10f8.3)') (rad2deg*varia(i),i=1,nvar)
+ ntrial=0
+ endif ! (ntrial.gt.maxtrial_iter .and. npool.gt.0)
+ 30 continue
+ enddo ! accepted
+#ifdef MPL
+ if (MyID.eq.MasterID) then
+ call receive_MCM_info
+ endif
+ if (Kwita.eq.0) call recv_stop_sig(kwita)
+#endif
+ if (ovrtim()) WhatsUp=-1
+cd write (iout,*) 'WhatsUp=',WhatsUp,' Kwita=',Kwita
+ not_done = (nacc_tot.lt.maxacc) .and. (WhatsUp.eq.0)
+ & .and. (Kwita.eq.0)
+cd write (iout,*) 'not_done=',not_done
+#ifdef MPL
+ if (Kwita.lt.0) then
+ print *,'Processor',MyID,
+ & ' has received STOP signal =',Kwita,' in EntSamp.'
+cd print *,'not_done=',not_done
+ if (Kwita.lt.-1) WhatsUp=Kwita
+ else if (nacc_tot.ge.maxacc) then
+ print *,'Processor',MyID,' calls send_stop_sig,',
+ & ' because a sufficient # of confs. have been collected.'
+cd print *,'not_done=',not_done
+ call send_stop_sig(-1)
+ else if (WhatsUp.eq.-1) then
+ print *,'Processor',MyID,
+ & ' calls send_stop_sig because of timeout.'
+cd print *,'not_done=',not_done
+ call send_stop_sig(-2)
+ endif
+#endif
+ enddo ! not_done
+
+C-----------------------------------------------------------------
+C... Construct energy histogram & update entropy
+C-----------------------------------------------------------------
+ go to 21
+ 20 WhatsUp=-3
+#ifdef MPL
+ write (iout,*) 'Processor',MyID,
+ & ' is broadcasting ERROR-STOP signal.'
+ write (*,*) 'Processor',MyID,
+ & ' is broadcasting ERROR-STOP signal.'
+ call send_stop_sig(-3)
+#endif
+ 21 continue
+#ifdef MPL
+ if (MyID.eq.MasterID) then
+c call receive_MCM_results
+ call receive_energies
+#endif
+ do i=1,nsave
+ if (esave(i).lt.elowest) elowest=esave(i)
+ if (esave(i).gt.ehighest) ehighest=esave(i)
+ enddo
+ write (iout,'(a,i10)') '# of accepted confs:',nacc_tot
+ write (iout,'(a,f10.5,a,f10.5)') 'Lowest energy:',elowest,
+ & ' Highest energy',ehighest
+ if (isweep.eq.1 .and. .not.ent_read) then
+ emin=elowest
+ emax=ehighest
+ write (iout,*) 'EMAX=',emax
+ indminn=0
+ indmaxx=(ehighest-emin)/delte
+ indmin=indminn
+ indmax=indmaxx
+ do i=-max_ene,max_ene
+ entropy(i)=(emin+i*delte)*betbol
+ enddo
+ ent_read=.true.
+ else
+ indmin=(elowest-emin)/delte
+ indmax=(ehighest-emin)/delte
+ if (indmin.lt.indminn) indminn=indmin
+ if (indmax.gt.indmaxx) indmaxx=indmax
+ endif
+ write(iout,*)'indminn=',indminn,' indmaxx=',indmaxx
+C Construct energy histogram
+ do i=1,nsave
+ inde=(esave(i)-emin)/delte
+ nhist(inde)=nhist(inde)+nminima(i)
+ enddo
+C Update entropy (density of states)
+ do i=indmin,indmax
+ if (nhist(i).gt.0) then
+ entropy(i)=entropy(i)+dlog(nhist(i)+0.0D0)
+ endif
+ enddo
+Cd do i=indmaxx+1
+Cd entropy(i)=1.0D+10
+Cd enddo
+ write (iout,'(/80(1h*)/a,i2/80(1h*)/)')
+ & 'End of macroiteration',isweep
+ write (iout,'(a,f10.5,a,f10.5)') 'Elowest=',elowest,
+ & ' Ehighest=',ehighest
+ write (iout,'(a)') 'Frequecies of minima'
+ do i=1,nsave
+ write (iout,'(i5,f5.0,f10.5)') i,nminima(i),esave(i)
+ enddo
+ write (iout,'(/a)') 'Energy histogram'
+ do i=indminn,indmaxx
+ write (iout,'(i5,2f10.5)') i,emin+i*delte,nhist(i)
+ enddo
+ write (iout,'(/a)') 'Entropy'
+ do i=indminn,indmaxx
+ write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i)
+ enddo
+C-----------------------------------------------------------------
+C... End of energy histogram construction
+C-----------------------------------------------------------------
+#ifdef MPL
+ entropy(-max_ene-4)=dfloat(indminn)
+ entropy(-max_ene-3)=dfloat(indmaxx)
+ entropy(-max_ene-2)=emin
+ entropy(-max_ene-1)=emax
+ call send_MCM_update
+cd print *,entname,ientout
+ open (ientout,file=entname,status='unknown')
+ write (ientout,'(2i5,2e25.17)') indminn,indmaxx,emin,emax
+ do i=indminn,indmaxx
+ write (ientout,'(i5,f10.5,f20.15)') i,emin+i*delte,entropy(i)
+ enddo
+ close(ientout)
+ else
+ write (iout,'(a)') 'Frequecies of minima'
+ do i=1,nsave
+ write (iout,'(i5,f5.0,f10.5)') i,nminima(i),esave(i)
+ enddo
+c call send_MCM_results
+ call send_energies
+ call receive_MCM_update
+ indminn=entropy(-max_ene-4)
+ indmaxx=entropy(-max_ene-3)
+ emin=entropy(-max_ene-2)
+ emax=entropy(-max_ene-1)
+ write (iout,*) 'Received from master:'
+ write (iout,*) 'indminn=',indminn,' indmaxx=',indmaxx,
+ & ' emin=',emin,' emax=',emax
+ write (iout,'(/a)') 'Entropy'
+ do i=indminn,indmaxx
+ write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i)
+ enddo
+ endif
+ if (WhatsUp.lt.-1) return
+#else
+ if (ovrtim() .or. WhatsUp.lt.0) return
+#endif
+
+ write (iout,'(/80(1h*)/20x,a)') 'Summary run statistics:'
+ call statprint(nacc,nfun,iretcode,etot,elowest)
+ write (iout,'(a)')
+ & 'Statistics of multiple-bond motions. Total motions:'
+ write (iout,'(16i5)') (nbond_move(i),i=1,Nbm)
+ write (iout,'(a)') 'Accepted motions:'
+ write (iout,'(16i5)') (nbond_acc(i),i=1,Nbm)
+ write (iout,'(a,i10)') 'Number of chain regrowths:',nregrow
+ write (iout,'(a,i10)') 'Accepted chain regrowths:',nregrow_acc
+
+C---------------------------------------------------------------------------
+ ENDDO ! ISWEEP
+C---------------------------------------------------------------------------
+
+ runtime=tcpu()
+
+ if (isweep.eq.nsweep .and. it.ge.maxacc)
+ &write (iout,'(/80(1h*)/20x,a/80(1h*)/)') 'All iterations done.'
+ return
+ end
+c------------------------------------------------------------------------------
+ subroutine accepting(ecur,eold,scur,sold,x,xold,accepted)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.MCM'
+ include 'COMMON.MCE'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.VAR'
+#ifdef MPL
+ include 'COMMON.INFO'
+#endif
+ include 'COMMON.GEO'
+ double precision ecur,eold,xx,ran_number,bol
+ double precision x(maxvar),xold(maxvar)
+ double precision tole /1.0D-1/, tola /5.0D0/
+ logical accepted
+C Check if the conformation is similar.
+cd write (iout,*) 'Enter ACCEPTING'
+cd write (iout,*) 'Old PHI angles:'
+cd write (iout,*) (rad2deg*xold(i),i=1,nphi)
+cd write (iout,*) 'Current angles'
+cd write (iout,*) (rad2deg*x(i),i=1,nphi)
+cd ddif=dif_ang(nphi,x,xold)
+cd write (iout,*) 'Angle norm:',ddif
+cd write (iout,*) 'ecur=',ecur,' emax=',emax
+ if (ecur.gt.emax) then
+ accepted=.false.
+ if (print_mc.gt.0)
+ & write (iout,'(a)') 'Conformation rejected as too high in energy'
+ return
+ else if (dabs(ecur-eold).lt.tole .and.
+ & dif_ang(nphi,x,xold).lt.tola) then
+ accepted=.false.
+ if (print_mc.gt.0)
+ & write (iout,'(a)') 'Conformation rejected as too similar'
+ return
+ endif
+C Else evaluate the entropy of the conf and compare it with that of the previous
+C one.
+ indecur=(ecur-emin)/delte
+ if (iabs(indecur).gt.max_ene) then
+ write (iout,'(a,2i5)')
+ & 'Accepting: Index out of range:',indecur
+ scur=1000.0D0
+ else if (indecur.eq.indmaxx) then
+ scur=entropy(indecur)
+ if (print_mc.gt.0) write (iout,*)'Energy boundary reached',
+ & indmaxx,indecur,entropy(indecur)
+ else
+ deix=ecur-(emin+indecur*delte)
+ dent=entropy(indecur+1)-entropy(indecur)
+ scur=entropy(indecur)+(dent/delte)*deix
+ endif
+cd print *,'Processor',MyID,' ecur=',ecur,' indecur=',indecur,
+cd & ' scur=',scur,' eold=',eold,' sold=',sold
+cd print *,'deix=',deix,' dent=',dent,' delte=',delte
+ if (print_mc.gt.1) then
+ write(iout,*)'ecur=',ecur,' indecur=',indecur,' scur=',scur
+ write(iout,*)'eold=',eold,' sold=',sold
+ endif
+ if (scur.le.sold) then
+ accepted=.true.
+ else
+C Else carry out acceptance test
+ xx=ran_number(0.0D0,1.0D0)
+ xxh=scur-sold
+ if (xxh.gt.50.0D0) then
+ bol=0.0D0
+ else
+ bol=exp(-xxh)
+ endif
+ if (bol.gt.xx) then
+ accepted=.true.
+ if (print_mc.gt.0) write (iout,'(a)')
+ & 'Conformation accepted.'
+ else
+ accepted=.false.
+ if (print_mc.gt.0) write (iout,'(a)')
+ & 'Conformation rejected.'
+ endif
+ endif
+ return
+ end
+c-----------------------------------------------------------------------------
+ subroutine read_pool
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.MCM'
+ include 'COMMON.MCE'
+ include 'COMMON.VAR'
+ double precision varia(maxvar)
+ print '(a)','Call READ_POOL'
+ do npool=1,max_pool
+ print *,'i=',i
+ read (intin,'(i5,f10.5)',end=10,err=10) iconf,epool(npool)
+ if (epool(npool).eq.0.0D0) goto 10
+ call read_angles(intin,*10)
+ call geom_to_var(nvar,xpool(1,npool))
+ enddo
+ goto 11
+ 10 npool=npool-1
+ 11 write (iout,'(a,i5)') 'Number of pool conformations:',npool
+ if (print_mc.gt.2) then
+ do i=1,npool
+ write (iout,'(a,i5,a,1pe14.5)') 'Pool conformation',i,' energy',
+ & epool(i)
+ write (iout,'(10f8.3)') (rad2deg*xpool(j,i),j=1,nvar)
+ enddo
+ endif ! (print_mc.gt.2)
+ return
+ end
--- /dev/null
+ subroutine fitsq(rms,x,y,nn,t,b,non_conv)
+ implicit real*8 (a-h,o-z)
+ include 'COMMON.IOUNITS'
+c x and y are the vectors of coordinates (dimensioned (3,n)) of the two
+c structures to be superimposed. nn is 3*n, where n is the number of
+c points. t and b are respectively the translation vector and the
+c rotation matrix that transforms the second set of coordinates to the
+c frame of the first set.
+c eta = machine-specific variable
+
+ dimension x(3*nn),y(3*nn),t(3)
+ dimension b(3,3),q(3,3),r(3,3),v(3),xav(3),yav(3),e(3),c(3,3)
+ logical non_conv
+c 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
+c 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
+c
+ 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
+c eta = z00100000
+c write (2,*) "SIVADE"
+ nit = 0
+ small=25.0*10.d-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
+c write (2,*) "nit",nit," e",(x(i,i),i=1,3)
+ 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
+c write (2,*) "np",np," npq",npq
+ if (np.gt.npq) go to 230
+ n0=0
+ do 220 n=np,npq
+ nn=n+np-1
+c write (2,*) "nn",nn
+ 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
+c write (2,*) "nn",nn
+ 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
+c write (2,*) "nn",nn," np",np," nq",nq," n0",n0
+c write (2,*) "x",(x(i,i),i=1,3)
+ 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
+c write (2,*) "n",n," a",a," b",b," c",c," y",y," z",z
+ 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
+c write (2,*) "e",(e(i),i=1,3)
+ 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
+c write (2,*) "e",(e(i),i=1,3)
+ 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))
+c write (2,*) "nit",nit
+c write (2,501) (e(i),i=1,3)
+ return
+ 501 format (/,5x,'singular values - ',3e15.5)
+ end
+ subroutine givns(a,b,m,n)
+ implicit real*8 (a-h,o-z)
+ dimension a(3,3),b(3,3)
+ if (dabs(a(m,n)).lt.dabs(a(n,n))) go to 10
+ t=a(n,n)/a(m,n)
+ s=1.0/dsqrt(1.0+t*t)
+ c=s*t
+ go to 20
+ 10 t=a(m,n)/a(n,n)
+ c=1.0/dsqrt(1.0+t*t)
+ s=c*t
+ 20 do 30 j=1,3
+ v=a(m,j)
+ w=a(n,j)
+ x=b(j,m)
+ y=b(j,n)
+ a(m,j)=c*v-s*w
+ a(n,j)=s*v+c*w
+ b(j,m)=c*x-s*y
+ 30 b(j,n)=s*x+c*y
+ return
+ end
+ subroutine switch(n,m,u,v,d)
+ implicit real*8 (a-h,o-z)
+ dimension u(3,3),v(3,3),d(3)
+ do 10 i=1,3
+ tem=u(i,n)
+ u(i,n)=u(i,n-1)
+ u(i,n-1)=tem
+ if (m.eq.0) go to 10
+ tem=v(i,n)
+ v(i,n)=v(i,n-1)
+ v(i,n-1)=tem
+ 10 continue
+ tem=d(n)
+ d(n)=d(n-1)
+ d(n-1)=tem
+ return
+ end
+ subroutine mvvad(b,xav,yav,t)
+ implicit real*8 (a-h,o-z)
+ dimension b(3,3),xav(3),yav(3),t(3)
+c dimension a(3,3),b(3),c(3),d(3)
+c do 10 j=1,3
+c d(j)=c(j)
+c do 10 i=1,3
+c 10 d(j)=d(j)+a(j,i)*b(i)
+ do 10 j=1,3
+ t(j)=yav(j)
+ do 10 i=1,3
+ 10 t(j)=t(j)+b(j,i)*xav(i)
+ return
+ end
+ double precision function det (a,b,c)
+ implicit real*8 (a-h,o-z)
+ dimension a(3),b(3),c(3)
+ det=a(1)*(b(2)*c(3)-b(3)*c(2))+a(2)*(b(3)*c(1)-b(1)*c(3))
+ 1 +a(3)*(b(1)*c(2)-b(2)*c(1))
+ return
+ end
+ subroutine mmmul(a,b,c)
+ implicit real*8 (a-h,o-z)
+ dimension a(3,3),b(3,3),c(3,3)
+ do 10 i=1,3
+ do 10 j=1,3
+ c(i,j)=0.0d0
+ do 10 k=1,3
+ 10 c(i,j)=c(i,j)+a(i,k)*b(k,j)
+ return
+ end
+ subroutine matvec(uvec,tmat,pvec,nback)
+ implicit real*8 (a-h,o-z)
+ real*8 tmat(3,3),uvec(3,nback), pvec(3,nback)
+c
+ do 2 j=1,nback
+ do 1 i=1,3
+ uvec(i,j) = 0.0d0
+ do 1 k=1,3
+ 1 uvec(i,j)=uvec(i,j)+tmat(i,k)*pvec(k,j)
+ 2 continue
+ return
+ end
--- /dev/null
+ subroutine gauss(RO,AP,MT,M,N,*)
+c
+c CALCULATES (RO**(-1))*AP BY GAUSS ELIMINATION
+c RO IS A SQUARE MATRIX
+c THE CALCULATED PRODUCT IS STORED IN AP
+c ABNORMAL EXIT IF RO IS SINGULAR
+c
+ integer MT, M, N, M1,I,J,IM,
+ & I1,MI,MI1
+ double precision RO(MT,M),AP(MT,N),X,RM,PR,
+ & Y
+ if(M.ne.1)goto 10
+ X=RO(1,1)
+ if(dabs(X).le.1.0D-13) return 1
+ X=1.0/X
+ do 16 I=1,N
+16 AP(1,I)=AP(1,I)*X
+ return
+10 continue
+ M1=M-1
+ DO1 I=1,M1
+ IM=I
+ RM=DABS(RO(I,I))
+ I1=I+1
+ do 2 J=I1,M
+ if(DABS(RO(J,I)).LE.RM) goto 2
+ RM=DABS(RO(J,I))
+ IM=J
+2 continue
+ If(IM.eq.I)goto 17
+ do 3 J=1,N
+ PR=AP(I,J)
+ AP(I,J)=AP(IM,J)
+3 AP(IM,J)=PR
+ do 4 J=I,M
+ PR=RO(I,J)
+ RO(I,J)=RO(IM,J)
+4 RO(IM,J)=PR
+17 X=RO(I,I)
+ if(dabs(X).le.1.0E-13) return 1
+ X=1.0/X
+ do 5 J=1,N
+5 AP(I,J)=X*AP(I,J)
+ do 6 J=I1,M
+6 RO(I,J)=X*RO(I,J)
+ do 7 J=I1,M
+ Y=RO(J,I)
+ do 8 K=1,N
+8 AP(J,K)=AP(J,K)-Y*AP(I,K)
+ do 9 K=I1,M
+9 RO(J,K)=RO(J,K)-Y*RO(I,K)
+7 continue
+1 continue
+ X=RO(M,M)
+ if(dabs(X).le.1.0E-13) return 1
+ X=1.0/X
+ do 11 J=1,N
+11 AP(M,J)=X*AP(M,J)
+ do 12 I=1,M1
+ MI=M-I
+ MI1=MI+1
+ do 14 J=1,N
+ X=AP(MI,J)
+ do 15 K=MI1,M
+15 X=X-AP(K,J)*RO(MI,K)
+14 AP(MI,J)=X
+12 continue
+ return
+ end
--- /dev/null
+ subroutine gen_rand_conf(nstart,*)
+C Generate random conformation or chain cut and regrowth.
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.LOCAL'
+ include 'COMMON.VAR'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.MCM'
+ include 'COMMON.GEO'
+ include 'COMMON.CONTROL'
+ logical overlap,back,fail
+cd print *,' CG Processor',me,' maxgen=',maxgen
+ maxsi=100
+cd write (iout,*) 'Gen_Rand_conf: nstart=',nstart
+ if (nstart.lt.5) then
+ it1=itype(2)
+ phi(4)=gen_phi(4,itype(2),itype(3))
+c write(iout,*)'phi(4)=',rad2deg*phi(4)
+ if (nstart.lt.3) theta(3)=gen_theta(itype(2),pi,phi(4))
+c write(iout,*)'theta(3)=',rad2deg*theta(3)
+ if (it1.ne.10) then
+ nsi=0
+ fail=.true.
+ do while (fail.and.nsi.le.maxsi)
+ call gen_side(it1,theta(3),alph(2),omeg(2),fail)
+ nsi=nsi+1
+ enddo
+ if (nsi.gt.maxsi) return1
+ endif ! it1.ne.10
+ call orig_frame
+ i=4
+ nstart=4
+ else
+ i=nstart
+ nstart=max0(i,4)
+ endif
+
+ maxnit=0
+
+ nit=0
+ niter=0
+ back=.false.
+ do while (i.le.nres .and. niter.lt.maxgen)
+ if (i.lt.nstart) then
+ if(iprint.gt.1) then
+ write (iout,'(/80(1h*)/2a/80(1h*))')
+ & 'Generation procedure went down to ',
+ & 'chain beginning. Cannot continue...'
+ write (*,'(/80(1h*)/2a/80(1h*))')
+ & 'Generation procedure went down to ',
+ & 'chain beginning. Cannot continue...'
+ endif
+ return1
+ endif
+ it1=itype(i-1)
+ it2=itype(i-2)
+ it=itype(i)
+c print *,'Gen_Rand_Conf: i=',i,' it=',it,' it1=',it1,' it2=',it2,
+c & ' nit=',nit,' niter=',niter,' maxgen=',maxgen
+ phi(i+1)=gen_phi(i+1,it1,it)
+ if (back) then
+ phi(i)=gen_phi(i+1,it2,it1)
+c print *,'phi(',i,')=',phi(i)
+ theta(i-1)=gen_theta(it2,phi(i-1),phi(i))
+ if (it2.ne.10) then
+ nsi=0
+ fail=.true.
+ do while (fail.and.nsi.le.maxsi)
+ call gen_side(it2,theta(i-1),alph(i-2),omeg(i-2),fail)
+ nsi=nsi+1
+ enddo
+ if (nsi.gt.maxsi) return1
+ endif
+ call locate_next_res(i-1)
+ endif
+ theta(i)=gen_theta(it1,phi(i),phi(i+1))
+ if (it1.ne.10) then
+ nsi=0
+ fail=.true.
+ do while (fail.and.nsi.le.maxsi)
+ call gen_side(it1,theta(i),alph(i-1),omeg(i-1),fail)
+ nsi=nsi+1
+ enddo
+ if (nsi.gt.maxsi) return1
+ endif
+ call locate_next_res(i)
+ if (overlap(i-1)) then
+ if (nit.lt.maxnit) then
+ back=.true.
+ nit=nit+1
+ else
+ nit=0
+ if (i.gt.3) then
+ back=.true.
+ i=i-1
+ else
+ write (iout,'(a)')
+ & 'Cannot generate non-overlaping conformation. Increase MAXNIT.'
+ write (*,'(a)')
+ & 'Cannot generate non-overlaping conformation. Increase MAXNIT.'
+ return1
+ endif
+ endif
+ else
+ back=.false.
+ nit=0
+ i=i+1
+ endif
+ niter=niter+1
+ enddo
+ if (niter.ge.maxgen) then
+ write (iout,'(a,2i5)')
+ & 'Too many trials in conformation generation',niter,maxgen
+ write (*,'(a,2i5)')
+ & 'Too many trials in conformation generation',niter,maxgen
+ return1
+ endif
+ do j=1,3
+ c(j,nres+1)=c(j,1)
+ c(j,nres+nres)=c(j,nres)
+ enddo
+ return
+ end
+c-------------------------------------------------------------------------
+ logical function overlap(i)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.FFIELD'
+ data redfac /0.5D0/
+ overlap=.false.
+ iti=itype(i)
+ if (iti.gt.ntyp) return
+C Check for SC-SC overlaps.
+cd print *,'nnt=',nnt,' nct=',nct
+ do j=nnt,i-1
+ itj=itype(j)
+ if (j.lt.i-1 .or. ipot.ne.4) then
+ rcomp=sigmaii(iti,itj)
+ else
+ rcomp=sigma(iti,itj)
+ endif
+cd print *,'j=',j
+ if (dist(nres+i,nres+j).lt.redfac*rcomp) then
+ overlap=.true.
+c print *,'overlap, SC-SC: i=',i,' j=',j,
+c & ' dist=',dist(nres+i,nres+j),' rcomp=',
+c & rcomp
+ return
+ endif
+ enddo
+C Check for overlaps between the added peptide group and the preceding
+C SCs.
+ iteli=itel(i)
+ do j=1,3
+ c(j,maxres2+1)=0.5D0*(c(j,i)+c(j,i+1))
+ enddo
+ do j=nnt,i-2
+ itj=itype(j)
+cd print *,'overlap, p-Sc: i=',i,' j=',j,
+cd & ' dist=',dist(nres+j,maxres2+1)
+ if (dist(nres+j,maxres2+1).lt.4.0D0*redfac) then
+ overlap=.true.
+ return
+ endif
+ enddo
+C Check for overlaps between the added side chain and the preceding peptide
+C groups.
+ do j=1,nnt-2
+ do k=1,3
+ c(k,maxres2+1)=0.5D0*(c(k,j)+c(k,j+1))
+ enddo
+cd print *,'overlap, SC-p: i=',i,' j=',j,
+cd & ' dist=',dist(nres+i,maxres2+1)
+ if (dist(nres+i,maxres2+1).lt.4.0D0*redfac) then
+ overlap=.true.
+ return
+ endif
+ enddo
+C Check for p-p overlaps
+ do j=1,3
+ c(j,maxres2+2)=0.5D0*(c(j,i)+c(j,i+1))
+ enddo
+ do j=nnt,i-2
+ itelj=itel(j)
+ do k=1,3
+ c(k,maxres2+2)=0.5D0*(c(k,j)+c(k,j+1))
+ enddo
+cd print *,'overlap, p-p: i=',i,' j=',j,
+cd & ' dist=',dist(maxres2+1,maxres2+2)
+ if(iteli.ne.0.and.itelj.ne.0)then
+ if (dist(maxres2+1,maxres2+2).lt.rpp(iteli,itelj)*redfac) then
+ overlap=.true.
+ return
+ endif
+ endif
+ enddo
+ return
+ end
+c--------------------------------------------------------------------------
+ double precision function gen_phi(i,it1,it2)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.BOUNDS'
+c gen_phi=ran_number(-pi,pi)
+C 8/13/98 Generate phi using pre-defined boundaries
+ gen_phi=ran_number(phibound(1,i),phibound(2,i))
+ return
+ end
+c---------------------------------------------------------------------------
+ double precision function gen_theta(it,gama,gama1)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.LOCAL'
+ include 'COMMON.GEO'
+ double precision y(2),z(2)
+ double precision theta_max,theta_min
+c print *,'gen_theta: it=',it
+ theta_min=0.05D0*pi
+ theta_max=0.95D0*pi
+ if (dabs(gama).gt.dwapi) then
+ y(1)=dcos(gama)
+ y(2)=dsin(gama)
+ else
+ y(1)=0.0D0
+ y(2)=0.0D0
+ endif
+ if (dabs(gama1).gt.dwapi) then
+ z(1)=dcos(gama1)
+ z(2)=dsin(gama1)
+ else
+ z(1)=0.0D0
+ z(2)=0.0D0
+ endif
+ thet_pred_mean=a0thet(it)
+ do k=1,2
+ thet_pred_mean=thet_pred_mean+athet(k,it)*y(k)+bthet(k,it)*z(k)
+ enddo
+ sig=polthet(3,it)
+ do j=2,0,-1
+ sig=sig*thet_pred_mean+polthet(j,it)
+ enddo
+ sig=0.5D0/(sig*sig+sigc0(it))
+ ak=dexp(gthet(1,it)-
+ &0.5D0*((gthet(2,it)-thet_pred_mean)/gthet(3,it))**2)
+c print '(i5,5(1pe14.4))',it,(gthet(j,it),j=1,3)
+c print '(5(1pe14.4))',thet_pred_mean,theta0(it),sig,sig0(it),ak
+ theta_temp=binorm(thet_pred_mean,theta0(it),sig,sig0(it),ak)
+ if (theta_temp.lt.theta_min) theta_temp=theta_min
+ if (theta_temp.gt.theta_max) theta_temp=theta_max
+ gen_theta=theta_temp
+c print '(a)','Exiting GENTHETA.'
+ return
+ end
+c-------------------------------------------------------------------------
+ subroutine gen_side(it,the,al,om,fail)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.SETUP'
+ include 'COMMON.IOUNITS'
+ double precision MaxBoxLen /10.0D0/
+ double precision Ap_inv(3,3),a(3,3),z(3,maxlob),W1(maxlob),
+ & sumW(0:maxlob),y(2),cm(2),eig(2),box(2,2),work(100),detAp(maxlob)
+ double precision eig_limit /1.0D-8/
+ double precision Big /10.0D0/
+ double precision vec(3,3)
+ logical lprint,fail,lcheck
+ lcheck=.false.
+ lprint=.false.
+ fail=.false.
+ if (the.eq.0.0D0 .or. the.eq.pi) then
+#ifdef MPI
+ write (*,'(a,i4,a,i3,a,1pe14.5)')
+ & 'CG Processor:',me,' Error in GenSide: it=',it,' theta=',the
+#else
+cd write (iout,'(a,i3,a,1pe14.5)')
+cd & 'Error in GenSide: it=',it,' theta=',the
+#endif
+ fail=.true.
+ return
+ endif
+ tant=dtan(the-pipol)
+ nlobit=nlob(it)
+ if (lprint) then
+#ifdef MPI
+ print '(a,i4,a)','CG Processor:',me,' Enter Gen_Side.'
+ write (iout,'(a,i4,a)') 'Processor:',me,' Enter Gen_Side.'
+#endif
+ print *,'it=',it,' nlobit=',nlobit,' the=',the,' tant=',tant
+ write (iout,*) 'it=',it,' nlobit=',nlobit,' the=',the,
+ & ' tant=',tant
+ endif
+ do i=1,nlobit
+ zz1=tant-censc(1,i,it)
+ do k=1,3
+ do l=1,3
+ a(k,l)=gaussc(k,l,i,it)
+ enddo
+ enddo
+ detApi=a(2,2)*a(3,3)-a(2,3)**2
+ Ap_inv(2,2)=a(3,3)/detApi
+ Ap_inv(2,3)=-a(2,3)/detApi
+ Ap_inv(3,2)=Ap_inv(2,3)
+ Ap_inv(3,3)=a(2,2)/detApi
+ if (lprint) then
+ write (*,'(/a,i2/)') 'Cluster #',i
+ write (*,'(3(1pe14.5),5x,1pe14.5)')
+ & ((a(l,k),l=1,3),censc(k,i,it),k=1,3)
+ write (iout,'(/a,i2/)') 'Cluster #',i
+ write (iout,'(3(1pe14.5),5x,1pe14.5)')
+ & ((a(l,k),l=1,3),censc(k,i,it),k=1,3)
+ endif
+ W1i=0.0D0
+ do k=2,3
+ do l=2,3
+ W1i=W1i+a(k,1)*a(l,1)*Ap_inv(k,l)
+ enddo
+ enddo
+ W1i=a(1,1)-W1i
+ W1(i)=dexp(bsc(i,it)-0.5D0*W1i*zz1*zz1)
+c if (lprint) write(*,'(a,3(1pe15.5)/)')
+c & 'detAp, W1, anormi',detApi,W1i,anormi
+ do k=2,3
+ zk=censc(k,i,it)
+ do l=2,3
+ zk=zk+zz1*Ap_inv(k,l)*a(l,1)
+ enddo
+ z(k,i)=zk
+ enddo
+ detAp(i)=dsqrt(detApi)
+ enddo
+
+ if (lprint) then
+ print *,'W1:',(w1(i),i=1,nlobit)
+ print *,'detAp:',(detAp(i),i=1,nlobit)
+ print *,'Z'
+ do i=1,nlobit
+ print '(i2,3f10.5)',i,(rad2deg*z(j,i),j=2,3)
+ enddo
+ write (iout,*) 'W1:',(w1(i),i=1,nlobit)
+ write (iout,*) 'detAp:',(detAp(i),i=1,nlobit)
+ write (iout,*) 'Z'
+ do i=1,nlobit
+ write (iout,'(i2,3f10.5)') i,(rad2deg*z(j,i),j=2,3)
+ enddo
+ endif
+ if (lcheck) then
+C Writing the distribution just to check the procedure
+ fac=0.0D0
+ dV=deg2rad**2*10.0D0
+ sum=0.0D0
+ sum1=0.0D0
+ do i=1,nlobit
+ fac=fac+W1(i)/detAp(i)
+ enddo
+ fac=1.0D0/(2.0D0*fac*pi)
+cd print *,it,'fac=',fac
+ do ial=90,180,2
+ y(1)=deg2rad*ial
+ do iom=-180,180,5
+ y(2)=deg2rad*iom
+ wart=0.0D0
+ do i=1,nlobit
+ do j=2,3
+ do k=2,3
+ a(j-1,k-1)=gaussc(j,k,i,it)
+ enddo
+ enddo
+ y2=y(2)
+
+ do iii=-1,1
+
+ y(2)=y2+iii*dwapi
+
+ wykl=0.0D0
+ do j=1,2
+ do k=1,2
+ wykl=wykl+a(j,k)*(y(j)-z(j+1,i))*(y(k)-z(k+1,i))
+ enddo
+ enddo
+ wart=wart+W1(i)*dexp(-0.5D0*wykl)
+
+ enddo
+
+ y(2)=y2
+
+ enddo
+c print *,'y',y(1),y(2),' fac=',fac
+ wart=fac*wart
+ write (20,'(2f10.3,1pd15.5)') y(1)*rad2deg,y(2)*rad2deg,wart
+ sum=sum+wart
+ sum1=sum1+1.0D0
+ enddo
+ enddo
+c print *,'it=',it,' sum=',sum*dV,' sum1=',sum1*dV
+ return
+ endif
+
+C Calculate the CM of the system
+C
+ do i=1,nlobit
+ W1(i)=W1(i)/detAp(i)
+ enddo
+ sumW(0)=0.0D0
+ do i=1,nlobit
+ sumW(i)=sumW(i-1)+W1(i)
+ enddo
+ cm(1)=z(2,1)*W1(1)
+ cm(2)=z(3,1)*W1(1)
+ do j=2,nlobit
+ cm(1)=cm(1)+z(2,j)*W1(j)
+ cm(2)=cm(2)+W1(j)*(z(3,1)+pinorm(z(3,j)-z(3,1)))
+ enddo
+ cm(1)=cm(1)/sumW(nlobit)
+ cm(2)=cm(2)/sumW(nlobit)
+ if (cm(1).gt.Big .or. cm(1).lt.-Big .or.
+ & cm(2).gt.Big .or. cm(2).lt.-Big) then
+cd write (iout,'(a)')
+cd & 'Unexpected error in GenSide - CM coordinates too large.'
+cd write (iout,'(i5,2(1pe14.5))') it,cm(1),cm(2)
+cd write (*,'(a)')
+cd & 'Unexpected error in GenSide - CM coordinates too large.'
+cd write (*,'(i5,2(1pe14.5))') it,cm(1),cm(2)
+ fail=.true.
+ return
+ endif
+cd print *,'CM:',cm(1),cm(2)
+C
+C Find the largest search distance from CM
+C
+ radmax=0.0D0
+ do i=1,nlobit
+ do j=2,3
+ do k=2,3
+ a(j-1,k-1)=gaussc(j,k,i,it)
+ enddo
+ enddo
+#ifdef NAG
+ call f02faf('N','U',2,a,3,eig,work,100,ifail)
+#else
+ call djacob(2,3,10000,1.0d-10,a,vec,eig)
+#endif
+#ifdef MPI
+ if (lprint) then
+ print *,'*************** CG Processor',me
+ print *,'CM:',cm(1),cm(2)
+ write (iout,*) '*************** CG Processor',me
+ write (iout,*) 'CM:',cm(1),cm(2)
+ print '(A,8f10.5)','Eigenvalues: ',(1.0/dsqrt(eig(k)),k=1,2)
+ write (iout,'(A,8f10.5)')
+ & 'Eigenvalues: ',(1.0/dsqrt(eig(k)),k=1,2)
+ endif
+#endif
+ if (eig(1).lt.eig_limit) then
+ write(iout,'(a)')
+ & 'From Mult_Norm: Eigenvalues of A are too small.'
+ write(*,'(a)')
+ & 'From Mult_Norm: Eigenvalues of A are too small.'
+ fail=.true.
+ return
+ endif
+ radius=0.0D0
+cd print *,'i=',i
+ do j=1,2
+ radius=radius+pinorm(z(j+1,i)-cm(j))**2
+ enddo
+ radius=dsqrt(radius)+3.0D0/dsqrt(eig(1))
+ if (radius.gt.radmax) radmax=radius
+ enddo
+ if (radmax.gt.pi) radmax=pi
+C
+C Determine the boundaries of the search rectangle.
+C
+ if (lprint) then
+ print '(a,4(1pe14.4))','W1: ',(W1(i),i=1,nlob(it) )
+ print '(a,4(1pe14.4))','radmax: ',radmax
+ endif
+ box(1,1)=dmax1(cm(1)-radmax,0.0D0)
+ box(2,1)=dmin1(cm(1)+radmax,pi)
+ box(1,2)=cm(2)-radmax
+ box(2,2)=cm(2)+radmax
+ if (lprint) then
+#ifdef MPI
+ print *,'CG Processor',me,' Array BOX:'
+#else
+ print *,'Array BOX:'
+#endif
+ print '(4(1pe14.4))',((box(k,j),k=1,2),j=1,2)
+ print '(a,4(1pe14.4))','sumW: ',(sumW(i),i=0,nlob(it) )
+#ifdef MPI
+ write (iout,*)'CG Processor',me,' Array BOX:'
+#else
+ write (iout,*)'Array BOX:'
+#endif
+ write(iout,'(4(1pe14.4))') ((box(k,j),k=1,2),j=1,2)
+ write(iout,'(a,4(1pe14.4))')'sumW: ',(sumW(i),i=0,nlob(it) )
+ endif
+ if (box(1,2).lt.-MaxBoxLen .or. box(2,2).gt.MaxBoxLen) then
+#ifdef MPI
+ write (iout,'(a,i4,a)') 'CG Processor:',me,': bad sampling box.'
+ write (*,'(a,i4,a)') 'CG Processor:',me,': bad sampling box.'
+#else
+c write (iout,'(a)') 'Bad sampling box.'
+#endif
+ fail=.true.
+ return
+ endif
+ which_lobe=ran_number(0.0D0,sumW(nlobit))
+c print '(a,1pe14.4)','which_lobe=',which_lobe
+ do i=1,nlobit
+ if (sumW(i-1).le.which_lobe .and. sumW(i).ge.which_lobe) goto 1
+ enddo
+ 1 ilob=i
+c print *,'ilob=',ilob,' nlob=',nlob(it)
+ do i=2,3
+ cm(i-1)=z(i,ilob)
+ do j=2,3
+ a(i-1,j-1)=gaussc(i,j,ilob,it)
+ enddo
+ enddo
+cd print '(a,i4,a)','CG Processor',me,' Calling MultNorm1.'
+ call mult_norm1(3,2,a,cm,box,y,fail)
+ if (fail) return
+ al=y(1)
+ om=pinorm(y(2))
+cd print *,'al=',al,' om=',om
+cd stop
+ return
+ end
+c---------------------------------------------------------------------------
+ double precision function ran_number(x1,x2)
+C Calculate a random real number from the range (x1,x2).
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ double precision x1,x2,fctor
+ data fctor /2147483647.0D0/
+#ifdef MPI
+ include "mpif.h"
+ include 'COMMON.SETUP'
+ ran_number=x1+(x2-x1)*prng_next(me)
+#else
+ call vrnd(ix,1)
+ ran_number=x1+(x2-x1)*ix/fctor
+#endif
+ return
+ end
+c--------------------------------------------------------------------------
+ integer function iran_num(n1,n2)
+C Calculate a random integer number from the range (n1,n2).
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ integer n1,n2,ix
+ real fctor /2147483647.0/
+#ifdef MPI
+ include "mpif.h"
+ include 'COMMON.SETUP'
+ ix=n1+(n2-n1+1)*prng_next(me)
+ if (ix.lt.n1) ix=n1
+ if (ix.gt.n2) ix=n2
+ iran_num=ix
+#else
+ call vrnd(ix,1)
+ ix=n1+(n2-n1+1)*(ix/fctor)
+ if (ix.gt.n2) ix=n2
+ iran_num=ix
+#endif
+ return
+ end
+c--------------------------------------------------------------------------
+ double precision function binorm(x1,x2,sigma1,sigma2,ak)
+ implicit real*8 (a-h,o-z)
+c print '(a)','Enter BINORM.'
+ alowb=dmin1(x1-3.0D0*sigma1,x2-3.0D0*sigma2)
+ aupb=dmax1(x1+3.0D0*sigma1,x2+3.0D0*sigma2)
+ seg=sigma1/(sigma1+ak*sigma2)
+ alen=ran_number(0.0D0,1.0D0)
+ if (alen.lt.seg) then
+ binorm=anorm_distr(x1,sigma1,alowb,aupb)
+ else
+ binorm=anorm_distr(x2,sigma2,alowb,aupb)
+ endif
+c print '(a)','Exiting BINORM.'
+ return
+ end
+c-----------------------------------------------------------------------
+c double precision function anorm_distr(x,sigma,alowb,aupb)
+c implicit real*8 (a-h,o-z)
+c print '(a)','Enter ANORM_DISTR.'
+c 10 y=ran_number(alowb,aupb)
+c expon=dexp(-0.5D0*((y-x)/sigma)**2)
+c ran=ran_number(0.0D0,1.0D0)
+c if (expon.lt.ran) goto 10
+c anorm_distr=y
+c print '(a)','Exiting ANORM_DISTR.'
+c return
+c end
+c-----------------------------------------------------------------------
+ double precision function anorm_distr(x,sigma,alowb,aupb)
+ implicit real*8 (a-h,o-z)
+c to make a normally distributed deviate with zero mean and unit variance
+c
+ integer iset
+ real fac,gset,rsq,v1,v2,ran1
+ save iset,gset
+ data iset/0/
+ if(iset.eq.0) then
+1 v1=2.0d0*ran_number(0.0d0,1.0d0)-1.0d0
+ v2=2.0d0*ran_number(0.0d0,1.0d0)-1.0d0
+ rsq=v1**2+v2**2
+ if(rsq.ge.1.d0.or.rsq.eq.0.0d0) goto 1
+ fac=sqrt(-2.0d0*log(rsq)/rsq)
+ gset=v1*fac
+ gaussdev=v2*fac
+ iset=1
+ else
+ gaussdev=gset
+ iset=0
+ endif
+ anorm_distr=x+gaussdev*sigma
+ return
+ end
+c------------------------------------------------------------------------
+ subroutine mult_norm(lda,n,a,x,fail)
+C
+C Generate the vector X whose elements obey the multiple-normal distribution
+C from exp(-0.5*X'AX). LDA is the leading dimension of the moment matrix A,
+C n is the dimension of the problem. FAIL is set at .TRUE., if the smallest
+C eigenvalue of the matrix A is close to 0.
+C
+ implicit double precision (a-h,o-z)
+ double precision a(lda,n),x(n),eig(100),vec(3,3),work(100)
+ double precision eig_limit /1.0D-8/
+ logical fail
+ fail=.false.
+c print '(a)','Enter MULT_NORM.'
+C
+C Find the smallest eigenvalue of the matrix A.
+C
+c do i=1,n
+c print '(8f10.5)',(a(i,j),j=1,n)
+c enddo
+#ifdef NAG
+ call f02faf('V','U',2,a,lda,eig,work,100,ifail)
+#else
+ call djacob(2,lda,10000,1.0d-10,a,vec,eig)
+#endif
+c print '(8f10.5)',(eig(i),i=1,n)
+C print '(a)'
+c do i=1,n
+c print '(8f10.5)',(a(i,j),j=1,n)
+c enddo
+ if (eig(1).lt.eig_limit) then
+ print *,'From Mult_Norm: Eigenvalues of A are too small.'
+ fail=.true.
+ return
+ endif
+C
+C Generate points following the normal distributions along the principal
+C axes of the moment matrix. Store in WORK.
+C
+ do i=1,n
+ sigma=1.0D0/dsqrt(eig(i))
+ alim=-3.0D0*sigma
+ work(i)=anorm_distr(0.0D0,sigma,-alim,alim)
+ enddo
+C
+C Transform the vector of normal variables back to the original basis.
+C
+ do i=1,n
+ xi=0.0D0
+ do j=1,n
+ xi=xi+a(i,j)*work(j)
+ enddo
+ x(i)=xi
+ enddo
+ return
+ end
+c------------------------------------------------------------------------
+ subroutine mult_norm1(lda,n,a,z,box,x,fail)
+C
+C Generate the vector X whose elements obey the multi-gaussian multi-dimensional
+C distribution from sum_{i=1}^m W(i)exp[-0.5*X'(i)A(i)X(i)]. LDA is the
+C leading dimension of the moment matrix A, n is the dimension of the
+C distribution, nlob is the number of lobes. FAIL is set at .TRUE., if the
+C smallest eigenvalue of the matrix A is close to 0.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ double precision a(lda,n),z(n),x(n),box(n,n)
+ double precision etmp
+ include 'COMMON.IOUNITS'
+#ifdef MP
+ include 'COMMON.SETUP'
+#endif
+ logical fail
+C
+C Generate points following the normal distributions along the principal
+C axes of the moment matrix. Store in WORK.
+C
+cd print *,'CG Processor',me,' entered MultNorm1.'
+cd print '(2(1pe14.4),3x,1pe14.4)',((a(i,j),j=1,2),z(i),i=1,2)
+cd do i=1,n
+cd print *,i,box(1,i),box(2,i)
+cd enddo
+ istep = 0
+ 10 istep = istep + 1
+ if (istep.gt.10000) then
+c write (iout,'(a,i4,2a)') 'CG Processor: ',me,': too many steps',
+c & ' in MultNorm1.'
+c write (*,'(a,i4,2a)') 'CG Processor: ',me,': too many steps',
+c & ' in MultNorm1.'
+c write (iout,*) 'box',box
+c write (iout,*) 'a',a
+c write (iout,*) 'z',z
+ fail=.true.
+ return
+ endif
+ do i=1,n
+ x(i)=ran_number(box(1,i),box(2,i))
+ enddo
+ ww=0.0D0
+ do i=1,n
+ xi=pinorm(x(i)-z(i))
+ ww=ww+0.5D0*a(i,i)*xi*xi
+ do j=i+1,n
+ ww=ww+a(i,j)*xi*pinorm(x(j)-z(j))
+ enddo
+ enddo
+ dec=ran_number(0.0D0,1.0D0)
+c print *,(x(i),i=1,n),ww,dexp(-ww),dec
+crc if (dec.gt.dexp(-ww)) goto 10
+ if(-ww.lt.100) then
+ etmp=dexp(-ww)
+ else
+ return
+ endif
+ if (dec.gt.etmp) goto 10
+cd print *,'CG Processor',me,' exitting MultNorm1.'
+ return
+ end
+c
+crc--------------------------------------
+ subroutine overlap_sc(scfail)
+c Internal and cartesian coordinates must be consistent as input,
+c and will be up-to-date on return.
+c At the end of this procedure, scfail is true if there are
+c overlapping residues left, or false otherwise (success)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.FFIELD'
+ include 'COMMON.VAR'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.IOUNITS'
+ logical had_overlaps,fail,scfail
+ integer ioverlap(maxres),ioverlap_last
+
+ had_overlaps=.false.
+ call overlap_sc_list(ioverlap,ioverlap_last)
+ if (ioverlap_last.gt.0) then
+ write (iout,*) '#OVERLAPing residues ',ioverlap_last
+ write (iout,'(20i4)') (ioverlap(k),k=1,ioverlap_last)
+ had_overlaps=.true.
+ endif
+
+ maxsi=1000
+ do k=1,1000
+ if (ioverlap_last.eq.0) exit
+
+ do ires=1,ioverlap_last
+ i=ioverlap(ires)
+ iti=itype(i)
+ if (iti.ne.10) then
+ nsi=0
+ fail=.true.
+ do while (fail.and.nsi.le.maxsi)
+ call gen_side(iti,theta(i+1),alph(i),omeg(i),fail)
+ nsi=nsi+1
+ enddo
+ if(fail) goto 999
+ endif
+ enddo
+
+ call chainbuild
+ call overlap_sc_list(ioverlap,ioverlap_last)
+c write (iout,*) 'Overlaping residues ',ioverlap_last,
+c & (ioverlap(j),j=1,ioverlap_last)
+ enddo
+
+ if (k.le.1000.and.ioverlap_last.eq.0) then
+ scfail=.false.
+ if (had_overlaps) then
+ write (iout,*) '#OVERLAPing all corrected after ',k,
+ & ' random generation'
+ endif
+ else
+ scfail=.true.
+ write (iout,*) '#OVERLAPing NOT all corrected ',ioverlap_last
+ write (iout,'(20i4)') (ioverlap(j),j=1,ioverlap_last)
+ endif
+
+ return
+
+ 999 continue
+ write (iout,'(a30,i5,a12,i4)')
+ & '#OVERLAP FAIL in gen_side after',maxsi,
+ & 'iter for RES',i
+ scfail=.true.
+ return
+ end
+
+ subroutine overlap_sc_list(ioverlap,ioverlap_last)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.FFIELD'
+ include 'COMMON.VAR'
+ include 'COMMON.CALC'
+ logical fail
+ integer ioverlap(maxres),ioverlap_last
+ data redfac /0.5D0/
+
+ ioverlap_last=0
+C Check for SC-SC overlaps and mark residues
+c print *,'>>overlap_sc nnt=',nnt,' nct=',nct
+ ind=0
+ do i=iatsc_s,iatsc_e
+ itypi=itype(i)
+ itypi1=itype(i+1)
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+ dxi=dc_norm(1,nres+i)
+ dyi=dc_norm(2,nres+i)
+ dzi=dc_norm(3,nres+i)
+ dsci_inv=dsc_inv(itypi)
+c
+ do iint=1,nint_gr(i)
+ do j=istart(i,iint),iend(i,iint)
+ ind=ind+1
+ itypj=itype(j)
+ dscj_inv=dsc_inv(itypj)
+ sig0ij=sigma(itypi,itypj)
+ chi1=chi(itypi,itypj)
+ chi2=chi(itypj,itypi)
+ chi12=chi1*chi2
+ chip1=chip(itypi)
+ chip2=chip(itypj)
+ chip12=chip1*chip2
+ alf1=alp(itypi)
+ alf2=alp(itypj)
+ alf12=0.5D0*(alf1+alf2)
+ if (j.gt.i+1) then
+ rcomp=sigmaii(itypi,itypj)
+ else
+ rcomp=sigma(itypi,itypj)
+ endif
+c print '(2(a3,2i3),a3,2f10.5)',
+c & ' i=',i,iti,' j=',j,itj,' d=',dist(nres+i,nres+j)
+c & ,rcomp
+ 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)
+ call sc_angular
+ sigsq=1.0D0/sigsq
+ sig=sig0ij*dsqrt(sigsq)
+ rij_shift=1.0D0/rij-sig+sig0ij
+
+ct if ( 1.0/rij .lt. redfac*rcomp .or.
+ct & rij_shift.le.0.0D0 ) then
+ if ( rij_shift.le.0.0D0 ) then
+cd write (iout,'(a,i3,a,i3,a,f10.5,a,3f10.5)')
+cd & 'overlap SC-SC: i=',i,' j=',j,
+cd & ' dist=',dist(nres+i,nres+j),' rcomp=',
+cd & rcomp,1.0/rij,rij_shift
+ ioverlap_last=ioverlap_last+1
+ ioverlap(ioverlap_last)=i
+ do k=1,ioverlap_last-1
+ if (ioverlap(k).eq.i) ioverlap_last=ioverlap_last-1
+ enddo
+ ioverlap_last=ioverlap_last+1
+ ioverlap(ioverlap_last)=j
+ do k=1,ioverlap_last-1
+ if (ioverlap(k).eq.j) ioverlap_last=ioverlap_last-1
+ enddo
+ endif
+ enddo
+ enddo
+ enddo
+ return
+ end
--- /dev/null
+ subroutine pdbout(etot,tytul,iunit)
+ 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'
+ include 'COMMON.DISTFIT'
+ include 'COMMON.MD'
+ character*50 tytul
+ dimension ica(maxres)
+ write (iunit,'(3a,1pe15.5)') 'REMARK ',tytul,' ENERGY ',etot
+cmodel write (iunit,'(a5,i6)') 'MODEL',1
+ if (nhfrag.gt.0) then
+ do j=1,nhfrag
+ iti=itype(hfrag(1,j))
+ itj=itype(hfrag(2,j))
+ if (j.lt.10) then
+ write (iunit,'(a5,i5,1x,a1,i1,2x,a3,i7,2x,a3,i7,i3,t76,i5)')
+ & 'HELIX',j,'H',j,
+ & restyp(iti),hfrag(1,j)-1,
+ & restyp(itj),hfrag(2,j)-1,1,hfrag(2,j)-hfrag(1,j)
+ else
+ write (iunit,'(a5,i5,1x,a1,i2,1x,a3,i7,2x,a3,i7,i3)')
+ & 'HELIX',j,'H',j,
+ & restyp(iti),hfrag(1,j)-1,
+ & restyp(itj),hfrag(2,j)-1,1,hfrag(2,j)-hfrag(1,j)
+ endif
+ enddo
+ endif
+
+ if (nbfrag.gt.0) then
+
+ do j=1,nbfrag
+
+ iti=itype(bfrag(1,j))
+ itj=itype(bfrag(2,j)-1)
+
+ write (iunit,'(a5,i5,1x,a1,i1,i3,1x,a3,i6,2x,a3,i6,i3)')
+ & 'SHEET',1,'B',j,2,
+ & restyp(iti),bfrag(1,j)-1,
+ & restyp(itj),bfrag(2,j)-2,0
+
+ if (bfrag(3,j).gt.bfrag(4,j)) then
+
+ itk=itype(bfrag(3,j))
+ itl=itype(bfrag(4,j)+1)
+
+ write (iunit,'(a5,i5,1x,a1,i1,i3,1x,a3,i6,2x,a3,i6,i3,
+ & 2x,a1,2x,a3,i6,3x,a1,2x,a3,i6)')
+ & 'SHEET',2,'B',j,2,
+ & restyp(itl),bfrag(4,j),
+ & restyp(itk),bfrag(3,j)-1,-1,
+ & "N",restyp(itk),bfrag(3,j)-1,
+ & "O",restyp(iti),bfrag(1,j)-1
+
+ else
+
+ itk=itype(bfrag(3,j))
+ itl=itype(bfrag(4,j)-1)
+
+
+ write (iunit,'(a5,i5,1x,a1,i1,i3,1x,a3,i6,2x,a3,i6,i3,
+ & 2x,a1,2x,a3,i6,3x,a1,2x,a3,i6)')
+ & 'SHEET',2,'B',j,2,
+ & restyp(itk),bfrag(3,j)-1,
+ & restyp(itl),bfrag(4,j)-2,1,
+ & "N",restyp(itk),bfrag(3,j)-1,
+ & "O",restyp(iti),bfrag(1,j)-1
+
+
+
+ endif
+
+ enddo
+ endif
+
+ if (nss.gt.0) then
+ do i=1,nss
+ write(iunit,'(a6,i4,1x,a3,i7,4x,a3,i7)')
+ & 'SSBOND',i,'CYS',ihpb(i)-1-nres,
+ & 'CYS',jhpb(i)-1-nres
+ enddo
+ endif
+
+ iatom=0
+ do i=nnt,nct
+ ires=i-nnt+1
+ iatom=iatom+1
+ ica(i)=iatom
+ iti=itype(i)
+ write (iunit,10) iatom,restyp(iti),ires,(c(j,i),j=1,3),vtot(i)
+ if (iti.ne.10) then
+ iatom=iatom+1
+ write (iunit,20) iatom,restyp(iti),ires,(c(j,nres+i),j=1,3),
+ & vtot(i+nres)
+ endif
+ enddo
+ write (iunit,'(a)') 'TER'
+ do i=nnt,nct-1
+ if (itype(i).eq.10) then
+ write (iunit,30) ica(i),ica(i+1)
+ else
+ write (iunit,30) ica(i),ica(i+1),ica(i)+1
+ endif
+ enddo
+ if (itype(nct).ne.10) then
+ write (iunit,30) ica(nct),ica(nct)+1
+ endif
+ do i=1,nss
+ write (iunit,30) ica(ihpb(i)-nres)+1,ica(jhpb(i)-nres)+1
+ enddo
+ write (iunit,'(a6)') 'ENDMDL'
+ 10 FORMAT ('ATOM',I7,' CA ',A3,I6,4X,3F8.3,f15.3)
+ 20 FORMAT ('ATOM',I7,' CB ',A3,I6,4X,3F8.3,f15.3)
+ 30 FORMAT ('CONECT',8I5)
+ return
+ end
+c------------------------------------------------------------------------------
+ subroutine MOL2out(etot,tytul)
+C Prints the Cartesian coordinates of the alpha-carbons in the Tripos mol2
+C format.
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.NAMES'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.HEADER'
+ include 'COMMON.SBRIDGE'
+ character*32 tytul,fd
+ character*3 zahl
+ character*6 res_num,pom,ucase
+#ifdef AIX
+ call fdate_(fd)
+#elif (defined CRAY)
+ call date(fd)
+#else
+ call fdate(fd)
+#endif
+ write (imol2,'(a)') '#'
+ write (imol2,'(a)')
+ & '# Creating user name: unres'
+ write (imol2,'(2a)') '# Creation time: ',
+ & fd
+ write (imol2,'(/a)') '\@<TRIPOS>MOLECULE'
+ write (imol2,'(a)') tytul
+ write (imol2,'(5i5)') nct-nnt+1,nct-nnt+nss+1,nct-nnt+nss+1,0,0
+ write (imol2,'(a)') 'SMALL'
+ write (imol2,'(a)') 'USER_CHARGES'
+ write (imol2,'(a)') '\@<TRIPOS>ATOM'
+ do i=nnt,nct
+ write (zahl,'(i3)') i
+ pom=ucase(restyp(itype(i)))
+ res_num = pom(:3)//zahl(2:)
+ write (imol2,10) i,(c(j,i),j=1,3),i,res_num,0.0
+ enddo
+ write (imol2,'(a)') '\@<TRIPOS>BOND'
+ do i=nnt,nct-1
+ write (imol2,'(i5,2i6,i2)') i-nnt+1,i-nnt+1,i-nnt+2,1
+ enddo
+ do i=1,nss
+ write (imol2,'(i5,2i6,i2)') nct-nnt+i,ihpb(i),jhpb(i),1
+ enddo
+ write (imol2,'(a)') '\@<TRIPOS>SUBSTRUCTURE'
+ do i=nnt,nct
+ write (zahl,'(i3)') i
+ pom = ucase(restyp(itype(i)))
+ res_num = pom(:3)//zahl(2:)
+ write (imol2,30) i-nnt+1,res_num,i-nnt+1,0
+ enddo
+ 10 FORMAT (I7,' CA ',3F10.4,' C.3',I8,1X,A,F11.4,' ****')
+ 30 FORMAT (I7,1x,A,I14,' RESIDUE',I13,' **** ****')
+ return
+ end
+c------------------------------------------------------------------------
+ subroutine intout
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.NAMES'
+ include 'COMMON.GEO'
+ write (iout,'(/a)') 'Geometry of the virtual chain.'
+ write (iout,'(7a)') ' Res ',' d',' Theta',
+ & ' Gamma',' Dsc',' Alpha',' Beta '
+ do i=1,nres
+ iti=itype(i)
+ write (iout,'(a3,i4,6f10.3)') restyp(iti),i,vbld(i),
+ & rad2deg*theta(i),rad2deg*phi(i),vbld(nres+i),rad2deg*alph(i),
+ & rad2deg*omeg(i)
+ enddo
+ return
+ end
+c---------------------------------------------------------------------------
+ subroutine briefout(it,ener)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.NAMES'
+ include 'COMMON.GEO'
+ include 'COMMON.SBRIDGE'
+c print '(a,i5)',intname,igeom
+#if defined(AIX) || defined(PGI)
+ open (igeom,file=intname,position='append')
+#else
+ open (igeom,file=intname,access='append')
+#endif
+ IF (NSS.LE.9) THEN
+ WRITE (igeom,180) IT,ENER,NSS,(IHPB(I),JHPB(I),I=1,NSS)
+ ELSE
+ WRITE (igeom,180) IT,ENER,NSS,(IHPB(I),JHPB(I),I=1,9)
+ WRITE (igeom,190) (IHPB(I),JHPB(I),I=10,NSS)
+ ENDIF
+c IF (nvar.gt.nphi) WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES)
+ WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES)
+ WRITE (igeom,200) (RAD2DEG*PHI(I),I=4,NRES)
+c if (nvar.gt.nphi+ntheta) then
+ write (igeom,200) (rad2deg*alph(i),i=2,nres-1)
+ write (igeom,200) (rad2deg*omeg(i),i=2,nres-1)
+c endif
+ close(igeom)
+ 180 format (I5,F12.3,I2,9(1X,2I3))
+ 190 format (3X,11(1X,2I3))
+ 200 format (8F10.4)
+ return
+ end
+#ifdef WINIFL
+ subroutine fdate(fd)
+ character*32 fd
+ write(fd,'(32x)')
+ return
+ end
+#endif
+c----------------------------------------------------------------
+#ifdef NOXDR
+ subroutine cartout(time)
+#else
+ subroutine cartoutx(time)
+#endif
+ 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'
+ include 'COMMON.DISTFIT'
+ include 'COMMON.MD'
+ double precision time
+#if defined(AIX) || defined(PGI)
+ open(icart,file=cartname,position="append")
+#else
+ open(icart,file=cartname,access="append")
+#endif
+ write (icart,'(e15.8,2e15.5,f12.5,$)') time,potE,uconst,t_bath
+ write (icart,'(i4,$)')
+ & nss,(ihpb(j),jhpb(j),j=1,nss)
+ write (icart,'(i4,20f7.4)') nfrag+npair+3*nfrag_back,
+ & (qfrag(i),i=1,nfrag),(qpair(i),i=1,npair),
+ & (utheta(i),ugamma(i),uscdiff(i),i=1,nfrag_back)
+ write (icart,'(8f10.5)')
+ & ((c(k,j),k=1,3),j=1,nres),
+ & ((c(k,j+nres),k=1,3),j=nnt,nct)
+ close(icart)
+ return
+ end
+c-----------------------------------------------------------------
+#ifndef NOXDR
+ subroutine cartout(time)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+ include 'COMMON.SETUP'
+#else
+ parameter (me=0)
+#endif
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.NAMES'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.HEADER'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.DISTFIT'
+ include 'COMMON.MD'
+ double precision time
+ integer iret,itmp
+ real xcoord(3,maxres2+2),prec
+
+#ifdef AIX
+ call xdrfopen_(ixdrf,cartname, "a", iret)
+ call xdrffloat_(ixdrf, real(time), iret)
+ call xdrffloat_(ixdrf, real(potE), iret)
+ call xdrffloat_(ixdrf, real(uconst), iret)
+ call xdrffloat_(ixdrf, real(uconst_back), iret)
+ call xdrffloat_(ixdrf, real(t_bath), iret)
+ call xdrfint_(ixdrf, nss, iret)
+ do j=1,nss
+ call xdrfint_(ixdrf, ihpb(j), iret)
+ call xdrfint_(ixdrf, jhpb(j), iret)
+ enddo
+ call xdrfint_(ixdrf, nfrag+npair+3*nfrag_back, iret)
+ do i=1,nfrag
+ call xdrffloat_(ixdrf, real(qfrag(i)), iret)
+ enddo
+ do i=1,npair
+ call xdrffloat_(ixdrf, real(qpair(i)), iret)
+ enddo
+ do i=1,nfrag_back
+ call xdrffloat_(ixdrf, real(utheta(i)), iret)
+ call xdrffloat_(ixdrf, real(ugamma(i)), iret)
+ call xdrffloat_(ixdrf, real(uscdiff(i)), iret)
+ enddo
+#else
+ call xdrfopen(ixdrf,cartname, "a", iret)
+ call xdrffloat(ixdrf, real(time), iret)
+ call xdrffloat(ixdrf, real(potE), iret)
+ call xdrffloat(ixdrf, real(uconst), iret)
+ call xdrffloat(ixdrf, real(uconst_back), iret)
+ call xdrffloat(ixdrf, real(t_bath), iret)
+ call xdrfint(ixdrf, nss, iret)
+ do j=1,nss
+ call xdrfint(ixdrf, ihpb(j), iret)
+ call xdrfint(ixdrf, jhpb(j), iret)
+ enddo
+ call xdrfint(ixdrf, nfrag+npair+3*nfrag_back, iret)
+ do i=1,nfrag
+ call xdrffloat(ixdrf, real(qfrag(i)), iret)
+ enddo
+ do i=1,npair
+ call xdrffloat(ixdrf, real(qpair(i)), iret)
+ enddo
+ do i=1,nfrag_back
+ call xdrffloat(ixdrf, real(utheta(i)), iret)
+ call xdrffloat(ixdrf, real(ugamma(i)), iret)
+ call xdrffloat(ixdrf, real(uscdiff(i)), iret)
+ enddo
+#endif
+ prec=10000.0
+ do i=1,nres
+ do j=1,3
+ xcoord(j,i)=c(j,i)
+ enddo
+ enddo
+ do i=nnt,nct
+ do j=1,3
+ xcoord(j,nres+i-nnt+1)=c(j,i+nres)
+ enddo
+ enddo
+
+ itmp=nres+nct-nnt+1
+#ifdef AIX
+ call xdrf3dfcoord_(ixdrf, xcoord, itmp, prec, iret)
+ call xdrfclose_(ixdrf, iret)
+#else
+ call xdrf3dfcoord(ixdrf, xcoord, itmp, prec, iret)
+ call xdrfclose(ixdrf, iret)
+#endif
+ return
+ end
+#endif
+c-----------------------------------------------------------------
+ subroutine statout(itime)
+ 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.DISTFIT'
+ include 'COMMON.MD'
+ include 'COMMON.REMD'
+ include 'COMMON.SETUP'
+ integer itime
+ double precision energia(0:n_ene)
+ double precision gyrate
+ external gyrate
+ common /gucio/ cm
+ character*256 line1,line2
+ character*4 format1,format2
+ character*30 format
+#ifdef AIX
+ if(itime.eq.0) then
+ open(istat,file=statname,position="append")
+ endif
+#else
+#ifdef PGI
+ open(istat,file=statname,position="append")
+#else
+ open(istat,file=statname,access="append")
+#endif
+#endif
+ if (refstr) then
+ call rms_nac_nnc(rms,frac,frac_nn,co,.false.)
+ if(tnp .or. tnp1 .or. tnh) then
+ write (line1,'(i10,f15.2,3f12.3,f12.6,f7.2,4f6.3,3f12.3,i5,$)')
+ & itime,totT,EK,potE,totE,hhh,
+ & rms,frac,frac_nn,co,amax,kinetic_T,t_bath,gyrate(),me
+ format1="a145"
+ else
+ write (line1,'(i10,f15.2,3f12.3,f7.2,4f6.3,3f12.3,i5,$)')
+ & itime,totT,EK,potE,totE,
+ & rms,frac,frac_nn,co,amax,kinetic_T,t_bath,gyrate(),me
+ format1="a133"
+ endif
+ else
+ if(tnp .or. tnp1 .or. tnh) then
+ write (line1,'(i10,f15.2,7f12.3,f12.6,i5,$)')
+ & itime,totT,EK,potE,totE,hhh,
+ & amax,kinetic_T,t_bath,gyrate(),me
+ format1="a126"
+ else
+ write (line1,'(i10,f15.2,7f12.3,i5,$)')
+ & itime,totT,EK,potE,totE,
+ & amax,kinetic_T,t_bath,gyrate(),me
+ format1="a114"
+ endif
+ endif
+ if(usampl.and.totT.gt.eq_time) then
+ write(line2,'(i5,2f9.4,300f7.4)') iset,uconst,uconst_back,
+ & (qfrag(ii1),ii1=1,nfrag),(qpair(ii2),ii2=1,npair),
+ & (utheta(i),ugamma(i),uscdiff(i),i=1,nfrag_back)
+ write(format2,'(a1,i3.3)') "a",23+7*nfrag+7*npair
+ & +21*nfrag_back
+ elseif(hremd.gt.0) then
+ write(line2,'(i5)') iset
+ format2="a005"
+ else
+ format2="a001"
+ line2=' '
+ endif
+ if (print_compon) then
+ write(format,'(a1,a4,a1,a4,a10)') "(",format1,",",format2,
+ & ",20f12.3)"
+ write (istat,format) line1,line2,
+ & (potEcomp(print_order(i)),i=1,nprint_ene)
+ else
+ write(format,'(a1,a4,a1,a4,a1)') "(",format1,",",format2,")"
+ write (istat,format) line1,line2
+ endif
+#if defined(AIX)
+ call flush(istat)
+#else
+ close(istat)
+#endif
+ 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
+
+ do i=nnt,nct
+ do j=1,3
+ cen(j)=cen(j)+c(j,i)
+ enddo
+ enddo
+ do j=1,3
+ cen(j)=cen(j)/dble(nct-nnt+1)
+ enddo
+ rg = 0.0d0
+ do i = nnt, nct
+ do j=1,3
+ rg = rg + (c(j,i)-cen(j))**2
+ enddo
+ end do
+ gyrate = sqrt(rg/dble(nct-nnt+1))
+ return
+ end
+
--- /dev/null
+ double precision function gnmr1(y,ymin,ymax)
+ implicit none
+ double precision y,ymin,ymax
+ double precision wykl /4.0d0/
+ if (y.lt.ymin) then
+ gnmr1=(ymin-y)**wykl/wykl
+ else if (y.gt.ymax) then
+ gnmr1=(y-ymax)**wykl/wykl
+ else
+ gnmr1=0.0d0
+ endif
+ return
+ end
+c------------------------------------------------------------------------------
+ double precision function gnmr1prim(y,ymin,ymax)
+ implicit none
+ double precision y,ymin,ymax
+ double precision wykl /4.0d0/
+ if (y.lt.ymin) then
+ gnmr1prim=-(ymin-y)**(wykl-1)
+ else if (y.gt.ymax) then
+ gnmr1prim=(y-ymax)**(wykl-1)
+ else
+ gnmr1prim=0.0d0
+ endif
+ return
+ end
+c------------------------------------------------------------------------------
+ double precision function harmonic(y,ymax)
+ implicit none
+ double precision y,ymax
+ double precision wykl /2.0d0/
+ harmonic=(y-ymax)**wykl
+ return
+ end
+c-------------------------------------------------------------------------------
+ double precision function harmonicprim(y,ymax)
+ double precision y,ymin,ymax
+ double precision wykl /2.0d0/
+ harmonicprim=(y-ymax)*wykl
+ return
+ end
+c---------------------------------------------------------------------------------
--- /dev/null
+ subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.VAR'
+ include 'COMMON.INTERACT'
+ include 'COMMON.FFIELD'
+ include 'COMMON.MD'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.SCCOR'
+ external ufparm
+ integer uiparm(1)
+ double precision urparm(1)
+ dimension x(maxvar),g(maxvar)
+c
+c This subroutine calculates total internal coordinate gradient.
+c Depending on the number of function evaluations, either whole energy
+c is evaluated beforehand, Cartesian coordinates and their derivatives in
+c internal coordinates are reevaluated or only the cartesian-in-internal
+c coordinate derivatives are evaluated. The subroutine was designed to work
+c with SUMSL.
+c
+c
+ icg=mod(nf,2)+1
+
+cd print *,'grad',nf,icg
+ if (nf-nfl+1) 20,30,40
+ 20 call func(n,x,nf,f,uiparm,urparm,ufparm)
+c write (iout,*) 'grad 20'
+ if (nf.eq.0) return
+ goto 40
+ 30 call var_to_geom(n,x)
+ call chainbuild
+c write (iout,*) 'grad 30'
+C
+C Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
+C
+ 40 call cartder
+c write (iout,*) 'grad 40'
+c print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
+C
+C Convert the Cartesian gradient into internal-coordinate gradient.
+C
+ ind=0
+ ind1=0
+ do i=1,nres-2
+ gthetai=0.0D0
+ gphii=0.0D0
+ do j=i+1,nres-1
+ ind=ind+1
+c ind=indmat(i,j)
+c print *,'GRAD: i=',i,' jc=',j,' ind=',ind
+ do k=1,3
+ gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
+ enddo
+ do k=1,3
+ gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
+ enddo
+ enddo
+ do j=i+1,nres-1
+ ind1=ind1+1
+c ind1=indmat(i,j)
+c print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
+ do k=1,3
+ gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
+ gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
+ enddo
+ enddo
+ if (i.gt.1) g(i-1)=gphii
+ if (n.gt.nphi) g(nphi+i)=gthetai
+ enddo
+ if (n.le.nphi+ntheta) goto 10
+ do i=2,nres-1
+ if (itype(i).ne.10) then
+ galphai=0.0D0
+ gomegai=0.0D0
+ do k=1,3
+ galphai=galphai+dxds(k,i)*gradx(k,i,icg)
+ enddo
+ do k=1,3
+ gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
+ enddo
+ g(ialph(i,1))=galphai
+ g(ialph(i,1)+nside)=gomegai
+ endif
+ enddo
+C
+C Add the components corresponding to local energy terms.
+C
+ 10 continue
+ do i=1,nvar
+cd write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
+ g(i)=g(i)+gloc(i,icg)
+ enddo
+C Uncomment following three lines for diagnostics.
+cd call intout
+cd call briefout(0,0.0d0)
+cd write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
+ return
+ end
+C-------------------------------------------------------------------------
+ subroutine grad_restr(n,x,nf,g,uiparm,urparm,ufparm)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.VAR'
+ include 'COMMON.INTERACT'
+ include 'COMMON.FFIELD'
+ include 'COMMON.IOUNITS'
+ external ufparm
+ integer uiparm(1)
+ double precision urparm(1)
+ dimension x(maxvar),g(maxvar)
+
+ icg=mod(nf,2)+1
+ if (nf-nfl+1) 20,30,40
+ 20 call func_restr(n,x,nf,f,uiparm,urparm,ufparm)
+c write (iout,*) 'grad 20'
+ if (nf.eq.0) return
+ goto 40
+ 30 continue
+#ifdef OSF
+c Intercept NaNs in the coordinates
+c write(iout,*) (var(i),i=1,nvar)
+ x_sum=0.D0
+ do i=1,n
+ x_sum=x_sum+x(i)
+ enddo
+ if (x_sum.ne.x_sum) then
+ write(iout,*)" *** grad_restr : Found NaN in coordinates"
+ call flush(iout)
+ print *," *** grad_restr : Found NaN in coordinates"
+ return
+ endif
+#endif
+ call var_to_geom_restr(n,x)
+ call chainbuild
+C
+C Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
+C
+ 40 call cartder
+C
+C Convert the Cartesian gradient into internal-coordinate gradient.
+C
+
+ ig=0
+ ind=nres-2
+ do i=2,nres-2
+ IF (mask_phi(i+2).eq.1) THEN
+ gphii=0.0D0
+ do j=i+1,nres-1
+ ind=ind+1
+ do k=1,3
+ gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
+ gphii=gphii+dxdv(k+3,ind)*gradx(k,j,icg)
+ enddo
+ enddo
+ ig=ig+1
+ g(ig)=gphii
+ ELSE
+ ind=ind+nres-1-i
+ ENDIF
+ enddo
+
+
+ ind=0
+ do i=1,nres-2
+ IF (mask_theta(i+2).eq.1) THEN
+ ig=ig+1
+ gthetai=0.0D0
+ do j=i+1,nres-1
+ ind=ind+1
+ do k=1,3
+ gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
+ gthetai=gthetai+dxdv(k,ind)*gradx(k,j,icg)
+ enddo
+ enddo
+ g(ig)=gthetai
+ ELSE
+ ind=ind+nres-1-i
+ ENDIF
+ enddo
+
+ do i=2,nres-1
+ if (itype(i).ne.10) then
+ IF (mask_side(i).eq.1) THEN
+ ig=ig+1
+ galphai=0.0D0
+ do k=1,3
+ galphai=galphai+dxds(k,i)*gradx(k,i,icg)
+ enddo
+ g(ig)=galphai
+ ENDIF
+ endif
+ enddo
+
+
+ do i=2,nres-1
+ if (itype(i).ne.10) then
+ IF (mask_side(i).eq.1) THEN
+ ig=ig+1
+ gomegai=0.0D0
+ do k=1,3
+ gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
+ enddo
+ g(ig)=gomegai
+ ENDIF
+ endif
+ enddo
+
+C
+C Add the components corresponding to local energy terms.
+C
+
+ ig=0
+ igall=0
+ do i=4,nres
+ igall=igall+1
+ if (mask_phi(i).eq.1) then
+ ig=ig+1
+ g(ig)=g(ig)+gloc(igall,icg)
+ endif
+ enddo
+
+ do i=3,nres
+ igall=igall+1
+ if (mask_theta(i).eq.1) then
+ ig=ig+1
+ g(ig)=g(ig)+gloc(igall,icg)
+ endif
+ enddo
+
+ do ij=1,2
+ do i=2,nres-1
+ if (itype(i).ne.10) then
+ igall=igall+1
+ if (mask_side(i).eq.1) then
+ ig=ig+1
+ g(ig)=g(ig)+gloc(igall,icg)
+ endif
+ endif
+ enddo
+ enddo
+
+cd do i=1,ig
+cd write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i)
+cd enddo
+ return
+ end
+C-------------------------------------------------------------------------
+ subroutine cartgrad
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.VAR'
+ include 'COMMON.INTERACT'
+ include 'COMMON.FFIELD'
+ include 'COMMON.MD'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.TIME1'
+ include 'COMMON.SCCOR'
+c
+c This subrouting calculates total Cartesian coordinate gradient.
+c The subroutine chainbuild_cart and energy MUST be called beforehand.
+c
+c do i=1,nres
+c write (iout,*) "przed sum_grad", gloc_sc(1,i,icg),gloc(i,icg)
+c enddo
+
+#ifdef TIMING
+ time00=MPI_Wtime()
+#endif
+ icg=1
+ call sum_gradient
+#ifdef TIMING
+#endif
+c do i=1,nres
+c write (iout,*) "checkgrad", gloc_sc(1,i,icg),gloc(i,icg)
+c enddo
+cd write (iout,*) "After sum_gradient"
+cd do i=1,nres-1
+cd write (iout,*) i," gradc ",(gradc(j,i,icg),j=1,3)
+cd write (iout,*) i," gradx ",(gradx(j,i,icg),j=1,3)
+cd enddo
+c If performing constraint dynamics, add the gradients of the constraint energy
+ if(usampl.and.totT.gt.eq_time) then
+ do i=1,nct
+ do j=1,3
+ gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
+ gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
+ enddo
+ enddo
+ do i=1,nres-3
+ gloc(i,icg)=gloc(i,icg)+dugamma(i)
+ enddo
+ do i=1,nres-2
+ gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
+ enddo
+ endif
+#ifdef TIMING
+ time01=MPI_Wtime()
+#endif
+ call intcartderiv
+#ifdef TIMING
+ time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
+#endif
+cd call checkintcartgrad
+cd write(iout,*) 'calling int_to_cart'
+cd write (iout,*) "gcart, gxcart, gloc before int_to_cart"
+ do i=1,nct
+ do j=1,3
+ gcart(j,i)=gradc(j,i,icg)
+ gxcart(j,i)=gradx(j,i,icg)
+ enddo
+cd write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),
+cd & (gxcart(j,i),j=1,3),gloc(i,icg)
+ enddo
+#ifdef TIMING
+ time01=MPI_Wtime()
+#endif
+ call int_to_cart
+#ifdef TIMING
+ time_inttocart=time_inttocart+MPI_Wtime()-time01
+#endif
+cd write (iout,*) "gcart and gxcart after int_to_cart"
+cd do i=0,nres-1
+cd write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),
+cd & (gxcart(j,i),j=1,3)
+cd enddo
+#ifdef TIMING
+ time_cartgrad=time_cartgrad+MPI_Wtime()-time00
+#endif
+ return
+ end
+C-------------------------------------------------------------------------
+ subroutine zerograd
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.DERIV'
+ include 'COMMON.CHAIN'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+ include 'COMMON.SCCOR'
+C
+C Initialize Cartesian-coordinate gradient
+C
+ do i=1,nres
+ do j=1,3
+ gvdwx(j,i)=0.0D0
+ gvdwxT(j,i)=0.0D0
+ gradx_scp(j,i)=0.0D0
+ gvdwc(j,i)=0.0D0
+ gvdwcT(j,i)=0.0D0
+ gvdwc_scp(j,i)=0.0D0
+ gvdwc_scpp(j,i)=0.0d0
+ gelc (j,i)=0.0D0
+ gelc_long(j,i)=0.0D0
+ gradb(j,i)=0.0d0
+ gradbx(j,i)=0.0d0
+ gvdwpp(j,i)=0.0d0
+ gel_loc(j,i)=0.0d0
+ gel_loc_long(j,i)=0.0d0
+ ghpbc(j,i)=0.0D0
+ ghpbx(j,i)=0.0D0
+ gcorr3_turn(j,i)=0.0d0
+ gcorr4_turn(j,i)=0.0d0
+ gradcorr(j,i)=0.0d0
+ gradcorr_long(j,i)=0.0d0
+ gradcorr5_long(j,i)=0.0d0
+ gradcorr6_long(j,i)=0.0d0
+ gcorr6_turn_long(j,i)=0.0d0
+ gradcorr5(j,i)=0.0d0
+ gradcorr6(j,i)=0.0d0
+ gcorr6_turn(j,i)=0.0d0
+ gsccorc(j,i)=0.0d0
+ gsccorx(j,i)=0.0d0
+ gradc(j,i,icg)=0.0d0
+ gradx(j,i,icg)=0.0d0
+ gscloc(j,i)=0.0d0
+ gsclocx(j,i)=0.0d0
+ do intertyp=1,3
+ gloc_sc(intertyp,i,icg)=0.0d0
+ enddo
+ enddo
+ enddo
+C
+C Initialize the gradient of local energy terms.
+C
+ do i=1,4*nres
+ gloc(i,icg)=0.0D0
+ enddo
+ do i=1,nres
+ gel_loc_loc(i)=0.0d0
+ gcorr_loc(i)=0.0d0
+ g_corr5_loc(i)=0.0d0
+ g_corr6_loc(i)=0.0d0
+ gel_loc_turn3(i)=0.0d0
+ gel_loc_turn4(i)=0.0d0
+ gel_loc_turn6(i)=0.0d0
+ gsccor_loc(i)=0.0d0
+ enddo
+c initialize gcart and gxcart
+ do i=0,nres
+ do j=1,3
+ gcart(j,i)=0.0d0
+ gxcart(j,i)=0.0d0
+ enddo
+ enddo
+ return
+ end
+c-------------------------------------------------------------------------
+ double precision function fdum()
+ fdum=0.0D0
+ return
+ end
--- /dev/null
+ block data
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.MCM'
+ include 'COMMON.MD'
+ data MovTypID
+ & /'pool','chain regrow','multi-bond','phi','theta','side chain',
+ & 'total'/
+c Conversion from poises to molecular unit and the gas constant
+ data cPoise /2.9361d0/, Rb /0.001986d0/
+ end
+c--------------------------------------------------------------------------
+ subroutine initialize
+C
+C Define constants and zero out tables.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+#ifndef ISNAN
+ external proc_proc
+#ifdef WINPGI
+cMS$ATTRIBUTES C :: proc_proc
+#endif
+#endif
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.TORSION'
+ include 'COMMON.FFIELD'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.MCM'
+ include 'COMMON.MINIM'
+ include 'COMMON.DERIV'
+ include 'COMMON.SPLITELE'
+c Common blocks from the diagonalization routines
+ COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(400)
+ COMMON /MACHSW/ KDIAG,ICORFL,IXDR
+ logical mask_r
+c real*8 text1 /'initial_i'/
+
+ mask_r=.false.
+#ifndef ISNAN
+c NaNQ initialization
+ i=-1
+ arg=100.0d0
+ rr=dacos(arg)
+#ifdef WINPGI
+ idumm=proc_proc(rr,i)
+#else
+ call proc_proc(rr,i)
+#endif
+#endif
+
+ kdiag=0
+ icorfl=0
+ iw=2
+C
+C The following is just to define auxiliary variables used in angle conversion
+C
+ pi=4.0D0*datan(1.0D0)
+ dwapi=2.0D0*pi
+ dwapi3=dwapi/3.0D0
+ pipol=0.5D0*pi
+ deg2rad=pi/180.0D0
+ rad2deg=1.0D0/deg2rad
+ angmin=10.0D0*deg2rad
+C
+C Define I/O units.
+C
+ inp= 1
+ iout= 2
+ ipdbin= 3
+ ipdb= 7
+ icart = 30
+ imol2= 4
+ igeom= 8
+ intin= 9
+ ithep= 11
+ ithep_pdb=51
+ irotam=12
+ irotam_pdb=52
+ itorp= 13
+ itordp= 23
+ ielep= 14
+ isidep=15
+ iscpp=25
+ icbase=16
+ ifourier=20
+ istat= 17
+ irest1=55
+ irest2=56
+ iifrag=57
+ ientin=18
+ ientout=19
+ ibond = 28
+ isccor = 29
+crc for write_rmsbank1
+ izs1=21
+cdr include secondary structure prediction bias
+ isecpred=27
+C
+C CSA I/O units (separated from others especially for Jooyoung)
+C
+ icsa_rbank=30
+ icsa_seed=31
+ icsa_history=32
+ icsa_bank=33
+ icsa_bank1=34
+ icsa_alpha=35
+ icsa_alpha1=36
+ icsa_bankt=37
+ icsa_int=39
+ icsa_bank_reminimized=38
+ icsa_native_int=41
+ icsa_in=40
+crc for ifc error 118
+ icsa_pdb=42
+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
+ print '(a,$)','Inside initialize'
+c call memmon_print_usage()
+ do i=1,maxres2
+ do j=1,3
+ c(j,i)=0.0D0
+ dc(j,i)=0.0D0
+ enddo
+ enddo
+ do i=1,maxres
+ do j=1,3
+ xloc(j,i)=0.0D0
+ enddo
+ enddo
+ do i=1,ntyp
+ do j=1,ntyp
+ aa(i,j)=0.0D0
+ bb(i,j)=0.0D0
+ augm(i,j)=0.0D0
+ sigma(i,j)=0.0D0
+ r0(i,j)=0.0D0
+ chi(i,j)=0.0D0
+ enddo
+ do j=1,2
+ bad(i,j)=0.0D0
+ enddo
+ chip(i)=0.0D0
+ alp(i)=0.0D0
+ sigma0(i)=0.0D0
+ sigii(i)=0.0D0
+ rr0(i)=0.0D0
+ a0thet(i)=0.0D0
+ do j=1,2
+ athet(j,i)=0.0D0
+ bthet(j,i)=0.0D0
+ enddo
+ do j=0,3
+ polthet(j,i)=0.0D0
+ enddo
+ do j=1,3
+ gthet(j,i)=0.0D0
+ enddo
+ theta0(i)=0.0D0
+ sig0(i)=0.0D0
+ sigc0(i)=0.0D0
+ do j=1,maxlob
+ bsc(j,i)=0.0D0
+ do k=1,3
+ censc(k,j,i)=0.0D0
+ enddo
+ do k=1,3
+ do l=1,3
+ gaussc(l,k,j,i)=0.0D0
+ enddo
+ enddo
+ nlob(i)=0
+ enddo
+ enddo
+ nlob(ntyp1)=0
+ dsc(ntyp1)=0.0D0
+ do i=1,maxtor
+ itortyp(i)=0
+ do j=1,maxtor
+ do k=1,maxterm
+ v1(k,j,i)=0.0D0
+ v2(k,j,i)=0.0D0
+ enddo
+ enddo
+ enddo
+ do i=1,maxres
+ itype(i)=0
+ itel(i)=0
+ enddo
+C Initialize the bridge arrays
+ ns=0
+ nss=0
+ nhpb=0
+ do i=1,maxss
+ iss(i)=0
+ enddo
+ do i=1,maxdim
+ dhpb(i)=0.0D0
+ enddo
+ do i=1,maxres
+ ihpb(i)=0
+ jhpb(i)=0
+ enddo
+C
+C Initialize timing.
+C
+ call set_timers
+C
+C Initialize variables used in minimization.
+C
+c maxfun=5000
+c maxit=2000
+ maxfun=500
+ maxit=200
+ tolf=1.0D-2
+ rtolf=5.0D-4
+C
+C Initialize the variables responsible for the mode of gradient storage.
+C
+ nfl=0
+ icg=1
+C
+C Initialize constants used to split the energy into long- and short-range
+C components
+C
+ r_cut=2.0d0
+ rlamb=0.3d0
+#ifndef SPLITELE
+ nprint_ene=nprint_ene-1
+#endif
+ return
+ end
+c-------------------------------------------------------------------------
+ block data nazwy
+ 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'/
+ data ename /
+ & "EVDW SC-SC","EVDW2 SC-p","EES p-p","ECORR4 ","ECORR5 ",
+ & "ECORR6 ","EELLO ","ETURN3 ","ETURN4 ","ETURN6 ",
+ & "EBE bend","ESC SCloc","ETORS ","ETORSD ","EHPB ","EVDWPP ",
+ & "ESTR ","EVDW2_14 ","UCONST ", " ","ESCCOR"," "," "/
+ data wname /
+ & "WSC","WSCP","WELEC","WCORR","WCORR5","WCORR6","WEL_LOC",
+ & "WTURN3","WTURN4","WTURN6","WANG","WSCLOC","WTOR","WTORD",
+ & "WSTRAIN","WVDWPP","WBOND","SCAL14"," "," ","WSCCOR",
+ & " "," "/
+ data nprint_ene /20/
+ data print_order/1,2,3,11,12,13,14,4,5,6,7,8,9,10,19,18,15,17,16,
+ & 21,0,0,0/
+ end
+c---------------------------------------------------------------------------
+ subroutine init_int_table
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+ integer blocklengths(15),displs(15)
+#endif
+ include 'COMMON.CONTROL'
+ include 'COMMON.SETUP'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.LOCAL'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.TORCNSTR'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.DERIV'
+ include 'COMMON.CONTACTS'
+ common /przechowalnia/ iturn3_start_all(0:MaxProcs),
+ & iturn3_end_all(0:MaxProcs),iturn4_start_all(0:MaxProcs),
+ & iturn4_end_all(0:MaxProcs),iatel_s_all(0:MaxProcs),
+ & iatel_e_all(0:MaxProcs),ielstart_all(maxres,0:MaxProcs-1),
+ & ielend_all(maxres,0:MaxProcs-1),
+ & ntask_cont_from_all(0:max_fg_procs-1),
+ & itask_cont_from_all(0:max_fg_procs-1,0:max_fg_procs-1),
+ & ntask_cont_to_all(0:max_fg_procs-1),
+ & itask_cont_to_all(0:max_fg_procs-1,0:max_fg_procs-1)
+ integer FG_GROUP,CONT_FROM_GROUP,CONT_TO_GROUP
+ logical scheck,lprint,flag
+#ifdef MPI
+ integer my_sc_int(0:max_fg_Procs-1),my_sc_intt(0:max_fg_Procs),
+ & my_ele_int(0:max_fg_Procs-1),my_ele_intt(0:max_fg_Procs)
+C... Determine the numbers of start and end SC-SC interaction
+C... to deal with by current processor.
+ do i=0,nfgtasks-1
+ itask_cont_from(i)=fg_rank
+ itask_cont_to(i)=fg_rank
+ enddo
+ lprint=.false.
+ if (lprint)
+ &write (iout,*) 'INIT_INT_TABLE nres=',nres,' nnt=',nnt,' nct=',nct
+ n_sc_int_tot=(nct-nnt+1)*(nct-nnt)/2-nss
+ call int_bounds(n_sc_int_tot,my_sc_inds,my_sc_inde)
+ if (lprint)
+ & write (iout,*) 'Processor',fg_rank,' CG group',kolor,
+ & ' absolute rank',MyRank,
+ & ' n_sc_int_tot',n_sc_int_tot,' my_sc_inds=',my_sc_inds,
+ & ' my_sc_inde',my_sc_inde
+ ind_sctint=0
+ iatsc_s=0
+ iatsc_e=0
+#endif
+c lprint=.false.
+ do i=1,maxres
+ nint_gr(i)=0
+ nscp_gr(i)=0
+ do j=1,maxint_gr
+ istart(i,1)=0
+ iend(i,1)=0
+ ielstart(i)=0
+ ielend(i)=0
+ iscpstart(i,1)=0
+ iscpend(i,1)=0
+ enddo
+ enddo
+ ind_scint=0
+ ind_scint_old=0
+cd write (iout,*) 'ns=',ns,' nss=',nss,' ihpb,jhpb',
+cd & (ihpb(i),jhpb(i),i=1,nss)
+ do i=nnt,nct-1
+ scheck=.false.
+ do ii=1,nss
+ if (ihpb(ii).eq.i+nres) then
+ scheck=.true.
+ jj=jhpb(ii)-nres
+ goto 10
+ endif
+ enddo
+ 10 continue
+cd write (iout,*) 'i=',i,' scheck=',scheck,' jj=',jj
+ if (scheck) then
+ if (jj.eq.i+1) then
+#ifdef MPI
+c write (iout,*) 'jj=i+1'
+ call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
+ & iatsc_s,iatsc_e,i+2,nct,nint_gr(i),istart(i,1),iend(i,1),*12)
+#else
+ nint_gr(i)=1
+ istart(i,1)=i+2
+ iend(i,1)=nct
+#endif
+ else if (jj.eq.nct) then
+#ifdef MPI
+c write (iout,*) 'jj=nct'
+ call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
+ & iatsc_s,iatsc_e,i+1,nct-1,nint_gr(i),istart(i,1),iend(i,1),*12)
+#else
+ nint_gr(i)=1
+ istart(i,1)=i+1
+ iend(i,1)=nct-1
+#endif
+ else
+#ifdef MPI
+ call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
+ & iatsc_s,iatsc_e,i+1,jj-1,nint_gr(i),istart(i,1),iend(i,1),*12)
+ ii=nint_gr(i)+1
+ call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
+ & iatsc_s,iatsc_e,jj+1,nct,nint_gr(i),istart(i,ii),iend(i,ii),*12)
+#else
+ nint_gr(i)=2
+ istart(i,1)=i+1
+ iend(i,1)=jj-1
+ istart(i,2)=jj+1
+ iend(i,2)=nct
+#endif
+ endif
+ else
+#ifdef MPI
+ call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
+ & iatsc_s,iatsc_e,i+1,nct,nint_gr(i),istart(i,1),iend(i,1),*12)
+#else
+ nint_gr(i)=1
+ istart(i,1)=i+1
+ iend(i,1)=nct
+ ind_scint=ind_scint+nct-i
+#endif
+ endif
+#ifdef MPI
+ ind_scint_old=ind_scint
+#endif
+ enddo
+ 12 continue
+#ifndef MPI
+ iatsc_s=nnt
+ iatsc_e=nct-1
+#endif
+#ifdef MPI
+ if (lprint) write (*,*) 'Processor',fg_rank,' CG Group',kolor,
+ & ' absolute rank',myrank,' iatsc_s=',iatsc_s,' iatsc_e=',iatsc_e
+#endif
+ if (lprint) then
+ write (iout,'(a)') 'Interaction array:'
+ do i=iatsc_s,iatsc_e
+ write (iout,'(i3,2(2x,2i3))')
+ & i,(istart(i,iint),iend(i,iint),iint=1,nint_gr(i))
+ enddo
+ endif
+ ispp=4
+#ifdef MPI
+C Now partition the electrostatic-interaction array
+ npept=nct-nnt
+ nele_int_tot=(npept-ispp)*(npept-ispp+1)/2
+ call int_bounds(nele_int_tot,my_ele_inds,my_ele_inde)
+ if (lprint)
+ & write (*,*) 'Processor',fg_rank,' CG group',kolor,
+ & ' absolute rank',MyRank,
+ & ' nele_int_tot',nele_int_tot,' my_ele_inds=',my_ele_inds,
+ & ' my_ele_inde',my_ele_inde
+ iatel_s=0
+ iatel_e=0
+ ind_eleint=0
+ ind_eleint_old=0
+ do i=nnt,nct-3
+ ijunk=0
+ call int_partition(ind_eleint,my_ele_inds,my_ele_inde,i,
+ & iatel_s,iatel_e,i+ispp,nct-1,ijunk,ielstart(i),ielend(i),*13)
+ enddo ! i
+ 13 continue
+ if (iatel_s.eq.0) iatel_s=1
+ nele_int_tot_vdw=(npept-2)*(npept-2+1)/2
+c write (iout,*) "nele_int_tot_vdw",nele_int_tot_vdw
+ call int_bounds(nele_int_tot_vdw,my_ele_inds_vdw,my_ele_inde_vdw)
+c write (iout,*) "my_ele_inds_vdw",my_ele_inds_vdw,
+c & " my_ele_inde_vdw",my_ele_inde_vdw
+ ind_eleint_vdw=0
+ ind_eleint_vdw_old=0
+ iatel_s_vdw=0
+ iatel_e_vdw=0
+ do i=nnt,nct-3
+ ijunk=0
+ call int_partition(ind_eleint_vdw,my_ele_inds_vdw,
+ & my_ele_inde_vdw,i,
+ & iatel_s_vdw,iatel_e_vdw,i+2,nct-1,ijunk,ielstart_vdw(i),
+ & ielend_vdw(i),*15)
+c write (iout,*) i," ielstart_vdw",ielstart_vdw(i),
+c & " ielend_vdw",ielend_vdw(i)
+ enddo ! i
+ if (iatel_s_vdw.eq.0) iatel_s_vdw=1
+ 15 continue
+#else
+ iatel_s=nnt
+ iatel_e=nct-5
+ do i=iatel_s,iatel_e
+ ielstart(i)=i+4
+ ielend(i)=nct-1
+ enddo
+ iatel_s_vdw=nnt
+ iatel_e_vdw=nct-3
+ do i=iatel_s_vdw,iatel_e_vdw
+ ielstart_vdw(i)=i+2
+ ielend_vdw(i)=nct-1
+ enddo
+#endif
+ if (lprint) then
+ write (*,'(a)') 'Processor',fg_rank,' CG group',kolor,
+ & ' absolute rank',MyRank
+ write (iout,*) 'Electrostatic interaction array:'
+ do i=iatel_s,iatel_e
+ write (iout,'(i3,2(2x,2i3))') i,ielstart(i),ielend(i)
+ enddo
+ endif ! lprint
+c iscp=3
+ iscp=2
+C Partition the SC-p interaction array
+#ifdef MPI
+ nscp_int_tot=(npept-iscp+1)*(npept-iscp+1)
+ call int_bounds(nscp_int_tot,my_scp_inds,my_scp_inde)
+ if (lprint) write (iout,*) 'Processor',fg_rank,' CG group',kolor,
+ & ' absolute rank',myrank,
+ & ' nscp_int_tot',nscp_int_tot,' my_scp_inds=',my_scp_inds,
+ & ' my_scp_inde',my_scp_inde
+ iatscp_s=0
+ iatscp_e=0
+ ind_scpint=0
+ ind_scpint_old=0
+ do i=nnt,nct-1
+ if (i.lt.nnt+iscp) then
+cd write (iout,*) 'i.le.nnt+iscp'
+ call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
+ & iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,1),
+ & iscpend(i,1),*14)
+ else if (i.gt.nct-iscp) then
+cd write (iout,*) 'i.gt.nct-iscp'
+ call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
+ & iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1),
+ & iscpend(i,1),*14)
+ else
+ call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
+ & iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1),
+ & iscpend(i,1),*14)
+ ii=nscp_gr(i)+1
+ call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
+ & iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,ii),
+ & iscpend(i,ii),*14)
+ endif
+ enddo ! i
+ 14 continue
+#else
+ iatscp_s=nnt
+ iatscp_e=nct-1
+ do i=nnt,nct-1
+ if (i.lt.nnt+iscp) then
+ nscp_gr(i)=1
+ iscpstart(i,1)=i+iscp
+ iscpend(i,1)=nct
+ elseif (i.gt.nct-iscp) then
+ nscp_gr(i)=1
+ iscpstart(i,1)=nnt
+ iscpend(i,1)=i-iscp
+ else
+ nscp_gr(i)=2
+ iscpstart(i,1)=nnt
+ iscpend(i,1)=i-iscp
+ iscpstart(i,2)=i+iscp
+ iscpend(i,2)=nct
+ endif
+ enddo ! i
+#endif
+ if (lprint) then
+ write (iout,'(a)') 'SC-p interaction array:'
+ do i=iatscp_s,iatscp_e
+ write (iout,'(i3,2(2x,2i3))')
+ & i,(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
+ enddo
+ endif ! lprint
+C Partition local interactions
+#ifdef MPI
+ call int_bounds(nres-2,loc_start,loc_end)
+ loc_start=loc_start+1
+ loc_end=loc_end+1
+ call int_bounds(nres-2,ithet_start,ithet_end)
+ ithet_start=ithet_start+2
+ ithet_end=ithet_end+2
+ call int_bounds(nct-nnt-2,iturn3_start,iturn3_end)
+ iturn3_start=iturn3_start+nnt
+ iphi_start=iturn3_start+2
+ iturn3_end=iturn3_end+nnt
+ iphi_end=iturn3_end+2
+ iturn3_start=iturn3_start-1
+ iturn3_end=iturn3_end-1
+ call int_bounds(nres-3,itau_start,itau_end)
+ itau_start=itau_start+3
+ itau_end=itau_end+3
+ call int_bounds(nres-3,iphi1_start,iphi1_end)
+ iphi1_start=iphi1_start+3
+ iphi1_end=iphi1_end+3
+ call int_bounds(nct-nnt-3,iturn4_start,iturn4_end)
+ iturn4_start=iturn4_start+nnt
+ iphid_start=iturn4_start+2
+ iturn4_end=iturn4_end+nnt
+ iphid_end=iturn4_end+2
+ iturn4_start=iturn4_start-1
+ iturn4_end=iturn4_end-1
+ call int_bounds(nres-2,ibond_start,ibond_end)
+ ibond_start=ibond_start+1
+ ibond_end=ibond_end+1
+ call int_bounds(nct-nnt,ibondp_start,ibondp_end)
+ ibondp_start=ibondp_start+nnt
+ ibondp_end=ibondp_end+nnt
+ call int_bounds1(nres-1,ivec_start,ivec_end)
+ print *,"Processor",myrank,fg_rank,fg_rank1,
+ & " ivec_start",ivec_start," ivec_end",ivec_end
+ iset_start=loc_start+2
+ iset_end=loc_end+2
+ if (ndih_constr.eq.0) then
+ idihconstr_start=1
+ idihconstr_end=0
+ else
+ call int_bounds(ndih_constr,idihconstr_start,idihconstr_end)
+ endif
+ nsumgrad=(nres-nnt)*(nres-nnt+1)/2
+ nlen=nres-nnt+1
+ call int_bounds(nsumgrad,ngrad_start,ngrad_end)
+ igrad_start=((2*nlen+1)
+ & -sqrt(float((2*nlen-1)**2-8*(ngrad_start-1))))/2
+ jgrad_start(igrad_start)=
+ & ngrad_start-(2*nlen-igrad_start)*(igrad_start-1)/2
+ & +igrad_start
+ jgrad_end(igrad_start)=nres
+ igrad_end=((2*nlen+1)
+ & -sqrt(float((2*nlen-1)**2-8*(ngrad_end-1))))/2
+ if (igrad_end.gt.igrad_start) jgrad_start(igrad_end)=igrad_end+1
+ jgrad_end(igrad_end)=ngrad_end-(2*nlen-igrad_end)*(igrad_end-1)/2
+ & +igrad_end
+ do i=igrad_start+1,igrad_end-1
+ jgrad_start(i)=i+1
+ jgrad_end(i)=nres
+ enddo
+ if (lprint) then
+ write (*,*) 'Processor:',fg_rank,' CG group',kolor,
+ & ' absolute rank',myrank,
+ & ' loc_start',loc_start,' loc_end',loc_end,
+ & ' ithet_start',ithet_start,' ithet_end',ithet_end,
+ & ' iphi_start',iphi_start,' iphi_end',iphi_end,
+ & ' iphid_start',iphid_start,' iphid_end',iphid_end,
+ & ' ibond_start',ibond_start,' ibond_end',ibond_end,
+ & ' ibondp_start',ibondp_start,' ibondp_end',ibondp_end,
+ & ' iturn3_start',iturn3_start,' iturn3_end',iturn3_end,
+ & ' iturn4_start',iturn4_start,' iturn4_end',iturn4_end,
+ & ' ivec_start',ivec_start,' ivec_end',ivec_end,
+ & ' iset_start',iset_start,' iset_end',iset_end,
+ & ' idihconstr_start',idihconstr_start,' idihconstr_end',
+ & idihconstr_end
+ write (*,*) 'Processor:',fg_rank,myrank,' igrad_start',
+ & igrad_start,' igrad_end',igrad_end,' ngrad_start',ngrad_start,
+ & ' ngrad_end',ngrad_end
+ do i=igrad_start,igrad_end
+ write(*,*) 'Processor:',fg_rank,myrank,i,
+ & jgrad_start(i),jgrad_end(i)
+ enddo
+ endif
+ if (nfgtasks.gt.1) then
+ call MPI_Allgather(ivec_start,1,MPI_INTEGER,ivec_displ(0),1,
+ & MPI_INTEGER,FG_COMM1,IERROR)
+ iaux=ivec_end-ivec_start+1
+ call MPI_Allgather(iaux,1,MPI_INTEGER,ivec_count(0),1,
+ & MPI_INTEGER,FG_COMM1,IERROR)
+ call MPI_Allgather(iset_start-2,1,MPI_INTEGER,iset_displ(0),1,
+ & MPI_INTEGER,FG_COMM,IERROR)
+ iaux=iset_end-iset_start+1
+ call MPI_Allgather(iaux,1,MPI_INTEGER,iset_count(0),1,
+ & MPI_INTEGER,FG_COMM,IERROR)
+ call MPI_Allgather(ibond_start,1,MPI_INTEGER,ibond_displ(0),1,
+ & MPI_INTEGER,FG_COMM,IERROR)
+ iaux=ibond_end-ibond_start+1
+ call MPI_Allgather(iaux,1,MPI_INTEGER,ibond_count(0),1,
+ & MPI_INTEGER,FG_COMM,IERROR)
+ call MPI_Allgather(ithet_start,1,MPI_INTEGER,ithet_displ(0),1,
+ & MPI_INTEGER,FG_COMM,IERROR)
+ iaux=ithet_end-ithet_start+1
+ call MPI_Allgather(iaux,1,MPI_INTEGER,ithet_count(0),1,
+ & MPI_INTEGER,FG_COMM,IERROR)
+ call MPI_Allgather(iphi_start,1,MPI_INTEGER,iphi_displ(0),1,
+ & MPI_INTEGER,FG_COMM,IERROR)
+ iaux=iphi_end-iphi_start+1
+ call MPI_Allgather(iaux,1,MPI_INTEGER,iphi_count(0),1,
+ & MPI_INTEGER,FG_COMM,IERROR)
+ call MPI_Allgather(iphi1_start,1,MPI_INTEGER,iphi1_displ(0),1,
+ & MPI_INTEGER,FG_COMM,IERROR)
+ iaux=iphi1_end-iphi1_start+1
+ call MPI_Allgather(iaux,1,MPI_INTEGER,iphi1_count(0),1,
+ & MPI_INTEGER,FG_COMM,IERROR)
+ do i=0,maxprocs-1
+ do j=1,maxres
+ ielstart_all(j,i)=0
+ ielend_all(j,i)=0
+ enddo
+ enddo
+ call MPI_Allgather(iturn3_start,1,MPI_INTEGER,
+ & iturn3_start_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
+ call MPI_Allgather(iturn4_start,1,MPI_INTEGER,
+ & iturn4_start_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
+ call MPI_Allgather(iturn3_end,1,MPI_INTEGER,
+ & iturn3_end_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
+ call MPI_Allgather(iturn4_end,1,MPI_INTEGER,
+ & iturn4_end_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
+ call MPI_Allgather(iatel_s,1,MPI_INTEGER,
+ & iatel_s_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
+ call MPI_Allgather(iatel_e,1,MPI_INTEGER,
+ & iatel_e_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
+ call MPI_Allgather(ielstart(1),maxres,MPI_INTEGER,
+ & ielstart_all(1,0),maxres,MPI_INTEGER,FG_COMM,IERROR)
+ call MPI_Allgather(ielend(1),maxres,MPI_INTEGER,
+ & ielend_all(1,0),maxres,MPI_INTEGER,FG_COMM,IERROR)
+ if (lprint) then
+ write (iout,*) "iatel_s_all",(iatel_s_all(i),i=0,nfgtasks)
+ write (iout,*) "iatel_e_all",(iatel_e_all(i),i=0,nfgtasks)
+ write (iout,*) "iturn3_start_all",
+ & (iturn3_start_all(i),i=0,nfgtasks-1)
+ write (iout,*) "iturn3_end_all",
+ & (iturn3_end_all(i),i=0,nfgtasks-1)
+ write (iout,*) "iturn4_start_all",
+ & (iturn4_start_all(i),i=0,nfgtasks-1)
+ write (iout,*) "iturn4_end_all",
+ & (iturn4_end_all(i),i=0,nfgtasks-1)
+ write (iout,*) "The ielstart_all array"
+ do i=nnt,nct
+ write (iout,'(20i4)') i,(ielstart_all(i,j),j=0,nfgtasks-1)
+ enddo
+ write (iout,*) "The ielend_all array"
+ do i=nnt,nct
+ write (iout,'(20i4)') i,(ielend_all(i,j),j=0,nfgtasks-1)
+ enddo
+ call flush(iout)
+ endif
+ ntask_cont_from=0
+ ntask_cont_to=0
+ itask_cont_from(0)=fg_rank
+ itask_cont_to(0)=fg_rank
+ flag=.false.
+ do ii=iturn3_start,iturn3_end
+ call add_int(ii,ii+2,iturn3_sent(1,ii),
+ & ntask_cont_to,itask_cont_to,flag)
+ enddo
+ do ii=iturn4_start,iturn4_end
+ call add_int(ii,ii+3,iturn4_sent(1,ii),
+ & ntask_cont_to,itask_cont_to,flag)
+ enddo
+ do ii=iturn3_start,iturn3_end
+ call add_int_from(ii,ii+2,ntask_cont_from,itask_cont_from)
+ enddo
+ do ii=iturn4_start,iturn4_end
+ call add_int_from(ii,ii+3,ntask_cont_from,itask_cont_from)
+ enddo
+ if (lprint) then
+ write (iout,*) "After turn3 ntask_cont_from",ntask_cont_from,
+ & " ntask_cont_to",ntask_cont_to
+ write (iout,*) "itask_cont_from",
+ & (itask_cont_from(i),i=1,ntask_cont_from)
+ write (iout,*) "itask_cont_to",
+ & (itask_cont_to(i),i=1,ntask_cont_to)
+ call flush(iout)
+ endif
+c write (iout,*) "Loop forward"
+c call flush(iout)
+ do i=iatel_s,iatel_e
+c write (iout,*) "from loop i=",i
+c call flush(iout)
+ do j=ielstart(i),ielend(i)
+ call add_int_from(i,j,ntask_cont_from,itask_cont_from)
+ enddo
+ enddo
+c write (iout,*) "Loop backward iatel_e-1",iatel_e-1,
+c & " iatel_e",iatel_e
+c call flush(iout)
+ nat_sent=0
+ do i=iatel_s,iatel_e
+c write (iout,*) "i",i," ielstart",ielstart(i),
+c & " ielend",ielend(i)
+c call flush(iout)
+ flag=.false.
+ do j=ielstart(i),ielend(i)
+ call add_int(i,j,iint_sent(1,j,nat_sent+1),ntask_cont_to,
+ & itask_cont_to,flag)
+ enddo
+ if (flag) then
+ nat_sent=nat_sent+1
+ iat_sent(nat_sent)=i
+ endif
+ enddo
+ if (lprint) then
+ write (iout,*)"After longrange ntask_cont_from",ntask_cont_from,
+ & " ntask_cont_to",ntask_cont_to
+ write (iout,*) "itask_cont_from",
+ & (itask_cont_from(i),i=1,ntask_cont_from)
+ write (iout,*) "itask_cont_to",
+ & (itask_cont_to(i),i=1,ntask_cont_to)
+ call flush(iout)
+ write (iout,*) "iint_sent"
+ do i=1,nat_sent
+ ii=iat_sent(i)
+ write (iout,'(20i4)') ii,(j,(iint_sent(k,j,i),k=1,4),
+ & j=ielstart(ii),ielend(ii))
+ enddo
+ write (iout,*) "iturn3_sent iturn3_start",iturn3_start,
+ & " iturn3_end",iturn3_end
+ write (iout,'(20i4)') (i,(iturn3_sent(j,i),j=1,4),
+ & i=iturn3_start,iturn3_end)
+ write (iout,*) "iturn4_sent iturn4_start",iturn4_start,
+ & " iturn4_end",iturn4_end
+ write (iout,'(20i4)') (i,(iturn4_sent(j,i),j=1,4),
+ & i=iturn4_start,iturn4_end)
+ call flush(iout)
+ endif
+ call MPI_Gather(ntask_cont_from,1,MPI_INTEGER,
+ & ntask_cont_from_all,1,MPI_INTEGER,king,FG_COMM,IERR)
+c write (iout,*) "Gather ntask_cont_from ended"
+c call flush(iout)
+ call MPI_Gather(itask_cont_from(0),max_fg_procs,MPI_INTEGER,
+ & itask_cont_from_all(0,0),max_fg_procs,MPI_INTEGER,king,
+ & FG_COMM,IERR)
+c write (iout,*) "Gather itask_cont_from ended"
+c call flush(iout)
+ call MPI_Gather(ntask_cont_to,1,MPI_INTEGER,ntask_cont_to_all,
+ & 1,MPI_INTEGER,king,FG_COMM,IERR)
+c write (iout,*) "Gather ntask_cont_to ended"
+c call flush(iout)
+ call MPI_Gather(itask_cont_to,max_fg_procs,MPI_INTEGER,
+ & itask_cont_to_all,max_fg_procs,MPI_INTEGER,king,FG_COMM,IERR)
+c write (iout,*) "Gather itask_cont_to ended"
+c call flush(iout)
+ if (fg_rank.eq.king) then
+ write (iout,*)"Contact receive task map (proc, #tasks, tasks)"
+ do i=0,nfgtasks-1
+ write (iout,'(20i4)') i,ntask_cont_from_all(i),
+ & (itask_cont_from_all(j,i),j=1,ntask_cont_from_all(i))
+ enddo
+ write (iout,*)
+ call flush(iout)
+ write (iout,*) "Contact send task map (proc, #tasks, tasks)"
+ do i=0,nfgtasks-1
+ write (iout,'(20i4)') i,ntask_cont_to_all(i),
+ & (itask_cont_to_all(j,i),j=1,ntask_cont_to_all(i))
+ enddo
+ write (iout,*)
+ call flush(iout)
+C Check if every send will have a matching receive
+ ncheck_to=0
+ ncheck_from=0
+ do i=0,nfgtasks-1
+ ncheck_to=ncheck_to+ntask_cont_to_all(i)
+ ncheck_from=ncheck_from+ntask_cont_from_all(i)
+ enddo
+ write (iout,*) "Control sums",ncheck_from,ncheck_to
+ if (ncheck_from.ne.ncheck_to) then
+ write (iout,*) "Error: #receive differs from #send."
+ write (iout,*) "Terminating program...!"
+ call flush(iout)
+ flag=.false.
+ else
+ flag=.true.
+ do i=0,nfgtasks-1
+ do j=1,ntask_cont_to_all(i)
+ ii=itask_cont_to_all(j,i)
+ do k=1,ntask_cont_from_all(ii)
+ if (itask_cont_from_all(k,ii).eq.i) then
+ if(lprint)write(iout,*)"Matching send/receive",i,ii
+ exit
+ endif
+ enddo
+ if (k.eq.ntask_cont_from_all(ii)+1) then
+ flag=.false.
+ write (iout,*) "Error: send by",j," to",ii,
+ & " would have no matching receive"
+ endif
+ enddo
+ enddo
+ endif
+ if (.not.flag) then
+ write (iout,*) "Unmatched sends; terminating program"
+ call flush(iout)
+ endif
+ endif
+ call MPI_Bcast(flag,1,MPI_LOGICAL,king,FG_COMM,IERROR)
+c write (iout,*) "flag broadcast ended flag=",flag
+c call flush(iout)
+ if (.not.flag) then
+ call MPI_Finalize(IERROR)
+ stop "Error in INIT_INT_TABLE: unmatched send/receive."
+ endif
+ call MPI_Comm_group(FG_COMM,fg_group,IERR)
+c write (iout,*) "MPI_Comm_group ended"
+c call flush(iout)
+ call MPI_Group_incl(fg_group,ntask_cont_from+1,
+ & itask_cont_from(0),CONT_FROM_GROUP,IERR)
+ call MPI_Group_incl(fg_group,ntask_cont_to+1,itask_cont_to(0),
+ & CONT_TO_GROUP,IERR)
+ do i=1,nat_sent
+ ii=iat_sent(i)
+ iaux=4*(ielend(ii)-ielstart(ii)+1)
+ call MPI_Group_translate_ranks(fg_group,iaux,
+ & iint_sent(1,ielstart(ii),i),CONT_TO_GROUP,
+ & iint_sent_local(1,ielstart(ii),i),IERR )
+c write (iout,*) "Ranks translated i=",i
+c call flush(iout)
+ enddo
+ iaux=4*(iturn3_end-iturn3_start+1)
+ call MPI_Group_translate_ranks(fg_group,iaux,
+ & iturn3_sent(1,iturn3_start),CONT_TO_GROUP,
+ & iturn3_sent_local(1,iturn3_start),IERR)
+ iaux=4*(iturn4_end-iturn4_start+1)
+ call MPI_Group_translate_ranks(fg_group,iaux,
+ & iturn4_sent(1,iturn4_start),CONT_TO_GROUP,
+ & iturn4_sent_local(1,iturn4_start),IERR)
+ if (lprint) then
+ write (iout,*) "iint_sent_local"
+ do i=1,nat_sent
+ ii=iat_sent(i)
+ write (iout,'(20i4)') ii,(j,(iint_sent_local(k,j,i),k=1,4),
+ & j=ielstart(ii),ielend(ii))
+ call flush(iout)
+ enddo
+ write (iout,*) "iturn3_sent_local iturn3_start",iturn3_start,
+ & " iturn3_end",iturn3_end
+ write (iout,'(20i4)') (i,(iturn3_sent_local(j,i),j=1,4),
+ & i=iturn3_start,iturn3_end)
+ write (iout,*) "iturn4_sent_local iturn4_start",iturn4_start,
+ & " iturn4_end",iturn4_end
+ write (iout,'(20i4)') (i,(iturn4_sent_local(j,i),j=1,4),
+ & i=iturn4_start,iturn4_end)
+ call flush(iout)
+ endif
+ call MPI_Group_free(fg_group,ierr)
+ call MPI_Group_free(cont_from_group,ierr)
+ call MPI_Group_free(cont_to_group,ierr)
+ call MPI_Type_contiguous(3,MPI_DOUBLE_PRECISION,MPI_UYZ,IERROR)
+ call MPI_Type_commit(MPI_UYZ,IERROR)
+ call MPI_Type_contiguous(18,MPI_DOUBLE_PRECISION,MPI_UYZGRAD,
+ & IERROR)
+ call MPI_Type_commit(MPI_UYZGRAD,IERROR)
+ call MPI_Type_contiguous(2,MPI_DOUBLE_PRECISION,MPI_MU,IERROR)
+ call MPI_Type_commit(MPI_MU,IERROR)
+ call MPI_Type_contiguous(4,MPI_DOUBLE_PRECISION,MPI_MAT1,IERROR)
+ call MPI_Type_commit(MPI_MAT1,IERROR)
+ call MPI_Type_contiguous(8,MPI_DOUBLE_PRECISION,MPI_MAT2,IERROR)
+ call MPI_Type_commit(MPI_MAT2,IERROR)
+ call MPI_Type_contiguous(6,MPI_DOUBLE_PRECISION,MPI_THET,IERROR)
+ call MPI_Type_commit(MPI_THET,IERROR)
+ call MPI_Type_contiguous(9,MPI_DOUBLE_PRECISION,MPI_GAM,IERROR)
+ call MPI_Type_commit(MPI_GAM,IERROR)
+#ifndef MATGATHER
+c 9/22/08 Derived types to send matrices which appear in correlation terms
+ do i=0,nfgtasks-1
+ if (ivec_count(i).eq.ivec_count(0)) then
+ lentyp(i)=0
+ else
+ lentyp(i)=1
+ endif
+ enddo
+ do ind_typ=lentyp(0),lentyp(nfgtasks-1)
+ if (ind_typ.eq.0) then
+ ichunk=ivec_count(0)
+ else
+ ichunk=ivec_count(1)
+ endif
+c do i=1,4
+c blocklengths(i)=4
+c enddo
+c displs(1)=0
+c do i=2,4
+c displs(i)=displs(i-1)+blocklengths(i-1)*maxres
+c enddo
+c do i=1,4
+c blocklengths(i)=blocklengths(i)*ichunk
+c enddo
+c write (iout,*) "blocklengths and displs"
+c do i=1,4
+c write (iout,*) i,blocklengths(i),displs(i)
+c enddo
+c call flush(iout)
+c call MPI_Type_indexed(4,blocklengths(1),displs(1),
+c & MPI_DOUBLE_PRECISION,MPI_ROTAT1(ind_typ),IERROR)
+c call MPI_Type_commit(MPI_ROTAT1(ind_typ),IERROR)
+c write (iout,*) "MPI_ROTAT1",MPI_ROTAT1
+c do i=1,4
+c blocklengths(i)=2
+c enddo
+c displs(1)=0
+c do i=2,4
+c displs(i)=displs(i-1)+blocklengths(i-1)*maxres
+c enddo
+c do i=1,4
+c blocklengths(i)=blocklengths(i)*ichunk
+c enddo
+c write (iout,*) "blocklengths and displs"
+c do i=1,4
+c write (iout,*) i,blocklengths(i),displs(i)
+c enddo
+c call flush(iout)
+c call MPI_Type_indexed(4,blocklengths(1),displs(1),
+c & MPI_DOUBLE_PRECISION,MPI_ROTAT2(ind_typ),IERROR)
+c call MPI_Type_commit(MPI_ROTAT2(ind_typ),IERROR)
+c write (iout,*) "MPI_ROTAT2",MPI_ROTAT2
+ do i=1,8
+ blocklengths(i)=2
+ enddo
+ displs(1)=0
+ do i=2,8
+ displs(i)=displs(i-1)+blocklengths(i-1)*maxres
+ enddo
+ do i=1,15
+ blocklengths(i)=blocklengths(i)*ichunk
+ enddo
+ call MPI_Type_indexed(8,blocklengths,displs,
+ & MPI_DOUBLE_PRECISION,MPI_PRECOMP11(ind_typ),IERROR)
+ call MPI_Type_commit(MPI_PRECOMP11(ind_typ),IERROR)
+ do i=1,8
+ blocklengths(i)=4
+ enddo
+ displs(1)=0
+ do i=2,8
+ displs(i)=displs(i-1)+blocklengths(i-1)*maxres
+ enddo
+ do i=1,15
+ blocklengths(i)=blocklengths(i)*ichunk
+ enddo
+ call MPI_Type_indexed(8,blocklengths,displs,
+ & MPI_DOUBLE_PRECISION,MPI_PRECOMP12(ind_typ),IERROR)
+ call MPI_Type_commit(MPI_PRECOMP12(ind_typ),IERROR)
+ do i=1,6
+ blocklengths(i)=4
+ enddo
+ displs(1)=0
+ do i=2,6
+ displs(i)=displs(i-1)+blocklengths(i-1)*maxres
+ enddo
+ do i=1,6
+ blocklengths(i)=blocklengths(i)*ichunk
+ enddo
+ call MPI_Type_indexed(6,blocklengths,displs,
+ & MPI_DOUBLE_PRECISION,MPI_PRECOMP22(ind_typ),IERROR)
+ call MPI_Type_commit(MPI_PRECOMP22(ind_typ),IERROR)
+ do i=1,2
+ blocklengths(i)=8
+ enddo
+ displs(1)=0
+ do i=2,2
+ displs(i)=displs(i-1)+blocklengths(i-1)*maxres
+ enddo
+ do i=1,2
+ blocklengths(i)=blocklengths(i)*ichunk
+ enddo
+ call MPI_Type_indexed(2,blocklengths,displs,
+ & MPI_DOUBLE_PRECISION,MPI_PRECOMP23(ind_typ),IERROR)
+ call MPI_Type_commit(MPI_PRECOMP23(ind_typ),IERROR)
+ do i=1,4
+ blocklengths(i)=1
+ enddo
+ displs(1)=0
+ do i=2,4
+ displs(i)=displs(i-1)+blocklengths(i-1)*maxres
+ enddo
+ do i=1,4
+ blocklengths(i)=blocklengths(i)*ichunk
+ enddo
+ call MPI_Type_indexed(4,blocklengths,displs,
+ & MPI_DOUBLE_PRECISION,MPI_ROTAT_OLD(ind_typ),IERROR)
+ call MPI_Type_commit(MPI_ROTAT_OLD(ind_typ),IERROR)
+ enddo
+#endif
+ endif
+ iint_start=ivec_start+1
+ iint_end=ivec_end+1
+ do i=0,nfgtasks-1
+ iint_count(i)=ivec_count(i)
+ iint_displ(i)=ivec_displ(i)
+ ivec_displ(i)=ivec_displ(i)-1
+ iset_displ(i)=iset_displ(i)-1
+ ithet_displ(i)=ithet_displ(i)-1
+ iphi_displ(i)=iphi_displ(i)-1
+ iphi1_displ(i)=iphi1_displ(i)-1
+ ibond_displ(i)=ibond_displ(i)-1
+ enddo
+ if (nfgtasks.gt.1 .and. fg_rank.eq.king
+ & .and. (me.eq.0 .or. out1file)) then
+ write (iout,*) "IVEC_DISPL, IVEC_COUNT, ISET_START, ISET_COUNT"
+ do i=0,nfgtasks-1
+ write (iout,*) i,ivec_displ(i),ivec_count(i),iset_displ(i),
+ & iset_count(i)
+ enddo
+ write (iout,*) "iphi_start",iphi_start," iphi_end",iphi_end,
+ & " iphi1_start",iphi1_start," iphi1_end",iphi1_end
+ write (iout,*)"IPHI_COUNT, IPHI_DISPL, IPHI1_COUNT, IPHI1_DISPL"
+ do i=0,nfgtasks-1
+ write (iout,*) i,iphi_count(i),iphi_displ(i),iphi1_count(i),
+ & iphi1_displ(i)
+ enddo
+ write(iout,'(i10,a,i10,a,i10,a/a,i3,a)') n_sc_int_tot,' SC-SC ',
+ & nele_int_tot,' electrostatic and ',nscp_int_tot,
+ & ' SC-p interactions','were distributed among',nfgtasks,
+ & ' fine-grain processors.'
+ endif
+#else
+ 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
+ iphi1_start=4
+ iphi1_end=nres
+ idihconstr_start=1
+ idihconstr_end=ndih_constr
+ iphid_start=iphi_start
+ iphid_end=iphi_end-1
+ itau_start=4
+ itau_end=nres
+ ibond_start=2
+ ibond_end=nres-1
+ ibondp_start=nnt+1
+ ibondp_end=nct
+ ivec_start=1
+ ivec_end=nres-1
+ iset_start=3
+ iset_end=nres+1
+ iint_start=2
+ iint_end=nres-1
+#endif
+ return
+ end
+#ifdef MPI
+c---------------------------------------------------------------------------
+ subroutine add_int(ii,jj,itask,ntask_cont_to,itask_cont_to,flag)
+ implicit none
+ include "DIMENSIONS"
+ include "COMMON.INTERACT"
+ include "COMMON.SETUP"
+ include "COMMON.IOUNITS"
+ integer ii,jj,itask(4),ntask_cont_to,itask_cont_to(0:MaxProcs-1)
+ logical flag
+ integer iturn3_start_all,iturn3_end_all,iturn4_start_all,
+ & iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all
+ common /przechowalnia/ iturn3_start_all(0:MaxProcs),
+ & iturn3_end_all(0:MaxProcs),iturn4_start_all(0:MaxProcs),
+ & iturn4_end_all(0:MaxProcs),iatel_s_all(0:MaxProcs),
+ & iatel_e_all(0:MaxProcs),ielstart_all(maxres,0:MaxProcs-1),
+ & ielend_all(maxres,0:MaxProcs-1)
+ integer iproc,isent,k,l
+c Determines whether to send interaction ii,jj to other processors; a given
+c interaction can be sent to at most 2 processors.
+c Sets flag=.true. if interaction ii,jj needs to be sent to at least
+c one processor, otherwise flag is unchanged from the input value.
+ isent=0
+ itask(1)=fg_rank
+ itask(2)=fg_rank
+ itask(3)=fg_rank
+ itask(4)=fg_rank
+c write (iout,*) "ii",ii," jj",jj
+c Loop over processors to check if anybody could need interaction ii,jj
+ do iproc=0,fg_rank-1
+c Check if the interaction matches any turn3 at iproc
+ do k=iturn3_start_all(iproc),iturn3_end_all(iproc)
+ l=k+2
+ if (k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1
+ & .or. k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1 .and. l.eq.jj-1)
+ & then
+c write (iout,*) "turn3 to iproc",iproc," ij",ii,jj,"kl",k,l
+c call flush(iout)
+ flag=.true.
+ if (iproc.ne.itask(1).and.iproc.ne.itask(2)
+ & .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
+ isent=isent+1
+ itask(isent)=iproc
+ call add_task(iproc,ntask_cont_to,itask_cont_to)
+ endif
+ endif
+ enddo
+C Check if the interaction matches any turn4 at iproc
+ do k=iturn4_start_all(iproc),iturn4_end_all(iproc)
+ l=k+3
+ if (k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1
+ & .or. k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1 .and. l.eq.jj-1)
+ & then
+c write (iout,*) "turn3 to iproc",iproc," ij",ii,jj," kl",k,l
+c call flush(iout)
+ flag=.true.
+ if (iproc.ne.itask(1).and.iproc.ne.itask(2)
+ & .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
+ isent=isent+1
+ itask(isent)=iproc
+ call add_task(iproc,ntask_cont_to,itask_cont_to)
+ endif
+ endif
+ enddo
+ if (iatel_s_all(iproc).gt.0 .and. iatel_e_all(iproc).gt.0 .and.
+ & iatel_s_all(iproc).le.ii-1 .and. iatel_e_all(iproc).ge.ii-1)then
+ if (ielstart_all(ii-1,iproc).le.jj-1.and.
+ & ielend_all(ii-1,iproc).ge.jj-1) then
+ flag=.true.
+ if (iproc.ne.itask(1).and.iproc.ne.itask(2)
+ & .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
+ isent=isent+1
+ itask(isent)=iproc
+ call add_task(iproc,ntask_cont_to,itask_cont_to)
+ endif
+ endif
+ if (ielstart_all(ii-1,iproc).le.jj+1.and.
+ & ielend_all(ii-1,iproc).ge.jj+1) then
+ flag=.true.
+ if (iproc.ne.itask(1).and.iproc.ne.itask(2)
+ & .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
+ isent=isent+1
+ itask(isent)=iproc
+ call add_task(iproc,ntask_cont_to,itask_cont_to)
+ endif
+ endif
+ endif
+ enddo
+ return
+ end
+c---------------------------------------------------------------------------
+ subroutine add_int_from(ii,jj,ntask_cont_from,itask_cont_from)
+ implicit none
+ include "DIMENSIONS"
+ include "COMMON.INTERACT"
+ include "COMMON.SETUP"
+ include "COMMON.IOUNITS"
+ integer ii,jj,itask(2),ntask_cont_from,
+ & itask_cont_from(0:MaxProcs-1)
+ logical flag
+ integer iturn3_start_all,iturn3_end_all,iturn4_start_all,
+ & iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all
+ common /przechowalnia/ iturn3_start_all(0:MaxProcs),
+ & iturn3_end_all(0:MaxProcs),iturn4_start_all(0:MaxProcs),
+ & iturn4_end_all(0:MaxProcs),iatel_s_all(0:MaxProcs),
+ & iatel_e_all(0:MaxProcs),ielstart_all(maxres,0:MaxProcs-1),
+ & ielend_all(maxres,0:MaxProcs-1)
+ integer iproc,k,l
+ do iproc=fg_rank+1,nfgtasks-1
+ do k=iturn3_start_all(iproc),iturn3_end_all(iproc)
+ l=k+2
+ if (k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1.and.l.eq.jj-1
+ & .or. k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1)
+ & then
+c write (iout,*)"turn3 from iproc",iproc," ij",ii,jj," kl",k,l
+ call add_task(iproc,ntask_cont_from,itask_cont_from)
+ endif
+ enddo
+ do k=iturn4_start_all(iproc),iturn4_end_all(iproc)
+ l=k+3
+ if (k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1.and.l.eq.jj-1
+ & .or. k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1)
+ & then
+c write (iout,*)"turn4 from iproc",iproc," ij",ii,jj," kl",k,l
+ call add_task(iproc,ntask_cont_from,itask_cont_from)
+ endif
+ enddo
+ if (iatel_s_all(iproc).gt.0 .and. iatel_e_all(iproc).gt.0) then
+ if (ii+1.ge.iatel_s_all(iproc).and.ii+1.le.iatel_e_all(iproc))
+ & then
+ if (jj+1.ge.ielstart_all(ii+1,iproc).and.
+ & jj+1.le.ielend_all(ii+1,iproc)) then
+ call add_task(iproc,ntask_cont_from,itask_cont_from)
+ endif
+ if (jj-1.ge.ielstart_all(ii+1,iproc).and.
+ & jj-1.le.ielend_all(ii+1,iproc)) then
+ call add_task(iproc,ntask_cont_from,itask_cont_from)
+ endif
+ endif
+ if (ii-1.ge.iatel_s_all(iproc).and.ii-1.le.iatel_e_all(iproc))
+ & then
+ if (jj-1.ge.ielstart_all(ii-1,iproc).and.
+ & jj-1.le.ielend_all(ii-1,iproc)) then
+ call add_task(iproc,ntask_cont_from,itask_cont_from)
+ endif
+ if (jj+1.ge.ielstart_all(ii-1,iproc).and.
+ & jj+1.le.ielend_all(ii-1,iproc)) then
+ call add_task(iproc,ntask_cont_from,itask_cont_from)
+ endif
+ endif
+ endif
+ enddo
+ return
+ end
+c---------------------------------------------------------------------------
+ subroutine add_task(iproc,ntask_cont,itask_cont)
+ implicit none
+ include "DIMENSIONS"
+ integer iproc,ntask_cont,itask_cont(0:MaxProcs-1)
+ integer ii
+ do ii=1,ntask_cont
+ if (itask_cont(ii).eq.iproc) return
+ enddo
+ ntask_cont=ntask_cont+1
+ itask_cont(ntask_cont)=iproc
+ return
+ end
+c---------------------------------------------------------------------------
+ subroutine int_bounds(total_ints,lower_bound,upper_bound)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'mpif.h'
+ include 'COMMON.SETUP'
+ integer total_ints,lower_bound,upper_bound
+ integer int4proc(0:max_fg_procs),sint4proc(0:max_fg_procs)
+ nint=total_ints/nfgtasks
+ do i=1,nfgtasks
+ int4proc(i-1)=nint
+ enddo
+ nexcess=total_ints-nint*nfgtasks
+ do i=1,nexcess
+ int4proc(nfgtasks-i)=int4proc(nfgtasks-i)+1
+ enddo
+ lower_bound=0
+ do i=0,fg_rank-1
+ lower_bound=lower_bound+int4proc(i)
+ enddo
+ upper_bound=lower_bound+int4proc(fg_rank)
+ lower_bound=lower_bound+1
+ return
+ end
+c---------------------------------------------------------------------------
+ subroutine int_bounds1(total_ints,lower_bound,upper_bound)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'mpif.h'
+ include 'COMMON.SETUP'
+ integer total_ints,lower_bound,upper_bound
+ integer int4proc(0:max_fg_procs),sint4proc(0:max_fg_procs)
+ nint=total_ints/nfgtasks1
+ do i=1,nfgtasks1
+ int4proc(i-1)=nint
+ enddo
+ nexcess=total_ints-nint*nfgtasks1
+ do i=1,nexcess
+ int4proc(nfgtasks1-i)=int4proc(nfgtasks1-i)+1
+ enddo
+ lower_bound=0
+ do i=0,fg_rank1-1
+ lower_bound=lower_bound+int4proc(i)
+ enddo
+ upper_bound=lower_bound+int4proc(fg_rank1)
+ lower_bound=lower_bound+1
+ 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
+#endif
+c------------------------------------------------------------------------------
+ subroutine hpb_partition
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.SETUP'
+ include 'COMMON.CONTROL'
+#ifdef MPI
+ call int_bounds(nhpb,link_start,link_end)
+ if (.not. out1file)
+ & write (iout,*) 'Processor',fg_rank,' CG group',kolor,
+ & ' absolute rank',MyRank,
+ & ' nhpb',nhpb,' link_start=',link_start,
+ & ' link_end',link_end
+#else
+ link_start=1
+ link_end=nhpb
+#endif
+ return
+ end
--- /dev/null
+ subroutine int_to_cart
+c--------------------------------------------------------------
+c This subroutine converts the energy derivatives from internal
+c coordinates to cartesian coordinates
+c-------------------------------------------------------------
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.VAR'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.MD'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.SCCOR'
+c calculating dE/ddc1
+ if (nres.lt.3) goto 18
+c do i=1,nres
+c c do intertyp=1,3
+c write (iout,*) "przed tosyjnymi",i,intertyp,gcart(intertyp,i)
+c &,gloc_sc(1,i,icg),gloc(i,icg)
+c enddo
+c enddo
+ do j=1,3
+ gcart(j,1)=gcart(j,1)+gloc(1,icg)*dphi(j,1,4)
+ & +gloc(nres-2,icg)*dtheta(j,1,3)
+ if(itype(2).ne.10) then
+ gcart(j,1)=gcart(j,1)+gloc(ialph(2,1),icg)*dalpha(j,1,2)+
+ & gloc(ialph(2,1)+nside,icg)*domega(j,1,2)
+ endif
+ enddo
+c Calculating the remainder of dE/ddc2
+ do j=1,3
+ gcart(j,2)=gcart(j,2)+gloc(1,icg)*dphi(j,2,4)+
+ & gloc(nres-2,icg)*dtheta(j,2,3)+gloc(nres-1,icg)*dtheta(j,1,4)
+ if(itype(2).ne.10) then
+ gcart(j,2)=gcart(j,2)+gloc(ialph(2,1),icg)*dalpha(j,2,2)+
+ & gloc(ialph(2,1)+nside,icg)*domega(j,2,2)
+ endif
+ if(itype(3).ne.10) then
+ gcart(j,2)=gcart(j,2)+gloc(ialph(3,1),icg)*dalpha(j,1,3)+
+ & gloc(ialph(3,1)+nside,icg)*domega(j,1,3)
+ endif
+ if(nres.gt.4) then
+ gcart(j,2)=gcart(j,2)+gloc(2,icg)*dphi(j,1,5)
+ endif
+ enddo
+c If there are only five residues
+ if(nres.eq.5) then
+ do j=1,3
+ gcart(j,3)=gcart(j,3)+gloc(1,icg)*dphi(j,3,4)+gloc(2,icg)*
+ & dphi(j,2,5)+gloc(nres-1,icg)*dtheta(j,2,4)+gloc(nres,icg)*
+ & dtheta(j,1,5)
+ if(itype(3).ne.10) then
+ gcart(j,3)=gcart(j,3)+gloc(ialph(3,1),icg)*
+ & dalpha(j,2,3)+gloc(ialph(3,1)+nside,icg)*domega(j,2,3)
+ endif
+ if(itype(4).ne.10) then
+ gcart(j,3)=gcart(j,3)+gloc(ialph(4,1),icg)*
+ & dalpha(j,1,4)+gloc(ialph(4,1)+nside,icg)*domega(j,1,4)
+ endif
+ enddo
+ endif
+c If there are more than five residues
+ if(nres.gt.5) then
+ do i=3,nres-3
+ do j=1,3
+ gcart(j,i)=gcart(j,i)+gloc(i-2,icg)*dphi(j,3,i+1)
+ & +gloc(i-1,icg)*dphi(j,2,i+2)+
+ & gloc(i,icg)*dphi(j,1,i+3)+gloc(nres+i-4,icg)*dtheta(j,2,i+1)+
+ & gloc(nres+i-3,icg)*dtheta(j,1,i+2)
+ if(itype(i).ne.10) then
+ gcart(j,i)=gcart(j,i)+gloc(ialph(i,1),icg)*dalpha(j,2,i)+
+ & gloc(ialph(i,1)+nside,icg)*domega(j,2,i)
+ endif
+ if(itype(i+1).ne.10) then
+ gcart(j,i)=gcart(j,i)+gloc(ialph(i+1,1),icg)*dalpha(j,1,i+1)
+ & +gloc(ialph(i+1,1)+nside,icg)*domega(j,1,i+1)
+ endif
+ enddo
+ enddo
+ endif
+c Setting dE/ddnres-2
+ if(nres.gt.5) then
+ do j=1,3
+ gcart(j,nres-2)=gcart(j,nres-2)+gloc(nres-4,icg)*
+ & dphi(j,3,nres-1)+gloc(nres-3,icg)*dphi(j,2,nres)
+ & +gloc(2*nres-6,icg)*
+ & dtheta(j,2,nres-1)+gloc(2*nres-5,icg)*dtheta(j,1,nres)
+ if(itype(nres-2).ne.10) then
+ gcart(j,nres-2)=gcart(j,nres-2)+gloc(ialph(nres-2,1),icg)*
+ & dalpha(j,2,nres-2)+gloc(ialph(nres-2,1)+nside,icg)*
+ & domega(j,2,nres-2)
+ endif
+ if(itype(nres-1).ne.10) then
+ gcart(j,nres-2)=gcart(j,nres-2)+gloc(ialph(nres-1,1),icg)*
+ & dalpha(j,1,nres-1)+gloc(ialph(nres-1,1)+nside,icg)*
+ & domega(j,1,nres-1)
+ endif
+ enddo
+ endif
+c Settind dE/ddnres-1
+ do j=1,3
+ gcart(j,nres-1)=gcart(j,nres-1)+gloc(nres-3,icg)*dphi(j,3,nres)+
+ & gloc(2*nres-5,icg)*dtheta(j,2,nres)
+ if(itype(nres-1).ne.10) then
+ gcart(j,nres-1)=gcart(j,nres-1)+gloc(ialph(nres-1,1),icg)*
+ & dalpha(j,2,nres-1)+gloc(ialph(nres-1,1)+nside,icg)*
+ & domega(j,2,nres-1)
+ endif
+ enddo
+c The side-chain vector derivatives
+ do i=2,nres-1
+ if(itype(i).ne.10) then
+ do j=1,3
+ gxcart(j,i)=gxcart(j,i)+gloc(ialph(i,1),icg)*dalpha(j,3,i)
+ & +gloc(ialph(i,1)+nside,icg)*domega(j,3,i)
+ enddo
+ endif
+ enddo
+c----------------------------------------------------------------------
+C INTERTYP=1 SC...Ca...Ca...Ca
+C INTERTYP=2 Ca...Ca...Ca...SC
+C INTERTYP=3 SC...Ca...Ca...SC
+c calculating dE/ddc1
+ 18 continue
+c do i=1,nres
+c gloc(i,icg)=0.0D0
+c write (iout,*) "poczotkoawy",i,gloc_sc(1,i,icg)
+c enddo
+ if (nres.lt.2) return
+ if ((nres.lt.3).and.(itype(1).eq.10)) return
+ if ((itype(1).ne.10).and.(itype(1).ne.21)) then
+ do j=1,3
+cc Derviative was calculated for oposite vector of side chain therefore
+c there is "-" sign before gloc_sc
+ gxcart(j,1)=gxcart(j,1)-gloc_sc(1,0,icg)*
+ & dtauangle(j,1,1,3)
+ gcart(j,1)=gcart(j,1)+gloc_sc(1,0,icg)*
+ & dtauangle(j,1,2,3)
+ if ((itype(2).ne.10).and.(itype(2).ne.21)) then
+ gxcart(j,1)= gxcart(j,1)
+ & -gloc_sc(3,0,icg)*dtauangle(j,3,1,3)
+ gcart(j,1)=gcart(j,1)+gloc_sc(3,0,icg)*
+ & dtauangle(j,3,2,3)
+ endif
+ enddo
+ endif
+ if ((nres.ge.3).and.(itype(3).ne.10).and.(itype(3).ne.21))
+ & then
+ do j=1,3
+ gcart(j,1)=gcart(j,1)+gloc_sc(2,1,icg)*dtauangle(j,2,1,4)
+ enddo
+ endif
+c As potetnial DO NOT depend on omicron anlge their derivative is
+c ommited
+c & +gloc_sc(intertyp,nres-2,icg)*dtheta(j,1,3)
+
+c Calculating the remainder of dE/ddc2
+ do j=1,3
+ if((itype(2).ne.10).and.(itype(2).ne.21)) then
+ if (itype(1).ne.10) gxcart(j,2)=gxcart(j,2)+
+ & gloc_sc(3,0,icg)*dtauangle(j,3,3,3)
+ if ((itype(3).ne.10).and.(nres.ge.3).and.(itype(3).ne.21)) then
+ gxcart(j,2)=gxcart(j,2)-gloc_sc(3,1,icg)*dtauangle(j,3,1,4)
+cc the - above is due to different vector direction
+ gcart(j,2)=gcart(j,2)+gloc_sc(3,1,icg)*dtauangle(j,3,2,4)
+ endif
+ if (nres.gt.3) then
+ gxcart(j,2)=gxcart(j,2)-gloc_sc(1,1,icg)*dtauangle(j,1,1,4)
+cc the - above is due to different vector direction
+ gcart(j,2)=gcart(j,2)+gloc_sc(1,1,icg)*dtauangle(j,1,2,4)
+c write(iout,*) gloc_sc(1,1,icg),dtauangle(j,1,2,4),"gcart"
+c write(iout,*) gloc_sc(1,1,icg),dtauangle(j,1,1,4),"gx"
+ endif
+ endif
+ if ((itype(1).ne.10).and.(itype(1).ne.21)) then
+ gcart(j,2)=gcart(j,2)+gloc_sc(1,0,icg)*dtauangle(j,1,3,3)
+c write(iout,*) gloc_sc(1,0,icg),dtauangle(j,1,3,3)
+ endif
+ if ((itype(3).ne.10).and.(nres.ge.3)) then
+ gcart(j,2)=gcart(j,2)+gloc_sc(2,1,icg)*dtauangle(j,2,2,4)
+c write(iout,*) gloc_sc(2,1,icg),dtauangle(j,2,2,4)
+ endif
+ if ((itype(4).ne.10).and.(nres.ge.4)) then
+ gcart(j,2)=gcart(j,2)+gloc_sc(2,2,icg)*dtauangle(j,2,1,5)
+c write(iout,*) gloc_sc(2,2,icg),dtauangle(j,2,1,5)
+ endif
+
+c write(iout,*) gcart(j,2),itype(2),itype(1),itype(3), "gcart2"
+ enddo
+c If there are more than five residues
+ if(nres.ge.5) then
+ do i=3,nres-2
+ do j=1,3
+c write(iout,*) "before", gcart(j,i)
+ if (itype(i).ne.10) then
+ gxcart(j,i)=gxcart(j,i)+gloc_sc(2,i-2,icg)
+ & *dtauangle(j,2,3,i+1)
+ & -gloc_sc(1,i-1,icg)*dtauangle(j,1,1,i+2)
+ gcart(j,i)=gcart(j,i)+gloc_sc(1,i-1,icg)
+ & *dtauangle(j,1,2,i+2)
+c write(iout,*) "new",j,i,
+c & gcart(j,i),gloc_sc(1,i-1,icg),dtauangle(j,1,2,i+2)
+
+ if (itype(i-1).ne.10) then
+ gxcart(j,i)=gxcart(j,i)+gloc_sc(3,i-2,icg)
+ &*dtauangle(j,3,3,i+1)
+ endif
+ if (itype(i+1).ne.10) then
+ gxcart(j,i)=gxcart(j,i)-gloc_sc(3,i-1,icg)
+ &*dtauangle(j,3,1,i+2)
+ gcart(j,i)=gcart(j,i)+gloc_sc(3,i-1,icg)
+ &*dtauangle(j,3,2,i+2)
+ endif
+ endif
+ if (itype(i-1).ne.10) then
+ gcart(j,i)=gcart(j,i)+gloc_sc(1,i-2,icg)*
+ & dtauangle(j,1,3,i+1)
+ endif
+ if (itype(i+1).ne.10) then
+ gcart(j,i)=gcart(j,i)+gloc_sc(2,i-1,icg)*
+ & dtauangle(j,2,2,i+2)
+c write(iout,*) "numer",i,gloc_sc(2,i-1,icg),
+c & dtauangle(j,2,2,i+2)
+ endif
+ if (itype(i+2).ne.10) then
+ gcart(j,i)=gcart(j,i)+gloc_sc(2,i,icg)*
+ & dtauangle(j,2,1,i+3)
+ endif
+ enddo
+ enddo
+ endif
+c Setting dE/ddnres-1
+ if(nres.ge.4) then
+ do j=1,3
+ if ((itype(nres-1).ne.10).and.(itype(nres-1).ne.21)) then
+ gxcart(j,nres-1)=gxcart(j,nres-1)+gloc_sc(2,nres-3,icg)
+ & *dtauangle(j,2,3,nres)
+c write (iout,*) "gxcart(nres-1)", gloc_sc(2,nres-3,icg),
+c & dtauangle(j,2,3,nres), gxcart(j,nres-1)
+ if (itype(nres-2).ne.10) then
+ gxcart(j,nres-1)=gxcart(j,nres-1)+gloc_sc(3,nres-3,icg)
+ & *dtauangle(j,3,3,nres)
+ endif
+ if ((itype(nres).ne.10).and.(itype(nres).ne.21)) then
+ gxcart(j,nres-1)=gxcart(j,nres-1)-gloc_sc(3,nres-2,icg)
+ & *dtauangle(j,3,1,nres+1)
+ gcart(j,nres-1)=gcart(j,nres-1)+gloc_sc(3,nres-2,icg)
+ & *dtauangle(j,3,2,nres+1)
+ endif
+ endif
+ if ((itype(nres-2).ne.10).and.(itype(nres-2).ne.21)) then
+ gcart(j,nres-1)=gcart(j,nres-1)+gloc_sc(1,nres-3,icg)*
+ & dtauangle(j,1,3,nres)
+ endif
+ if ((itype(nres).ne.10).and.(itype(nres).ne.21)) then
+ gcart(j,nres-1)=gcart(j,nres-1)+gloc_sc(2,nres-2,icg)*
+ & dtauangle(j,2,2,nres+1)
+c write (iout,*) "gcart(nres-1)", gloc_sc(2,nres-2,icg),
+c & dtauangle(j,2,2,nres+1), itype(nres-1),itype(nres)
+ endif
+ enddo
+ endif
+c Settind dE/ddnres
+ if ((nres.ge.3).and.(itype(nres).ne.10))then
+ do j=1,3
+ gxcart(j,nres)=gxcart(j,nres)+gloc_sc(3,nres-2,icg)
+ & *dtauangle(j,3,3,nres+1)+gloc_sc(2,nres-2,icg)
+ & *dtauangle(j,2,3,nres+1)
+ enddo
+ endif
+c The side-chain vector derivatives
+ return
+ end
+
+
--- /dev/null
+ subroutine intcartderiv
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.SETUP'
+ include 'COMMON.CHAIN'
+ include 'COMMON.VAR'
+ include 'COMMON.GEO'
+ include 'COMMON.INTERACT'
+ include 'COMMON.DERIV'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.LOCAL'
+ include 'COMMON.SCCOR'
+ double precision dcostheta(3,2,maxres),
+ & dcosphi(3,3,maxres),dsinphi(3,3,maxres),
+ & dcosalpha(3,3,maxres),dcosomega(3,3,maxres),
+ & dsinomega(3,3,maxres),vo1(3),vo2(3),vo3(3),
+ & dummy(3),vp1(3),vp2(3),vp3(3),vpp1(3),n(3)
+
+#if defined(MPI) && defined(PARINTDER)
+ if (nfgtasks.gt.1 .and. me.eq.king)
+ & call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
+#endif
+ pi4 = 0.5d0*pipol
+ pi34 = 3*pi4
+
+c write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
+c Derivatives of theta's
+#if defined(MPI) && defined(PARINTDER)
+c We need dtheta(:,:,i-1) to compute dphi(:,:,i)
+ do i=max0(ithet_start-1,3),ithet_end
+#else
+ do i=3,nres
+#endif
+ cost=dcos(theta(i))
+ sint=sqrt(1-cost*cost)
+ do j=1,3
+ dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/
+ & vbld(i-1)
+ dtheta(j,1,i)=-1/sint*dcostheta(j,1,i)
+ dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/
+ & vbld(i)
+ dtheta(j,2,i)=-1/sint*dcostheta(j,2,i)
+ enddo
+ enddo
+
+#if defined(MPI) && defined(PARINTDER)
+c We need dtheta(:,:,i-1) to compute dphi(:,:,i)
+ do i=max0(ithet_start-1,3),ithet_end
+#else
+ do i=3,nres
+#endif
+ if ((itype(i-1).ne.10).and.(itype(i-1).ne.21)) then
+ cost1=dcos(omicron(1,i))
+ sint1=sqrt(1-cost1*cost1)
+ cost2=dcos(omicron(2,i))
+ sint2=sqrt(1-cost2*cost2)
+ do j=1,3
+CC Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
+ dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+
+ & cost1*dc_norm(j,i-2))/
+ & vbld(i-1)
+ domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i)
+ dcosomicron(j,1,2,i)=-(dc_norm(j,i-2)
+ & +cost1*(dc_norm(j,i-1+nres)))/
+ & vbld(i-1+nres)
+ domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i)
+CC Calculate derivative over second omicron Sci-1,Cai-1 Cai
+CC Looks messy but better than if in loop
+ dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres)
+ & +cost2*dc_norm(j,i-1))/
+ & vbld(i)
+ domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i)
+ dcosomicron(j,2,2,i)=-(dc_norm(j,i-1)
+ & +cost2*(-dc_norm(j,i-1+nres)))/
+ & vbld(i-1+nres)
+c write(iout,*) "vbld", i,itype(i),vbld(i-1+nres)
+ domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i)
+ enddo
+ endif
+ enddo
+
+
+
+c Derivatives of phi:
+c If phi is 0 or 180 degrees, then the formulas
+c have to be derived by power series expansion of the
+c conventional formulas around 0 and 180.
+#ifdef PARINTDER
+ do i=iphi1_start,iphi1_end
+#else
+ do i=4,nres
+#endif
+c the conventional case
+ sint=dsin(theta(i))
+ sint1=dsin(theta(i-1))
+ sing=dsin(phi(i))
+ cost=dcos(theta(i))
+ cost1=dcos(theta(i-1))
+ cosg=dcos(phi(i))
+ scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
+ fac0=1.0d0/(sint1*sint)
+ fac1=cost*fac0
+ fac2=cost1*fac0
+ fac3=cosg*cost1/(sint1*sint1)
+ fac4=cosg*cost/(sint*sint)
+c Obtaining the gamma derivatives from sine derivative
+ if (phi(i).gt.-pi4.and.phi(i).le.pi4.or.
+ & phi(i).gt.pi34.and.phi(i).le.pi.or.
+ & phi(i).gt.-pi.and.phi(i).le.-pi34) then
+ call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
+ call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
+ call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
+ do j=1,3
+ ctgt=cost/sint
+ ctgt1=cost1/sint1
+ cosg_inv=1.0d0/cosg
+ dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1)
+ & -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
+ dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
+ dsinphi(j,2,i)=
+ & -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i))
+ & -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
+ dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
+c Bug fixed 3/24/05 (AL)
+ dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i)
+ & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
+c & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
+ dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
+ enddo
+c Obtaining the gamma derivatives from cosine derivative
+ else
+ do j=1,3
+ dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3*
+ & dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp*
+ & dc_norm(j,i-3))/vbld(i-2)
+ dphi(j,1,i)=-1/sing*dcosphi(j,1,i)
+ dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2*
+ & dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4*
+ & dcostheta(j,1,i)
+ dphi(j,2,i)=-1/sing*dcosphi(j,2,i)
+ dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4*
+ & dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp*
+ & dc_norm(j,i-1))/vbld(i)
+ dphi(j,3,i)=-1/sing*dcosphi(j,3,i)
+ enddo
+ endif
+ enddo
+
+Calculate derivative of Tauangle
+#ifdef PARINTDER
+ do i=itau_start,itau_end
+#else
+ do i=3,nres
+#endif
+ if ((itype(i-2).eq.21).or.(itype(i-2).eq.10)) cycle
+cc dtauangle(j,intertyp,dervityp,residue number)
+cc INTERTYP=1 SC...Ca...Ca..Ca
+c the conventional case
+ sint=dsin(theta(i))
+ sint1=dsin(omicron(2,i-1))
+ sing=dsin(tauangle(1,i))
+ cost=dcos(theta(i))
+ cost1=dcos(omicron(2,i-1))
+ cosg=dcos(tauangle(1,i))
+ do j=1,3
+ dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
+cc write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
+ enddo
+ scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
+ fac0=1.0d0/(sint1*sint)
+ fac1=cost*fac0
+ fac2=cost1*fac0
+ fac3=cosg*cost1/(sint1*sint1)
+ fac4=cosg*cost/(sint*sint)
+cc write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
+c Obtaining the gamma derivatives from sine derivative
+ if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or.
+ & tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or.
+ & tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
+ call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
+ call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
+ call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
+ do j=1,3
+ ctgt=cost/sint
+ ctgt1=cost1/sint1
+ cosg_inv=1.0d0/cosg
+ dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1)
+ &-(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres)))
+ & *vbld_inv(i-2+nres)
+ dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
+ dsintau(j,1,2,i)=
+ & -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i))
+ & -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
+c write(iout,*) "dsintau", dsintau(j,1,2,i)
+ dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
+c Bug fixed 3/24/05 (AL)
+ dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i)
+ & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
+c & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
+ dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
+ enddo
+c Obtaining the gamma derivatives from cosine derivative
+ else
+ do j=1,3
+ dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3*
+ & dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp*
+ & (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
+ dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
+ dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2*
+ & dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4*
+ & dcostheta(j,1,i)
+ dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
+ dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4*
+ & dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp*
+ & dc_norm(j,i-1))/vbld(i)
+ dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
+c write (iout,*) "else",i
+ enddo
+ endif
+c do k=1,3
+c write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
+c enddo
+ enddo
+CC Second case Ca...Ca...Ca...SC
+#ifdef PARINTDER
+ do i=itau_start,itau_end
+#else
+ do i=4,nres
+#endif
+ if ((itype(i-1).eq.21).or.(itype(i-1).eq.10)) cycle
+c the conventional case
+ sint=dsin(omicron(1,i))
+ sint1=dsin(theta(i-1))
+ sing=dsin(tauangle(2,i))
+ cost=dcos(omicron(1,i))
+ cost1=dcos(theta(i-1))
+ cosg=dcos(tauangle(2,i))
+c do j=1,3
+c dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
+c enddo
+ scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
+ fac0=1.0d0/(sint1*sint)
+ fac1=cost*fac0
+ fac2=cost1*fac0
+ fac3=cosg*cost1/(sint1*sint1)
+ fac4=cosg*cost/(sint*sint)
+c Obtaining the gamma derivatives from sine derivative
+ if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or.
+ & tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or.
+ & tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
+ call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
+ call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
+ call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
+ do j=1,3
+ ctgt=cost/sint
+ ctgt1=cost1/sint1
+ cosg_inv=1.0d0/cosg
+ dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1)
+ & +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
+c write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
+c &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
+ dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
+ dsintau(j,2,2,i)=
+ & -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i))
+ & -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
+c write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
+c & sing*ctgt*domicron(j,1,2,i),
+c & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
+ dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
+c Bug fixed 3/24/05 (AL)
+ dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i)
+ & +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
+c & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
+ dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
+ enddo
+c Obtaining the gamma derivatives from cosine derivative
+ else
+ do j=1,3
+ dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3*
+ & dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp*
+ & dc_norm(j,i-3))/vbld(i-2)
+ dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
+ dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2*
+ & dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4*
+ & dcosomicron(j,1,1,i)
+ dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
+ dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4*
+ & dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp*
+ & dc_norm(j,i-1+nres))/vbld(i-1+nres)
+ dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
+c write(iout,*) i,j,"else", dtauangle(j,2,3,i)
+ enddo
+ endif
+ enddo
+
+
+CCC third case SC...Ca...Ca...SC
+#ifdef PARINTDER
+
+ do i=itau_start,itau_end
+#else
+ do i=3,nres
+#endif
+c the conventional case
+ if ((itype(i-1).eq.21).or.(itype(i-1).eq.10).or.
+ &(itype(i-2).eq.21).or.(itype(i-2).eq.10)) cycle
+ sint=dsin(omicron(1,i))
+ sint1=dsin(omicron(2,i-1))
+ sing=dsin(tauangle(3,i))
+ cost=dcos(omicron(1,i))
+ cost1=dcos(omicron(2,i-1))
+ cosg=dcos(tauangle(3,i))
+ do j=1,3
+ dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
+c dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
+ enddo
+ scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
+ fac0=1.0d0/(sint1*sint)
+ fac1=cost*fac0
+ fac2=cost1*fac0
+ fac3=cosg*cost1/(sint1*sint1)
+ fac4=cosg*cost/(sint*sint)
+c Obtaining the gamma derivatives from sine derivative
+ if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or.
+ & tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or.
+ & tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
+ call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
+ call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
+ call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
+ do j=1,3
+ ctgt=cost/sint
+ ctgt1=cost1/sint1
+ cosg_inv=1.0d0/cosg
+ dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1)
+ & -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres))
+ & *vbld_inv(i-2+nres)
+ dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
+ dsintau(j,3,2,i)=
+ & -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i))
+ & -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
+ dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
+c Bug fixed 3/24/05 (AL)
+ dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i)
+ & +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))
+ & *vbld_inv(i-1+nres)
+c & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
+ dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
+ enddo
+c Obtaining the gamma derivatives from cosine derivative
+ else
+ do j=1,3
+ dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3*
+ & dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp*
+ & dc_norm2(j,i-2+nres))/vbld(i-2+nres)
+ dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
+ dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2*
+ & dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4*
+ & dcosomicron(j,1,1,i)
+ dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
+ dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4*
+ & dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp*
+ & dc_norm(j,i-1+nres))/vbld(i-1+nres)
+ dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
+c write(iout,*) "else",i
+ enddo
+ endif
+ enddo
+#ifdef CRYST_SC
+c Derivatives of side-chain angles alpha and omega
+#if defined(MPI) && defined(PARINTDER)
+ do i=ibond_start,ibond_end
+#else
+ do i=2,nres-1
+#endif
+ if(itype(i).ne.10) then
+ fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
+ fac6=fac5/vbld(i)
+ fac7=fac5*fac5
+ fac8=fac5/vbld(i+1)
+ fac9=fac5/vbld(i+nres)
+ scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
+ scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
+ cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))*(
+ & scalar(dC_norm(1,i),dC_norm(1,i+nres))
+ & -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
+ sina=sqrt(1-cosa*cosa)
+ sino=dsin(omeg(i))
+ do j=1,3
+ dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)-
+ & dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
+ dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
+ dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)-
+ & scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
+ dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
+ dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)-
+ & dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/
+ & vbld(i+nres))
+ dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
+ enddo
+c obtaining the derivatives of omega from sines
+ if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or.
+ & omeg(i).gt.pi34.and.omeg(i).le.pi.or.
+ & omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
+ fac15=dcos(theta(i+1))/(dsin(theta(i+1))*
+ & dsin(theta(i+1)))
+ fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
+ fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
+ call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
+ call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
+ call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
+ coso_inv=1.0d0/dcos(omeg(i))
+ do j=1,3
+ dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1)
+ & +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)-(
+ & sino*dc_norm(j,i-1))/vbld(i)
+ domega(j,1,i)=coso_inv*dsinomega(j,1,i)
+ dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1)
+ & +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j)
+ & -sino*dc_norm(j,i)/vbld(i+1)
+ domega(j,2,i)=coso_inv*dsinomega(j,2,i)
+ dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)-
+ & fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/
+ & vbld(i+nres)
+ domega(j,3,i)=coso_inv*dsinomega(j,3,i)
+ enddo
+ else
+c obtaining the derivatives of omega from cosines
+ fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
+ fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
+ fac12=fac10*sina
+ fac13=fac12*fac12
+ fac14=sina*sina
+ do j=1,3
+ dcosomega(j,1,i)=(-(0.25d0*cosa/fac11*
+ & dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+
+ & (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina*
+ & fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
+ domega(j,1,i)=-1/sino*dcosomega(j,1,i)
+ dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2*
+ & dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11*
+ & dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+
+ & (scala2-fac11*cosa)*(0.25d0*sina/fac10*
+ & dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)
+ & ))/fac13
+ domega(j,2,i)=-1/sino*dcosomega(j,2,i)
+ dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)-
+ & scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+
+ & (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
+ domega(j,3,i)=-1/sino*dcosomega(j,3,i)
+ enddo
+ endif
+ endif
+ enddo
+#endif
+#if defined(MPI) && defined(PARINTDER)
+ if (nfgtasks.gt.1) then
+#ifdef DEBUG
+ write (iout,*) "Gather dtheta"
+cd call flush(iout)
+c write (iout,*) "dtheta before gather"
+c do i=1,nres
+c write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
+c enddo
+#endif
+ call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),
+ & MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,
+ & king,FG_COMM,IERROR)
+#ifdef DEBUG
+cd write (iout,*) "Gather dphi"
+cd call flush(iout)
+ write (iout,*) "dphi before gather"
+ do i=1,nres
+ write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
+ enddo
+#endif
+ call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),
+ & MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,
+ & king,FG_COMM,IERROR)
+cd write (iout,*) "Gather dalpha"
+cd call flush(iout)
+#ifdef CRYST_SC
+ call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),
+ & MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,
+ & king,FG_COMM,IERROR)
+cd write (iout,*) "Gather domega"
+cd call flush(iout)
+ call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),
+ & MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,
+ & king,FG_COMM,IERROR)
+#endif
+ endif
+#endif
+#ifdef DEBUG
+ write (iout,*) "dtheta after gather"
+ do i=1,nres
+ write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),j=1,2)
+ enddo
+ write (iout,*) "dphi after gather"
+ do i=1,nres
+ write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
+ enddo
+#endif
+ return
+ end
+
+ subroutine checkintcartgrad
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.CHAIN'
+ include 'COMMON.VAR'
+ include 'COMMON.GEO'
+ include 'COMMON.INTERACT'
+ include 'COMMON.DERIV'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.SETUP'
+ double precision dthetanum(3,2,maxres),dphinum(3,3,maxres)
+ & ,dalphanum(3,3,maxres), domeganum(3,3,maxres)
+ double precision theta_s(maxres),phi_s(maxres),alph_s(maxres),
+ & omeg_s(maxres),dc_norm_s(3)
+ double precision aincr /1.0d-5/
+
+ do i=1,nres
+ phi_s(i)=phi(i)
+ theta_s(i)=theta(i)
+ alph_s(i)=alph(i)
+ omeg_s(i)=omeg(i)
+ enddo
+c Check theta gradient
+ write (iout,*)
+ & "Analytical (upper) and numerical (lower) gradient of theta"
+ write (iout,*)
+ do i=3,nres
+ do j=1,3
+ dcji=dc(j,i-2)
+ dc(j,i-2)=dcji+aincr
+ call chainbuild_cart
+ call int_from_cart1(.false.)
+ dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
+ dc(j,i-2)=dcji
+ dcji=dc(j,i-1)
+ dc(j,i-1)=dc(j,i-1)+aincr
+ call chainbuild_cart
+ dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
+ dc(j,i-1)=dcji
+ enddo
+ write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),
+ & (dtheta(j,2,i),j=1,3)
+ write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),
+ & (dthetanum(j,2,i),j=1,3)
+ write (iout,'(5x,3f10.5,5x,3f10.5)')
+ & (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),
+ & (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
+ write (iout,*)
+ enddo
+c Check gamma gradient
+ write (iout,*)
+ & "Analytical (upper) and numerical (lower) gradient of gamma"
+ do i=4,nres
+ do j=1,3
+ dcji=dc(j,i-3)
+ dc(j,i-3)=dcji+aincr
+ call chainbuild_cart
+ dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
+ dc(j,i-3)=dcji
+ dcji=dc(j,i-2)
+ dc(j,i-2)=dcji+aincr
+ call chainbuild_cart
+ dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
+ dc(j,i-2)=dcji
+ dcji=dc(j,i-1)
+ dc(j,i-1)=dc(j,i-1)+aincr
+ call chainbuild_cart
+ dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
+ dc(j,i-1)=dcji
+ enddo
+ write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),
+ & (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
+ write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),
+ & (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
+ write (iout,'(5x,3(3f10.5,5x))')
+ & (dphinum(j,1,i)/dphi(j,1,i),j=1,3),
+ & (dphinum(j,2,i)/dphi(j,2,i),j=1,3),
+ & (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
+ write (iout,*)
+ enddo
+c Check alpha gradient
+ write (iout,*)
+ & "Analytical (upper) and numerical (lower) gradient of alpha"
+ do i=2,nres-1
+ if(itype(i).ne.10) then
+ do j=1,3
+ dcji=dc(j,i-1)
+ dc(j,i-1)=dcji+aincr
+ call chainbuild_cart
+ dalphanum(j,1,i)=(alph(i)-alph_s(i))
+ & /aincr
+ dc(j,i-1)=dcji
+ dcji=dc(j,i)
+ dc(j,i)=dcji+aincr
+ call chainbuild_cart
+ dalphanum(j,2,i)=(alph(i)-alph_s(i))
+ & /aincr
+ dc(j,i)=dcji
+ dcji=dc(j,i+nres)
+ dc(j,i+nres)=dc(j,i+nres)+aincr
+ call chainbuild_cart
+ dalphanum(j,3,i)=(alph(i)-alph_s(i))
+ & /aincr
+ dc(j,i+nres)=dcji
+ enddo
+ endif
+ write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),
+ & (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
+ write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),
+ & (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
+ write (iout,'(5x,3(3f10.5,5x))')
+ & (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),
+ & (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),
+ & (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
+ write (iout,*)
+ enddo
+c Check omega gradient
+ write (iout,*)
+ & "Analytical (upper) and numerical (lower) gradient of omega"
+ do i=2,nres-1
+ if(itype(i).ne.10) then
+ do j=1,3
+ dcji=dc(j,i-1)
+ dc(j,i-1)=dcji+aincr
+ call chainbuild_cart
+ domeganum(j,1,i)=(omeg(i)-omeg_s(i))
+ & /aincr
+ dc(j,i-1)=dcji
+ dcji=dc(j,i)
+ dc(j,i)=dcji+aincr
+ call chainbuild_cart
+ domeganum(j,2,i)=(omeg(i)-omeg_s(i))
+ & /aincr
+ dc(j,i)=dcji
+ dcji=dc(j,i+nres)
+ dc(j,i+nres)=dc(j,i+nres)+aincr
+ call chainbuild_cart
+ domeganum(j,3,i)=(omeg(i)-omeg_s(i))
+ & /aincr
+ dc(j,i+nres)=dcji
+ enddo
+ endif
+ write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),
+ & (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
+ write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),
+ & (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
+ write (iout,'(5x,3(3f10.5,5x))')
+ & (domeganum(j,1,i)/domega(j,1,i),j=1,3),
+ & (domeganum(j,2,i)/domega(j,2,i),j=1,3),
+ & (domeganum(j,3,i)/domega(j,3,i),j=1,3)
+ write (iout,*)
+ enddo
+ return
+ end
+
+ subroutine chainbuild_cart
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.SETUP'
+ include 'COMMON.CHAIN'
+ include 'COMMON.LOCAL'
+ include 'COMMON.TIME1'
+ include 'COMMON.IOUNITS'
+
+#ifdef MPI
+ if (nfgtasks.gt.1) then
+c write (iout,*) "BCAST in chainbuild_cart"
+c call flush(iout)
+c Broadcast the order to build the chain and compute internal coordinates
+c to the slaves. The slaves receive the order in ERGASTULUM.
+ time00=MPI_Wtime()
+c write (iout,*) "CHAINBUILD_CART: DC before BCAST"
+c do i=0,nres
+c write (iout,'(i3,3f10.5,5x,3f10.5)') i,(dc(j,i),j=1,3),
+c & (dc(j,i+nres),j=1,3)
+c enddo
+ if (fg_rank.eq.0)
+ & call MPI_Bcast(7,1,MPI_INTEGER,king,FG_COMM,IERROR)
+ time_bcast7=time_bcast7+MPI_Wtime()-time00
+ time01=MPI_Wtime()
+ call MPI_Bcast(dc(1,0),6*(nres+1),MPI_DOUBLE_PRECISION,
+ & king,FG_COMM,IERR)
+c write (iout,*) "CHAINBUILD_CART: DC after BCAST"
+c do i=0,nres
+c write (iout,'(i3,3f10.5,5x,3f10.5)') i,(dc(j,i),j=1,3),
+c & (dc(j,i+nres),j=1,3)
+c enddo
+c write (iout,*) "End BCAST in chainbuild_cart"
+c call flush(iout)
+ time_bcast=time_bcast+MPI_Wtime()-time00
+ time_bcastc=time_bcastc+MPI_Wtime()-time01
+ endif
+#endif
+ do j=1,3
+ c(j,1)=dc(j,0)
+ enddo
+ do i=2,nres
+ do j=1,3
+ c(j,i)=c(j,i-1)+dc(j,i-1)
+ enddo
+ enddo
+ do i=1,nres
+ do j=1,3
+ c(j,i+nres)=c(j,i)+dc(j,i+nres)
+ enddo
+ enddo
+c write (iout,*) "CHAINBUILD_CART"
+c call cartprint
+ call int_from_cart1(.false.)
+ return
+ end
--- /dev/null
+C
+C------------------------------------------------------------------------------
+C
+ double precision function alpha(i1,i2,i3)
+c
+c Calculates the planar angle between atoms (i1), (i2), and (i3).
+c
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.CHAIN'
+ x12=c(1,i1)-c(1,i2)
+ x23=c(1,i3)-c(1,i2)
+ y12=c(2,i1)-c(2,i2)
+ y23=c(2,i3)-c(2,i2)
+ z12=c(3,i1)-c(3,i2)
+ z23=c(3,i3)-c(3,i2)
+ vnorm=dsqrt(x12*x12+y12*y12+z12*z12)
+ wnorm=dsqrt(x23*x23+y23*y23+z23*z23)
+ scalar=(x12*x23+y12*y23+z12*z23)/(vnorm*wnorm)
+ alpha=arcos(scalar)
+ return
+ end
+C
+C------------------------------------------------------------------------------
+C
+ double precision function beta(i1,i2,i3,i4)
+c
+c Calculates the dihedral angle between atoms (i1), (i2), (i3) and (i4)
+c
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.CHAIN'
+ x12=c(1,i1)-c(1,i2)
+ x23=c(1,i3)-c(1,i2)
+ x34=c(1,i4)-c(1,i3)
+ y12=c(2,i1)-c(2,i2)
+ y23=c(2,i3)-c(2,i2)
+ y34=c(2,i4)-c(2,i3)
+ z12=c(3,i1)-c(3,i2)
+ z23=c(3,i3)-c(3,i2)
+ z34=c(3,i4)-c(3,i3)
+cd print '(2i3,3f10.5)',i1,i2,x12,y12,z12
+cd print '(2i3,3f10.5)',i2,i3,x23,y23,z23
+cd print '(2i3,3f10.5)',i3,i4,x34,y34,z34
+ wx=-y23*z34+y34*z23
+ wy=x23*z34-z23*x34
+ wz=-x23*y34+y23*x34
+ wnorm=dsqrt(wx*wx+wy*wy+wz*wz)
+ vx=y12*z23-z12*y23
+ vy=-x12*z23+z12*x23
+ vz=x12*y23-y12*x23
+ vnorm=dsqrt(vx*vx+vy*vy+vz*vz)
+ if (vnorm.gt.1.0D-13 .and. wnorm.gt.1.0D-13) then
+ scalar=(vx*wx+vy*wy+vz*wz)/(vnorm*wnorm)
+ if (dabs(scalar).gt.1.0D0)
+ &scalar=0.99999999999999D0*scalar/dabs(scalar)
+ angle=dacos(scalar)
+cd print '(2i4,10f7.3)',i2,i3,vx,vy,vz,wx,wy,wz,vnorm,wnorm,
+cd &scalar,angle
+ else
+ angle=pi
+ endif
+c if (angle.le.0.0D0) angle=pi+angle
+ tx=vy*wz-vz*wy
+ ty=-vx*wz+vz*wx
+ tz=vx*wy-vy*wx
+ scalar=tx*x23+ty*y23+tz*z23
+ if (scalar.lt.0.0D0) angle=-angle
+ beta=angle
+ return
+ end
+C
+C------------------------------------------------------------------------------
+C
+ function dist(i1,i2)
+c
+c Calculates the distance between atoms (i1) and (i2).
+c
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.CHAIN'
+ x12=c(1,i1)-c(1,i2)
+ y12=c(2,i1)-c(2,i2)
+ z12=c(3,i1)-c(3,i2)
+ dist=dsqrt(x12*x12+y12*y12+z12*z12)
+ return
+ end
+C
--- /dev/null
+ subroutine integral(gamma1,gamma2,gamma3,gamma4,ity1,ity2,a1,a2,
+ & si1,si2,si3,si4,transp,q)
+ implicit none
+ integer ity1,ity2
+ integer ilam1,ilam2,ilam3,ilam4,iincr
+ double precision gamma1,gamma2,gamma3,gamma4,beta,b(2,90),lambda1,
+ & lambda2,lambda3,lambda4
+ logical transp
+ double precision elocal,ele
+ double precision delta,delta2,sum,ene,sumene,boltz
+ double precision q,a1(2,2),a2(2,2),si1,si2,si3,si4
+ double precision conv /.01745329252d0/,pi /3.141592654d0/
+
+ iincr=20
+ delta=iincr*conv
+ delta2=0.5d0*delta
+cd print *,'iincr',iincr,' delta',delta
+cd write(2,*) gamma1,gamma2,ity1,ity2,a1,a2,si1,si2,si3,si4,transp
+
+cd do ilam1=-180,180,5
+cd do ilam2=-180,180,5
+cd lambda1=ilam1*conv+delta2
+cd lambda2=ilam2*conv+delta2
+cd write(2,'(2i5,2f10.5)') ilam1,ilam2,elocal(2,lambda1,lambda2),
+cd & ele(lambda1,lambda2,a1,1.0d0,1.d00)
+cd enddo
+cd enddo
+cd stop
+
+ sum=0.0d0
+ sumene=0.0d0
+ do ilam1=-180,179,iincr
+ do ilam2=-180,179,iincr
+ do ilam3=-180,179,iincr
+ do ilam4=-180,179,iincr
+ lambda1=ilam1*conv+delta2
+ lambda2=ilam2*conv+delta2
+ lambda3=ilam3*conv+delta2
+ lambda4=ilam4*conv+delta2
+cd write (2,*) ilam1,ilam2,ilam3,ilam4
+cd write (2,*) lambda1,lambda2,lambda3,lambda4
+ ene=
+ & -elocal(ity1,lambda1,lambda2,.false.)*
+ & elocal(ity2,lambda3,lambda4,transp)*
+ & ele(si1*lambda1+gamma1,si3*lambda3+gamma3,a1)*
+ & ele(si2*lambda2+gamma2,si4*lambda4+gamma4,a2)
+cd write (2,*) elocal(ity1,lambda1,gamma1-pi-lambda2),
+cd & elocal(ity2,lambda3,gamma2-pi-lambda4),
+cd & ele(lambda1,lambda2,a1,si1,si3),
+cd & ele(lambda3,lambda4,a2,si2,si4)
+ sum=sum+ene
+ enddo
+ enddo
+ enddo
+ enddo
+ q=sum/(2*pi)**4*delta**4
+ write (2,* )'sum',sum,' q',q
+ return
+ end
+c---------------------------------------------------------------------------
+ subroutine integral3(gamma1,gamma2,ity1,ity2,ity3,ity4,
+ & a1,koniec,q1,q2,q3,q4)
+ implicit none
+ integer ity1,ity2,ity3,ity4
+ integer ilam1,ilam2,ilam3,ilam4,iincr
+ double precision gamma1,gamma2,gamma3,gamma4,beta,lambda1,
+ & lambda2,lambda3,lambda4
+ logical koniec
+ double precision elocal,ele
+ double precision delta,delta2,sum1,sum2,sum3,sum4,
+ & ene1,ene2,ene3,ene4,boltz
+ double precision q1,q2,q3,q4,a1(2,2),a2(2,2)
+ double precision conv /.01745329252d0/,pi /3.141592654d0/
+
+ iincr=60
+ delta=iincr*conv
+ delta2=0.5d0*delta
+cd print *,'iincr',iincr,' delta',delta
+ write(2,*) gamma1,gamma2,ity1,ity2,ity3,ity4,a1,koniec
+
+cd do ilam1=-180,180,5
+cd do ilam2=-180,180,5
+cd lambda1=ilam1*conv+delta2
+cd lambda2=ilam2*conv+delta2
+cd write(2,'(2i5,2f10.5)') ilam1,ilam2,elocal(2,lambda1,lambda2),
+cd & ele(lambda1,lambda2,a1,1.0d0,1.d00)
+cd enddo
+cd enddo
+cd stop
+
+ sum1=0.0d0
+ sum2=0.0d0
+ sum3=0.0d0
+ sum4=0.0d0
+ do ilam1=-180,179,iincr
+ do ilam2=-180,179,iincr
+ do ilam3=-180,179,iincr
+ do ilam4=-180,179,iincr
+ lambda1=ilam1*conv+delta2
+ lambda2=ilam2*conv+delta2
+ lambda3=ilam3*conv+delta2
+ lambda4=ilam4*conv+delta2
+cd write (2,*) ilam1,ilam2,ilam3,ilam4
+cd write (2,*) lambda1,lambda2,lambda3,lambda4
+ if (.not.koniec) then
+ ene1=
+ & elocal(ity1,lambda1,gamma1-pi-lambda2,.false.)*
+ & elocal(ity3,lambda3,gamma2-pi-lambda4,.false.)*
+ & ele(lambda2,lambda4,a1)
+ else
+ ene1=
+ & elocal(ity1,lambda1,gamma1-pi-lambda2,.false.)*
+ & elocal(ity3,lambda3,lambda4,.false.)*
+ & ele(lambda2,-lambda4,a1)
+ endif
+ ene2=
+ & elocal(ity1,lambda1,gamma1-pi-lambda2,.false.)*
+ & elocal(ity4,lambda3,lambda4,.false.)*
+ & ele(lambda2,lambda3,a1)
+ if (.not.koniec) then
+ ene3=
+ & elocal(ity2,lambda1,lambda2,.false.)*
+ & elocal(ity3,lambda3,gamma2-pi-lambda4,.false.)*
+ & ele(lambda1,lambda4,a1)
+ else
+ ene3=
+ & elocal(ity2,lambda1,lambda2,.false.)*
+ & elocal(ity3,lambda3,lambda4,.false.)*
+ & ele(lambda1,-lambda4,a1)
+ endif
+ ene4=
+ & elocal(ity2,lambda1,lambda2,.false.)*
+ & elocal(ity4,lambda3,lambda4,.false.)*
+ & ele(lambda1,lambda3,a1)
+ sum1=sum1+ene1
+ sum2=sum2+ene2
+ sum3=sum3+ene3
+ sum4=sum4+ene4
+ enddo
+ enddo
+ enddo
+ enddo
+ q1=sum1/(2*pi)**4*delta**4
+ q2=sum2/(2*pi)**4*delta**4
+ q3=sum3/(2*pi)**4*delta**4
+ q4=sum4/(2*pi)**4*delta**4
+ write (2,* )'sum',sum1,sum2,sum3,sum4,' q',q1,q2,q3,q4
+ return
+ end
+c-------------------------------------------------------------------------
+ subroutine integral5(gamma1,gamma2,gamma3,gamma4,ity1,ity2,ity3,
+ & ity4,ity5,ity6,a1,a2,si1,si2,si3,si4,transp,ene1,ene2,ene3,ene4)
+ implicit none
+ integer ity1,ity2,ity3,ity4,ity5,ity6
+ integer ilam1,ilam2,ilam3,ilam4,ilam5,iincr
+ double precision gamma1,gamma2,gamma3,gamma4,beta,b(2,90),lambda1,
+ & lambda2,lambda3,lambda4,lambda5
+ logical transp
+ double precision elocal,ele
+ double precision eloc1,eloc2,eloc3,eloc4,eloc5,eloc6,ele1,ele2
+ double precision delta,delta2,sum,ene,sumene,pom
+ double precision ene1,ene2,ene3,ene4,sum1,sum2,sum3,sum4,
+ & a1(2,2),a2(2,2)
+ integer si1,si2,si3,si4
+ double precision conv /.01745329252d0/,pi /3.141592654d0/
+
+ iincr=60
+ delta=iincr*conv
+ delta2=0.5d0*delta
+cd print *,'iincr',iincr,' delta',delta
+cd write(2,*) 'gamma1=',gamma1,' gamma2=',gamma2,
+cd & ' gamma3=',gamma3,' gamma4=',gamma4
+cd write(2,*) ity1,ity2,ity3,ity4,ity5,ity6
+cd write(2,*) 'a1=',a1
+cd write(2,*) 'a2=',a2
+cd write(2,*) si1,si2,si3,si4,transp
+
+ sum1=0.0d0
+ sum2=0.0d0
+ sum3=0.0d0
+ sum4=0.0d0
+ do ilam1=-180,179,iincr
+ do ilam2=-180,179,iincr
+ do ilam3=-180,179,iincr
+ do ilam4=-180,179,iincr
+ do ilam5=-180,179,iincr
+ lambda1=ilam1*conv+delta2
+ lambda2=ilam2*conv+delta2
+ lambda3=ilam3*conv+delta2
+ lambda4=ilam4*conv+delta2
+ lambda5=ilam5*conv+delta2
+ if (transp) then
+ ele1=ele(lambda1,si4*lambda4,a1)
+ ele2=ele(lambda2,lambda3,a2)
+ else
+ ele1=ele(lambda1,lambda3,a1)
+ ele2=ele(lambda2,si4*lambda4,a2)
+ endif
+ eloc2=elocal(ity2,lambda1,gamma2-pi-lambda2,.false.)
+ eloc5=elocal(ity5,lambda3,gamma4-pi-si4*lambda4,.false.)
+ pom=ele1*ele2*eloc2*eloc5
+ if (si1.gt.0) then
+ eloc1=elocal(ity1,lambda5,gamma1-pi-lambda1,.false.)
+ sum1=sum1+pom*eloc1
+ endif
+ eloc3=elocal(ity3,lambda2,lambda5,.false.)
+ sum2=sum2+pom*eloc3
+ eloc4=elocal(ity4,lambda5,gamma3-pi-lambda3,.false.)
+ sum3=sum3+pom*eloc4
+ if (si4.gt.0) then
+ eloc6=elocal(ity6,lambda4,lambda5,.false.)
+ sum4=sum4+pom*eloc6
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ pom=1.0d0/(2*pi)**5*delta**5
+ ene1=sum1*pom
+ ene2=sum2*pom
+ ene3=sum3*pom
+ ene4=sum4*pom
+c write (2,* )'sum',sum1,sum2,sum3,sum4,' q',ene1,ene2,ene3,ene4
+ return
+ end
+c-------------------------------------------------------------------------
+ subroutine integral_turn6(gamma1,gamma2,gamma3,gamma4,ity1,ity2,
+ & ity3,ity4,ity5,ity6,a1,a2,ene_turn6)
+ implicit none
+ integer ity1,ity2,ity3,ity4,ity5,ity6
+ integer ilam1,ilam2,ilam3,ilam4,ilam5,ilam6,iincr
+ double precision gamma1,gamma2,gamma3,gamma4,beta,b(2,90),lambda1,
+ & lambda2,lambda3,lambda4,lambda5,lambda6
+ logical transp
+ double precision elocal,ele
+ double precision eloc1,eloc2,eloc3,eloc4,eloc41,eloc5,eloc6,
+ & eloc61,ele1,ele2
+ double precision delta,delta2,sum,ene,sumene,pom,ene5
+ double precision ene_turn6,sum5,a1(2,2),a2(2,2)
+ double precision conv /.01745329252d0/,pi /3.141592654d0/
+
+ iincr=60
+ delta=iincr*conv
+ delta2=0.5d0*delta
+cd print *,'iincr',iincr,' delta',delta
+ write(2,*) 'gamma1=',gamma1,' gamma2=',gamma2,
+ & ' gamma3=',gamma3,' gamma4=',gamma4
+ write(2,*) ity1,ity2,ity3,ity4,ity5,ity6
+ write(2,*) 'a1=',a1
+ write(2,*) 'a2=',a2
+
+ sum5=0.0d0
+ do ilam1=-180,179,iincr
+ do ilam2=-180,179,iincr
+ do ilam3=-180,179,iincr
+ do ilam4=-180,179,iincr
+ do ilam5=-180,179,iincr
+ lambda1=ilam1*conv+delta2
+ lambda2=ilam2*conv+delta2
+ lambda3=ilam3*conv+delta2
+ lambda4=ilam4*conv+delta2
+ lambda5=ilam5*conv+delta2
+ ele1=ele(lambda1,-lambda4,a1)
+ ele2=ele(lambda2,lambda3,a2)
+ eloc2=elocal(ity2,lambda1,gamma2-pi-lambda2,.false.)
+ eloc5=elocal(ity5,lambda3,lambda4,.false.)
+ pom=ele1*ele2*eloc2*eloc5
+ eloc3=elocal(ity3,lambda2,gamma3-pi-lambda5,.false.)
+ eloc4=elocal(ity4,lambda5,gamma4-pi-lambda3,.false.)
+ sum5=sum5+pom*eloc3*eloc4
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ pom=-1.0d0/(2*pi)**5*delta**5
+ ene_turn6=sum5*pom
+c print *,'sum6',sum6,' ene6',ene6
+ return
+ end
+c-------------------------------------------------------------------------
+ subroutine integral6(gamma1,gamma2,gamma3,gamma4,ity1,ity2,ity3,
+ & ity4,ity5,ity6,a1,a2,si1,si2,si3,si4,transp,ene1,ene2,ene3,ene4,
+ & ene5,ene6)
+ implicit none
+ integer ity1,ity2,ity3,ity4,ity5,ity6
+ integer ilam1,ilam2,ilam3,ilam4,ilam5,ilam6,iincr
+ double precision gamma1,gamma2,gamma3,gamma4,beta,b(2,90),lambda1,
+ & lambda2,lambda3,lambda4,lambda5,lambda6
+ logical transp
+ double precision elocal,ele
+ double precision eloc1,eloc2,eloc3,eloc4,eloc41,eloc5,eloc6,
+ & eloc61,ele1,ele2
+ double precision delta,delta2,sum,ene,sumene,pom
+ double precision ene1,ene2,ene3,ene4,ene5,ene6,sum1,sum2,sum3,
+ & sum4,sum5,sum6,a1(2,2),a2(2,2)
+ integer si1,si2,si3,si4
+ double precision conv /.01745329252d0/,pi /3.141592654d0/
+
+ iincr=60
+ delta=iincr*conv
+ delta2=0.5d0*delta
+cd print *,'iincr',iincr,' delta',delta
+cd write(2,*) 'gamma1=',gamma1,' gamma2=',gamma2,
+cd & ' gamma3=',gamma3,' gamma4=',gamma4
+cd write(2,*) ity1,ity2,ity3,ity4,ity5,ity6
+cd write(2,*) 'a1=',a1
+cd write(2,*) 'a2=',a2
+cd write(2,*) si1,si2,si3,si4,transp
+
+ sum1=0.0d0
+ sum2=0.0d0
+ sum3=0.0d0
+ sum4=0.0d0
+ sum5=0.0d0
+ sum6=0.0d0
+ eloc1=0.0d0
+ eloc6=0.0d0
+ eloc61=0.0d0
+ do ilam1=-180,179,iincr
+ do ilam2=-180,179,iincr
+ do ilam3=-180,179,iincr
+ do ilam4=-180,179,iincr
+ do ilam5=-180,179,iincr
+ do ilam6=-180,179,iincr
+ lambda1=ilam1*conv+delta2
+ lambda2=ilam2*conv+delta2
+ lambda3=ilam3*conv+delta2
+ lambda4=ilam4*conv+delta2
+ lambda5=ilam5*conv+delta2
+ lambda6=ilam6*conv+delta2
+ if (transp) then
+ ele1=ele(lambda1,si4*lambda4,a1)
+ ele2=ele(lambda2,lambda3,a2)
+ else
+ ele1=ele(lambda1,lambda3,a1)
+ ele2=ele(lambda2,si4*lambda4,a2)
+ endif
+ eloc2=elocal(ity2,lambda1,gamma2-pi-lambda2,.false.)
+ eloc5=elocal(ity5,lambda3,gamma4-pi-si4*lambda4,.false.)
+ pom=ele1*ele2*eloc2*eloc5
+ if (si1.gt.0) then
+ eloc1=elocal(ity1,lambda5,gamma1-pi-lambda1,.false.)
+ endif
+ eloc3=elocal(ity3,lambda2,lambda6,.false.)
+ sum1=sum1+pom*eloc1*eloc3
+ eloc4=elocal(ity4,lambda5,gamma3-pi-lambda3,.false.)
+ if (si4.gt.0) then
+ eloc6=elocal(ity6,lambda4,lambda6,.false.)
+ eloc61=elocal(ity6,lambda4,lambda5,.false.)
+ endif
+ sum2=sum2+pom*eloc4*eloc6
+ eloc41=elocal(ity4,lambda6,gamma3-pi-lambda3,.false.)
+ sum3=sum3+pom*eloc1*eloc41
+ sum4=sum4+pom*eloc1*eloc6
+ sum5=sum5+pom*eloc3*eloc4
+ sum6=sum6+pom*eloc3*eloc61
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ pom=-1.0d0/(2*pi)**6*delta**6
+ ene1=sum1*pom
+ ene2=sum2*pom
+ ene3=sum3*pom
+ ene4=sum4*pom
+ ene5=sum5*pom
+ ene6=sum6*pom
+c print *,'sum6',sum6,' ene6',ene6
+ return
+ end
+c-------------------------------------------------------------------------
+ subroutine integral3a(gamma1,gamma2,ity1,ity2,a1,si1,ene1)
+ implicit none
+ integer ity1,ity2,ity3,ity4,ity5,ity6
+ integer ilam1,ilam2,ilam3,ilam4,ilam5,ilam6,iincr
+ double precision gamma1,gamma2,gamma3,gamma4,beta,b(2,90),lambda1,
+ & lambda2,lambda3,lambda4,lambda5,lambda6
+ logical transp
+ double precision elocal,ele
+ double precision eloc1,eloc2,eloc3,eloc4,eloc41,eloc5,eloc6,
+ & eloc61,ele1,ele2
+ double precision delta,delta2,sum,ene,sumene,pom
+ double precision ene1,ene2,ene3,ene4,ene5,ene6,sum1,sum2,sum3,
+ & sum4,sum5,sum6,a1(2,2),a2(2,2)
+ integer si1,si2,si3,si4
+ double precision conv /.01745329252d0/,pi /3.141592654d0/
+
+ iincr=60
+ delta=iincr*conv
+ delta2=0.5d0*delta
+cd print *,'iincr',iincr,' delta',delta
+cd write(2,*) 'gamma1=',gamma1,' gamma2=',gamma2
+cd write(2,*) ity1,ity2
+cd write(2,*) 'a1=',a1
+cd write(2,*) si1,
+
+ sum1=0.0d0
+ eloc1=0.0d0
+ do ilam1=-180,179,iincr
+ do ilam2=-180,179,iincr
+ do ilam3=-180,179,iincr
+ lambda1=ilam1*conv+delta2
+ lambda2=ilam2*conv+delta2
+ lambda3=ilam3*conv+delta2
+ ele1=ele(lambda1,si1*lambda3,a1)
+ eloc1=elocal(ity1,lambda1,gamma1-pi-lambda2,.false.)
+ if (si1.gt.0) then
+ eloc2=elocal(ity2,lambda2,gamma2-pi-lambda3,.false.)
+ else
+ eloc2=elocal(ity2,lambda2,lambda3,.false.)
+ endif
+ sum1=sum1+ele1*eloc1*eloc2
+ enddo
+ enddo
+ enddo
+ pom=1.0d0/(2*pi)**3*delta**3
+ ene1=sum1*pom
+ return
+ end
+c-------------------------------------------------------------------------
+ subroutine integral4a(gamma1,gamma2,gamma3,ity1,ity2,ity3,a1,si1,
+ & ene1)
+ implicit none
+ integer ity1,ity2,ity3,ity4,ity5,ity6
+ integer ilam1,ilam2,ilam3,ilam4,ilam5,ilam6,iincr
+ double precision gamma1,gamma2,gamma3,gamma4,beta,b(2,90),lambda1,
+ & lambda2,lambda3,lambda4,lambda5,lambda6
+ logical transp
+ double precision elocal,ele
+ double precision eloc1,eloc2,eloc3,eloc4,eloc41,eloc5,eloc6,
+ & eloc61,ele1,ele2
+ double precision delta,delta2,sum,ene,sumene,pom
+ double precision ene1,ene2,ene3,ene4,ene5,ene6,sum1,sum2,sum3,
+ & sum4,sum5,sum6,a1(2,2),a2(2,2)
+ integer si1,si2,si3,si4
+ double precision conv /.01745329252d0/,pi /3.141592654d0/
+
+ iincr=60
+ delta=iincr*conv
+ delta2=0.5d0*delta
+cd print *,'iincr',iincr,' delta',delta
+cd write(2,*) 'gamma1=',gamma1,' gamma2=',gamma2,
+cd & ' gamma3=',gamma3
+cd write(2,*) ity1,ity2,ity3
+cd write(2,*) 'a1=',a1
+cd write(2,*) 'si1=',si1
+ sum1=0.0d0
+ do ilam1=-180,179,iincr
+ do ilam2=-180,179,iincr
+ do ilam3=-180,179,iincr
+ do ilam4=-180,179,iincr
+ lambda1=ilam1*conv+delta2
+ lambda2=ilam2*conv+delta2
+ lambda3=ilam3*conv+delta2
+ lambda4=ilam4*conv+delta2
+ ele1=ele(lambda1,si1*lambda4,a1)
+ eloc1=elocal(ity1,lambda1,gamma1-pi-lambda2,.false.)
+ eloc2=elocal(ity2,lambda2,gamma2-pi-lambda3,.false.)
+ if (si1.gt.0) then
+ eloc3=elocal(ity3,lambda3,gamma3-pi-lambda4,.false.)
+ else
+ eloc3=elocal(ity3,lambda3,lambda4,.false.)
+ endif
+ sum1=sum1+ele1*eloc1*eloc2*eloc3
+ enddo
+ enddo
+ enddo
+ enddo
+ pom=-1.0d0/(2*pi)**4*delta**4
+ ene1=sum1*pom
+ return
+ end
+c-------------------------------------------------------------------------
+ double precision function elocal(i,x,y,transp)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.TORSION'
+ integer i
+ double precision x,y,u(2),v(2),cu(2),dv(2),ev(2)
+ double precision scalar2
+ logical transp
+ u(1)=dcos(x)
+ u(2)=dsin(x)
+ v(1)=dcos(y)
+ v(2)=dsin(y)
+ if (transp) then
+ call matvec2(cc(1,1,i),v,cu)
+ call matvec2(dd(1,1,i),u,dv)
+ call matvec2(ee(1,1,i),u,ev)
+ elocal=scalar2(b1(1,i),v)+scalar2(b2(1,i),u)+scalar2(cu,v)+
+ & scalar2(dv,u)+scalar2(ev,v)
+ else
+ call matvec2(cc(1,1,i),u,cu)
+ call matvec2(dd(1,1,i),v,dv)
+ call matvec2(ee(1,1,i),v,ev)
+ elocal=scalar2(b1(1,i),u)+scalar2(b2(1,i),v)+scalar2(cu,u)+
+ & scalar2(dv,v)+scalar2(ev,u)
+ endif
+ return
+ end
+c-------------------------------------------------------------------------
+ double precision function ele(x,y,a)
+ implicit none
+ double precision x,y,a(2,2),si1,si2,u(2),v(2),av(2)
+ double precision scalar2
+ u(1)=-cos(x)
+ u(2)= sin(x)
+ v(1)=-cos(y)
+ v(2)= sin(y)
+ call matvec2(a,v,av)
+ ele=scalar2(u,av)
+ return
+ end
--- /dev/null
+ subroutine kinetic(KE_total)
+c----------------------------------------------------------------
+c This subroutine calculates the total kinetic energy of the chain
+c-----------------------------------------------------------------
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.VAR'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.MD'
+ include 'COMMON.IOUNITS'
+ double precision KE_total
+
+ integer i,j,k
+ double precision KEt_p,KEt_sc,KEr_p,KEr_sc,incr(3),
+ & mag1,mag2,v(3)
+
+ KEt_p=0.0d0
+ KEt_sc=0.0d0
+c write (iout,*) "ISC",(isc(itype(i)),i=1,nres)
+c The translational part for peptide virtual bonds
+ do j=1,3
+ incr(j)=d_t(j,0)
+ enddo
+ do i=nnt,nct-1
+c write (iout,*) "Kinetic trp:",i,(incr(j),j=1,3)
+ do j=1,3
+ v(j)=incr(j)+0.5d0*d_t(j,i)
+ enddo
+ vtot(i)=v(1)*v(1)+v(2)*v(2)+v(3)*v(3)
+ KEt_p=KEt_p+(v(1)*v(1)+v(2)*v(2)+v(3)*v(3))
+ do j=1,3
+ incr(j)=incr(j)+d_t(j,i)
+ enddo
+ enddo
+c write(iout,*) 'KEt_p', KEt_p
+c The translational part for the side chain virtual bond
+c Only now we can initialize incr with zeros. It must be equal
+c to the velocities of the first Calpha.
+ do j=1,3
+ incr(j)=d_t(j,0)
+ enddo
+ do i=nnt,nct
+ iti=itype(i)
+ if (itype(i).eq.10) then
+ do j=1,3
+ v(j)=incr(j)
+ enddo
+ else
+ do j=1,3
+ v(j)=incr(j)+d_t(j,nres+i)
+ enddo
+ endif
+c write (iout,*) "Kinetic trsc:",i,(incr(j),j=1,3)
+c write (iout,*) "i",i," msc",msc(iti)," v",(v(j),j=1,3)
+ KEt_sc=KEt_sc+msc(iti)*(v(1)*v(1)+v(2)*v(2)+v(3)*v(3))
+ vtot(i+nres)=v(1)*v(1)+v(2)*v(2)+v(3)*v(3)
+ do j=1,3
+ incr(j)=incr(j)+d_t(j,i)
+ enddo
+ enddo
+c goto 111
+c write(iout,*) 'KEt_sc', KEt_sc
+c The part due to stretching and rotation of the peptide groups
+ KEr_p=0.0D0
+ do i=nnt,nct-1
+c write (iout,*) "i",i
+c write (iout,*) "i",i," mag1",mag1," mag2",mag2
+ do j=1,3
+ incr(j)=d_t(j,i)
+ enddo
+c write (iout,*) "Kinetic rotp:",i,(incr(j),j=1,3)
+ KEr_p=KEr_p+(incr(1)*incr(1)+incr(2)*incr(2)
+ & +incr(3)*incr(3))
+ enddo
+c goto 111
+c write(iout,*) 'KEr_p', KEr_p
+c The rotational part of the side chain virtual bond
+ KEr_sc=0.0D0
+ do i=nnt,nct
+ iti=itype(i)
+ if (itype(i).ne.10) then
+ do j=1,3
+ incr(j)=d_t(j,nres+i)
+ enddo
+c write (iout,*) "Kinetic rotsc:",i,(incr(j),j=1,3)
+ KEr_sc=KEr_sc+Isc(iti)*(incr(1)*incr(1)+incr(2)*incr(2)+
+ & incr(3)*incr(3))
+ endif
+ enddo
+c The total kinetic energy
+ 111 continue
+c write(iout,*) 'KEr_sc', KEr_sc
+ KE_total=0.5d0*(mp*KEt_p+KEt_sc+0.25d0*Ip*KEr_p+KEr_sc)
+c write (iout,*) "KE_total",KE_total
+ return
+ end
+
+
+
+
--- /dev/null
+ subroutine lagrangian
+c-------------------------------------------------------------------------
+c This subroutine contains the total lagrangain from which the accelerations
+c are obtained. For numerical gradient checking, the derivetive of the
+c lagrangian in the velocities and coordinates are calculated seperately
+c-------------------------------------------------------------------------
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.VAR'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.MD'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.MUCA'
+ include 'COMMON.TIME1'
+
+ integer i,j,ind
+ double precision zapas(MAXRES6),muca_factor
+ logical lprn /.false./
+ common /cipiszcze/ itime
+
+#ifdef TIMING
+ time00=MPI_Wtime()
+#endif
+ do j=1,3
+ zapas(j)=-gcart(j,0)
+ enddo
+ ind=3
+ if (lprn) then
+ write (iout,*) "Potential forces backbone"
+ endif
+ do i=nnt,nct-1
+ if (lprn) write (iout,'(i5,3e15.5,5x,3e15.5)')
+ & i,(-gcart(j,i),j=1,3)
+ do j=1,3
+ ind=ind+1
+ zapas(ind)=-gcart(j,i)
+ enddo
+ enddo
+ if (lprn) write (iout,*) "Potential forces sidechain"
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ if (lprn) write (iout,'(i5,3e15.5,5x,3e15.5)')
+ & i,(-gcart(j,i),j=1,3)
+ do j=1,3
+ ind=ind+1
+ zapas(ind)=-gxcart(j,i)
+ enddo
+ endif
+ enddo
+
+ call ginv_mult(zapas,d_a_work)
+
+ do j=1,3
+ d_a(j,0)=d_a_work(j)
+ enddo
+ ind=3
+ do i=nnt,nct-1
+ do j=1,3
+ ind=ind+1
+ d_a(j,i)=d_a_work(ind)
+ enddo
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ do j=1,3
+ ind=ind+1
+ d_a(j,i+nres)=d_a_work(ind)
+ enddo
+ endif
+ enddo
+
+ if(lmuca) then
+ imtime=imtime+1
+ if(mucadyn.gt.0) call muca_update(potE)
+ factor=muca_factor(potE)*t_bath*Rb
+
+cd print *,'lmuca ',factor,potE
+ do j=1,3
+ d_a(j,0)=d_a(j,0)*factor
+ enddo
+ do i=nnt,nct-1
+ do j=1,3
+ d_a(j,i)=d_a(j,i)*factor
+ enddo
+ enddo
+ do i=nnt,nct
+ do j=1,3
+ d_a(j,i+nres)=d_a(j,i+nres)*factor
+ enddo
+ enddo
+
+ endif
+
+ if (lprn) then
+ write(iout,*) 'acceleration 3D'
+ write (iout,'(i3,3f10.5,3x,3f10.5)') 0,(d_a(j,0),j=1,3)
+ do i=nnt,nct-1
+ write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3)
+ enddo
+ do i=nnt,nct
+ write (iout,'(i3,3f10.5,3x,3f10.5)')
+ & i+nres,(d_a(j,i+nres),j=1,3)
+ enddo
+ endif
+#ifdef TIMING
+ time_lagrangian=time_lagrangian+MPI_Wtime()-time00
+#endif
+ return
+ end
+c------------------------------------------------------------------
+ subroutine setup_MD_matrices
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+ integer ierror
+#endif
+ include 'COMMON.SETUP'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.MD'
+#ifndef LANG0
+ include 'COMMON.LANGEVIN'
+#else
+ include 'COMMON.LANGEVIN.lang0'
+#endif
+ include 'COMMON.IOUNITS'
+ include 'COMMON.TIME1'
+ integer i,j
+ logical lprn /.false./
+ logical osob
+ double precision dtdi,massvec(maxres2),Gcopy(maxres2,maxres2),
+ & Ghalf(mmaxres2),sqreig(maxres2), invsqreig(maxres2), Gcopytmp,
+ & Gsqrptmp, Gsqrmtmp, Gvec2tmp,Gvectmp(maxres2,maxres2)
+ double precision work(8*maxres6)
+ integer iwork(maxres6)
+ common /przechowalnia/ Gcopy,Ghalf,invsqreig,Gvectmp
+c
+c Set up the matrix of the (dC,dX)-->(C,X) transformation (A), the
+c inertia matrix (Gmat) and the inverse of the inertia matrix (Ginv)
+c
+c Determine the number of degrees of freedom (dimen) and the number of
+c sites (dimen1)
+ dimen=(nct-nnt+1)+nside
+ dimen1=(nct-nnt)+(nct-nnt+1)
+ dimen3=dimen*3
+#ifdef MPI
+ if (nfgtasks.gt.1) then
+ time00=MPI_Wtime()
+ call MPI_Bcast(5,1,MPI_INTEGER,king,FG_COMM,IERROR)
+ time_Bcast=time_Bcast+MPI_Wtime()-time00
+ call int_bounds(dimen,igmult_start,igmult_end)
+ igmult_start=igmult_start-1
+ call MPI_Allgather(3*igmult_start,1,MPI_INTEGER,
+ & ng_start(0),1,MPI_INTEGER,FG_COMM,IERROR)
+ my_ng_count=igmult_end-igmult_start
+ call MPI_Allgather(3*my_ng_count,1,MPI_INTEGER,ng_counts(0),1,
+ & MPI_INTEGER,FG_COMM,IERROR)
+ write (iout,*) 'Processor:',fg_rank,' CG group',kolor,
+ & ' absolute rank',myrank,' igmult_start',igmult_start,
+ & ' igmult_end',igmult_end,' count',my_ng_count
+ write (iout,*) "ng_start",(ng_start(i),i=0,nfgtasks-1)
+ write (iout,*) "ng_counts",(ng_counts(i),i=0,nfgtasks-1)
+ call flush(iout)
+ else
+#endif
+ igmult_start=1
+ igmult_end=dimen
+ my_ng_count=dimen
+#ifdef MPI
+ endif
+#endif
+c write (iout,*) "dimen",dimen," dimen1",dimen1," dimen3",dimen3
+c Zeroing out A and fricmat
+ do i=1,dimen
+ do j=1,dimen
+ A(i,j)=0.0D0
+ enddo
+ enddo
+c Diagonal elements of the dC part of A and the respective friction coefficients
+ ind=1
+ ind1=0
+ do i=nnt,nct-1
+ ind=ind+1
+ ind1=ind1+1
+ coeff=0.25d0*IP
+ massvec(ind1)=mp
+ Gmat(ind,ind)=coeff
+ A(ind1,ind)=0.5d0
+ enddo
+
+c Off-diagonal elements of the dC part of A
+ k=3
+ do i=1,nct-nnt
+ do j=1,i
+ A(i,j)=1.0d0
+ enddo
+ enddo
+c Diagonal elements of the dX part of A and the respective friction coefficients
+ m=nct-nnt
+ m1=nct-nnt+1
+ ind=0
+ ind1=0
+ do i=nnt,nct
+ ind=ind+1
+ ii = ind+m
+ iti=itype(i)
+ massvec(ii)=msc(iti)
+ if (iti.ne.10) then
+ ind1=ind1+1
+ ii1= ind1+m1
+ A(ii,ii1)=1.0d0
+ Gmat(ii1,ii1)=ISC(iti)
+ endif
+ enddo
+c Off-diagonal elements of the dX part of A
+ ind=0
+ k=nct-nnt
+ do i=nnt,nct
+ iti=itype(i)
+ ind=ind+1
+ do j=nnt,i
+ ii = ind
+ jj = j-nnt+1
+ A(k+ii,jj)=1.0d0
+ enddo
+ enddo
+ if (lprn) then
+ write (iout,*)
+ write (iout,*) "Vector massvec"
+ do i=1,dimen1
+ write (iout,*) i,massvec(i)
+ enddo
+ write (iout,'(//a)') "A"
+ call matout(dimen,dimen1,maxres2,maxres2,A)
+ endif
+
+c Calculate the G matrix (store in Gmat)
+ do k=1,dimen
+ do i=1,dimen
+ dtdi=0.0d0
+ do j=1,dimen1
+ dtdi=dtdi+A(j,k)*A(j,i)*massvec(j)
+ enddo
+ Gmat(k,i)=Gmat(k,i)+dtdi
+ enddo
+ enddo
+
+ if (lprn) then
+ write (iout,'(//a)') "Gmat"
+ call matout(dimen,dimen,maxres2,maxres2,Gmat)
+ endif
+ do i=1,dimen
+ do j=1,dimen
+ Ginv(i,j)=0.0d0
+ Gcopy(i,j)=Gmat(i,j)
+ enddo
+ Ginv(i,i)=1.0d0
+ enddo
+c Invert the G matrix
+ call MATINVERT(dimen,maxres2,Gcopy,Ginv,osob)
+ if (lprn) then
+ write (iout,'(//a)') "Ginv"
+ call matout(dimen,dimen,maxres2,maxres2,Ginv)
+ endif
+#ifdef MPI
+ if (nfgtasks.gt.1) then
+ myginv_ng_count=maxres2*my_ng_count
+ call MPI_Allgather(maxres2*igmult_start,1,MPI_INTEGER,
+ & nginv_start(0),1,MPI_INTEGER,FG_COMM,IERROR)
+ call MPI_Allgather(myginv_ng_count,1,MPI_INTEGER,
+ & nginv_counts(0),1,MPI_INTEGER,FG_COMM,IERROR)
+ if (lprn .and. (me.eq.king .or. .not. out1file) ) then
+ write (iout,*) "nginv_start",(nginv_start(i),i=0,nfgtasks-1)
+ write (iout,*) "nginv_counts",(nginv_counts(i),i=0,nfgtasks-1)
+ call flush(iout)
+ endif
+c call MPI_Scatterv(ginv(1,1),nginv_counts(0),
+c & nginv_start(0),MPI_DOUBLE_PRECISION,ginv,
+c & myginv_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERR)
+c call MPI_Barrier(FG_COMM,IERR)
+ time00=MPI_Wtime()
+ call MPI_Scatterv(ginv(1,1),nginv_counts(0),
+ & nginv_start(0),MPI_DOUBLE_PRECISION,gcopy(1,1),
+ & myginv_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERR)
+#ifdef TIMING
+ time_scatter_ginv=time_scatter_ginv+MPI_Wtime()-time00
+#endif
+ do i=1,dimen
+ do j=1,2*my_ng_count
+ ginv(j,i)=gcopy(i,j)
+ enddo
+ enddo
+c write (iout,*) "Master's chunk of ginv"
+c call MATOUT2(my_ng_count,dimen,maxres2,maxres2,ginv)
+ endif
+#endif
+ if (osob) then
+ write (iout,*) "The G matrix is singular."
+ stop
+ endif
+c Compute G**(-1/2) and G**(1/2)
+ ind=0
+ do i=1,dimen
+ do j=1,i
+ ind=ind+1
+ Ghalf(ind)=Gmat(i,j)
+ enddo
+ enddo
+ call gldiag(maxres2,dimen,dimen,Ghalf,work,Geigen,Gvec,
+ & ierr,iwork)
+ if (lprn) then
+ write (iout,'(//a)')
+ & "Eigenvectors and eigenvalues of the G matrix"
+ call eigout(dimen,dimen,maxres2,maxres2,Gvec,Geigen)
+ endif
+
+ do i=1,dimen
+ sqreig(i)=dsqrt(Geigen(i))
+ invsqreig(i)=1.d0/sqreig(i)
+ enddo
+ do i=1,dimen
+ do j=1,dimen
+ Gvectmp(i,j)=Gvec(j,i)
+ enddo
+ enddo
+
+ do i=1,dimen
+ do j=1,dimen
+ Gsqrptmp=0.0d0
+ Gsqrmtmp=0.0d0
+ Gcopytmp=0.0d0
+ do k=1,dimen
+c Gvec2tmp=Gvec(i,k)*Gvec(j,k)
+ Gvec2tmp=Gvec(k,i)*Gvec(k,j)
+ Gsqrptmp=Gsqrptmp+Gvec2tmp*sqreig(k)
+ Gsqrmtmp=Gsqrmtmp+Gvec2tmp*invsqreig(k)
+ Gcopytmp=Gcopytmp+Gvec2tmp*Geigen(k)
+ enddo
+ Gsqrp(i,j)=Gsqrptmp
+ Gsqrm(i,j)=Gsqrmtmp
+ Gcopy(i,j)=Gcopytmp
+ enddo
+ enddo
+
+ do i=1,dimen
+ do j=1,dimen
+ Gvec(i,j)=Gvectmp(j,i)
+ enddo
+ enddo
+
+ if (lprn) then
+ write (iout,*) "Comparison of original and restored G"
+ do i=1,dimen
+ do j=1,dimen
+ write (iout,'(2i5,5f10.5)') i,j,Gmat(i,j),Gcopy(i,j),
+ & Gmat(i,j)-Gcopy(i,j),Gsqrp(i,j),Gsqrm(i,j)
+ enddo
+ enddo
+ endif
+ return
+ end
+c-------------------------------------------------------------------------------
+ SUBROUTINE EIGOUT(NC,NR,LM2,LM3,A,B)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ double precision A(LM2,LM3),B(LM2)
+ KA=1
+ KC=6
+ 1 KB=MIN0(KC,NC)
+ WRITE(IOUT,600) (I,I=KA,KB)
+ WRITE(IOUT,601) (B(I),I=KA,KB)
+ WRITE(IOUT,602)
+ 2 N=0
+ DO 3 I=1,NR
+ WRITE(IOUT,603) I,(A(I,J),J=KA,KB)
+ N=N+1
+ IF(N.LT.10) GO TO 3
+ WRITE(IOUT,602)
+ N=0
+ 3 CONTINUE
+ 4 IF (KB.EQ.NC) RETURN
+ KA=KC+1
+ KC=KC+6
+ GO TO 1
+ 600 FORMAT (// 9H ROOT NO.,I4,9I11)
+ 601 FORMAT (/5X,10(1PE11.4))
+ 602 FORMAT (2H )
+ 603 FORMAT (I5,10F11.5)
+ 604 FORMAT (1H1)
+ END
+c-------------------------------------------------------------------------------
+ SUBROUTINE MATOUT(NC,NR,LM2,LM3,A)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ double precision A(LM2,LM3)
+ KA=1
+ KC=6
+ 1 KB=MIN0(KC,NC)
+ WRITE(IOUT,600) (I,I=KA,KB)
+ WRITE(IOUT,602)
+ 2 N=0
+ DO 3 I=1,NR
+ WRITE(IOUT,603) I,(A(I,J),J=KA,KB)
+ N=N+1
+ IF(N.LT.10) GO TO 3
+ WRITE(IOUT,602)
+ N=0
+ 3 CONTINUE
+ 4 IF (KB.EQ.NC) RETURN
+ KA=KC+1
+ KC=KC+6
+ GO TO 1
+ 600 FORMAT (//5x,9I11)
+ 602 FORMAT (2H )
+ 603 FORMAT (I5,10F11.3)
+ 604 FORMAT (1H1)
+ END
+c-------------------------------------------------------------------------------
+ SUBROUTINE MATOUT1(NC,NR,LM2,LM3,A)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ double precision A(LM2,LM3)
+ KA=1
+ KC=21
+ 1 KB=MIN0(KC,NC)
+ WRITE(IOUT,600) (I,I=KA,KB)
+ WRITE(IOUT,602)
+ 2 N=0
+ DO 3 I=1,NR
+ WRITE(IOUT,603) I,(A(I,J),J=KA,KB)
+ N=N+1
+ IF(N.LT.3) GO TO 3
+ WRITE(IOUT,602)
+ N=0
+ 3 CONTINUE
+ 4 IF (KB.EQ.NC) RETURN
+ KA=KC+1
+ KC=KC+21
+ GO TO 1
+ 600 FORMAT (//5x,7(3I5,2x))
+ 602 FORMAT (2H )
+ 603 FORMAT (I5,7(3F5.1,2x))
+ 604 FORMAT (1H1)
+ END
+c-------------------------------------------------------------------------------
+ SUBROUTINE MATOUT2(NC,NR,LM2,LM3,A)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ double precision A(LM2,LM3)
+ KA=1
+ KC=12
+ 1 KB=MIN0(KC,NC)
+ WRITE(IOUT,600) (I,I=KA,KB)
+ WRITE(IOUT,602)
+ 2 N=0
+ DO 3 I=1,NR
+ WRITE(IOUT,603) I,(A(I,J),J=KA,KB)
+ N=N+1
+ IF(N.LT.3) GO TO 3
+ WRITE(IOUT,602)
+ N=0
+ 3 CONTINUE
+ 4 IF (KB.EQ.NC) RETURN
+ KA=KC+1
+ KC=KC+12
+ GO TO 1
+ 600 FORMAT (//5x,4(3I9,2x))
+ 602 FORMAT (2H )
+ 603 FORMAT (I5,4(3F9.3,2x))
+ 604 FORMAT (1H1)
+ END
+c---------------------------------------------------------------------------
+ SUBROUTINE ginv_mult(z,d_a_tmp)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+ integer ierr
+#endif
+ include 'COMMON.SETUP'
+ include 'COMMON.TIME1'
+ include 'COMMON.MD'
+ double precision z(dimen3),d_a_tmp(dimen3),temp(maxres6),time00
+ &time01
+#ifdef MPI
+ if (nfgtasks.gt.1) then
+ if (fg_rank.eq.0) then
+c The matching BROADCAST for fg processors is called in ERGASTULUM
+ time00=MPI_Wtime()
+ call MPI_Bcast(4,1,MPI_INTEGER,king,FG_COMM,IERROR)
+ time_Bcast=time_Bcast+MPI_Wtime()-time00
+c print *,"Processor",myrank," BROADCAST iorder in GINV_MULT"
+ endif
+c write (2,*) "time00",time00
+c write (2,*) "Before Scatterv"
+c call flush(2)
+c write (2,*) "Whole z (for FG master)"
+c do i=1,dimen
+c write (2,*) i,z(i)
+c enddo
+c call MPI_Barrier(FG_COMM,IERROR)
+ time00=MPI_Wtime()
+ call MPI_Scatterv(z,ng_counts(0),ng_start(0),
+ & MPI_DOUBLE_PRECISION,
+ & z,3*my_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERR)
+c write (2,*) "My chunk of z"
+c do i=1,3*my_ng_count
+c write (2,*) i,z(i)
+c enddo
+c write (2,*) "After SCATTERV"
+c call flush(2)
+c write (2,*) "MPI_Wtime",MPI_Wtime()
+ time_scatter=time_scatter+MPI_Wtime()-time00
+#ifdef TIMING
+ time_scatter_ginvmult=time_scatter_ginvmult+MPI_Wtime()-time00
+#endif
+c write (2,*) "time_scatter",time_scatter
+c write (2,*) "dimen",dimen," dimen3",dimen3," my_ng_count",
+c & my_ng_count
+c call flush(2)
+ time01=MPI_Wtime()
+ do k=0,2
+ do i=1,dimen
+ ind=(i-1)*3+k+1
+ temp(ind)=0.0d0
+ do j=1,my_ng_count
+c write (2,*) "k,i,j,ind",k,i,j,ind,(j-1)*3+k+1,
+c & Ginv(i,j),z((j-1)*3+k+1),
+c & Ginv(i,j)*z((j-1)*3+k+1)
+c temp(ind)=temp(ind)+Ginv(i,j)*z((j-1)*3+k+1)
+ temp(ind)=temp(ind)+Ginv(j,i)*z((j-1)*3+k+1)
+ enddo
+ enddo
+ enddo
+ time_ginvmult=time_ginvmult+MPI_Wtime()-time01
+c write (2,*) "Before REDUCE"
+c call flush(2)
+c write (2,*) "z before reduce"
+c do i=1,dimen
+c write (2,*) i,temp(i)
+c enddo
+ time00=MPI_Wtime()
+ call MPI_Reduce(temp(1),d_a_tmp(1),dimen3,MPI_DOUBLE_PRECISION,
+ & MPI_SUM,king,FG_COMM,IERR)
+ time_reduce=time_reduce+MPI_Wtime()-time00
+c write (2,*) "After REDUCE"
+c call flush(2)
+ else
+#endif
+#ifdef TIMING
+ time01=MPI_Wtime()
+#endif
+ do k=0,2
+ do i=1,dimen
+ ind=(i-1)*3+k+1
+ d_a_tmp(ind)=0.0d0
+ do j=1,dimen
+c write (2,*) "k,i,j,ind",k,i,j,ind,(j-1)*3+k+1
+c call flush(2)
+c & Ginv(i,j),z((j-1)*3+k+1),
+c & Ginv(i,j)*z((j-1)*3+k+1)
+ d_a_tmp(ind)=d_a_tmp(ind)
+ & +Ginv(j,i)*z((j-1)*3+k+1)
+c d_a_tmp(ind)=d_a_tmp(ind)
+c & +Ginv(i,j)*z((j-1)*3+k+1)
+ enddo
+ enddo
+ enddo
+#ifdef TIMING
+ time_ginvmult=time_ginvmult+MPI_Wtime()-time01
+#endif
+#ifdef MPI
+ endif
+#endif
+ return
+ end
+c---------------------------------------------------------------------------
+#ifdef GINV_MULT
+ SUBROUTINE ginv_mult_test(z,d_a_tmp)
+ include 'DIMENSIONS'
+ integer dimen
+c include 'COMMON.MD'
+ double precision z(dimen),d_a_tmp(dimen)
+ double precision ztmp(dimen/3),dtmp(dimen/3)
+
+c do i=1,dimen
+c d_a_tmp(i)=0.0d0
+c do j=1,dimen
+c d_a_tmp(i)=d_a_tmp(i)+Ginv(i,j)*z(j)
+c enddo
+c enddo
+c
+c return
+
+!ibm* unroll(3)
+ do k=0,2
+ do j=1,dimen/3
+ ztmp(j)=z((j-1)*3+k+1)
+ enddo
+
+ call alignx(16,ztmp(1))
+ call alignx(16,dtmp(1))
+ call alignx(16,Ginv(1,1))
+
+ do i=1,dimen/3
+ dtmp(i)=0.0d0
+ do j=1,dimen/3
+ dtmp(i)=dtmp(i)+Ginv(i,j)*ztmp(j)
+ enddo
+ enddo
+ do i=1,dimen/3
+ ind=(i-1)*3+k+1
+ d_a_tmp(ind)=dtmp(i)
+ enddo
+ enddo
+ return
+ end
+#endif
+c---------------------------------------------------------------------------
+ SUBROUTINE fricmat_mult(z,d_a_tmp)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+ integer IERROR
+#endif
+ include 'COMMON.MD'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.SETUP'
+ include 'COMMON.TIME1'
+#ifndef LANG0
+ include 'COMMON.LANGEVIN'
+#else
+ include 'COMMON.LANGEVIN.lang0'
+#endif
+ double precision z(dimen3),d_a_tmp(dimen3),temp(maxres6),time00
+ &time01
+#ifdef MPI
+ if (nfgtasks.gt.1) then
+ if (fg_rank.eq.0) then
+c The matching BROADCAST for fg processors is called in ERGASTULUM
+ time00=MPI_Wtime()
+ call MPI_Bcast(9,1,MPI_INTEGER,king,FG_COMM,IERROR)
+ time_Bcast=time_Bcast+MPI_Wtime()-time00
+c print *,"Processor",myrank," BROADCAST iorder in FRICMAT_MULT"
+ endif
+c call MPI_Barrier(FG_COMM,IERROR)
+ time00=MPI_Wtime()
+ call MPI_Scatterv(z,ng_counts(0),ng_start(0),
+ & MPI_DOUBLE_PRECISION,
+ & z,3*my_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERR)
+c write (2,*) "My chunk of z"
+c do i=1,3*my_ng_count
+c write (2,*) i,z(i)
+c enddo
+ time_scatter=time_scatter+MPI_Wtime()-time00
+#ifdef TIMING
+ time_scatter_fmatmult=time_scatter_fmatmult+MPI_Wtime()-time00
+#endif
+ time01=MPI_Wtime()
+ do k=0,2
+ do i=1,dimen
+ ind=(i-1)*3+k+1
+ temp(ind)=0.0d0
+ do j=1,my_ng_count
+ temp(ind)=temp(ind)-fricmat(j,i)*z((j-1)*3+k+1)
+ enddo
+ enddo
+ enddo
+ time_fricmatmult=time_fricmatmult+MPI_Wtime()-time01
+c write (2,*) "Before REDUCE"
+c write (2,*) "d_a_tmp before reduce"
+c do i=1,dimen3
+c write (2,*) i,temp(i)
+c enddo
+c call flush(2)
+ time00=MPI_Wtime()
+ call MPI_Reduce(temp(1),d_a_tmp(1),dimen3,MPI_DOUBLE_PRECISION,
+ & MPI_SUM,king,FG_COMM,IERR)
+ time_reduce=time_reduce+MPI_Wtime()-time00
+c write (2,*) "After REDUCE"
+c call flush(2)
+ else
+#endif
+#ifdef TIMING
+ time01=MPI_Wtime()
+#endif
+ do k=0,2
+ do i=1,dimen
+ ind=(i-1)*3+k+1
+ d_a_tmp(ind)=0.0d0
+ do j=1,dimen
+ d_a_tmp(ind)=d_a_tmp(ind)
+ & -fricmat(j,i)*z((j-1)*3+k+1)
+ enddo
+ enddo
+ enddo
+#ifdef TIMING
+ time_fricmatmult=time_fricmatmult+MPI_Wtime()-time01
+#endif
+#ifdef MPI
+ endif
+#endif
+c write (iout,*) "Vector d_a"
+c do i=1,dimen3
+c write (2,*) i,d_a_tmp(i)
+c enddo
+ return
+ end
--- /dev/null
+c-------------------------------------------------------------
+
+ subroutine local_move_init(debug)
+crc implicit none
+
+c Includes
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS' ! Needed by COMMON.LOCAL
+ include 'COMMON.GEO' ! For pi, deg2rad
+ include 'COMMON.LOCAL' ! For vbl
+ include 'COMMON.LOCMOVE'
+
+c INPUT arguments
+ logical debug
+
+
+c Determine wheter to do some debugging output
+ locmove_output=debug
+
+c Set the init_called flag to 1
+ init_called=1
+
+c The following are never changed
+ min_theta=60.D0*deg2rad ! (0,PI)
+ max_theta=175.D0*deg2rad ! (0,PI)
+ dmin2=vbl*vbl*2.*(1.-cos(min_theta))
+ dmax2=vbl*vbl*2.*(1.-cos(max_theta))
+ flag=1.0D300
+ small=1.0D-5
+ small2=0.5*small*small
+
+c Not really necessary...
+ a_n=0
+ b_n=0
+ res_n=0
+
+ return
+ end
+
+c-------------------------------------------------------------
+
+ subroutine local_move(n_start, n_end, PHImin, PHImax)
+c Perform a local move between residues m and n (inclusive)
+c PHImin and PHImax [0,PI] determine the size of the move
+c Works on whatever structure is in the variables theta and phi,
+c sidechain variables are left untouched
+c The final structure is NOT minimized, but both the cartesian
+c variables c and the angles are up-to-date at the end (no further
+c chainbuild is required)
+crc implicit none
+
+c Includes
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.CHAIN'
+ include 'COMMON.VAR'
+ include 'COMMON.MINIM'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.LOCMOVE'
+
+c External functions
+ integer move_res
+ external move_res
+ double precision ran_number
+ external ran_number
+
+c INPUT arguments
+ integer n_start, n_end ! First and last residues to move
+ double precision PHImin, PHImax ! min/max angles [0,PI]
+
+c Local variables
+ integer i,j
+ double precision min,max
+ integer iretcode
+
+
+c Check if local_move_init was called. This assumes that it
+c would not be 1 if not explicitely initialized
+ if (init_called.ne.1) then
+ write(6,*)' *** local_move_init not called!!!'
+ stop
+ endif
+
+c Quick check for crazy range
+ if (n_start.gt.n_end .or. n_start.lt.1 .or. n_end.gt.nres) then
+ write(6,'(a,i3,a,i3)')
+ + ' *** Cannot make local move between n_start = ',
+ + n_start,' and n_end = ',n_end
+ return
+ endif
+
+c Take care of end residues first...
+ if (n_start.eq.1) then
+c Move residue 1 (completely random)
+ theta(3)=ran_number(min_theta,max_theta)
+ phi(4)=ran_number(-PI,PI)
+ i=2
+ else
+ i=n_start
+ endif
+ if (n_end.eq.nres) then
+c Move residue nres (completely random)
+ theta(nres)=ran_number(min_theta,max_theta)
+ phi(nres)=ran_number(-PI,PI)
+ j=nres-1
+ else
+ j=n_end
+ endif
+
+c ...then go through all other residues one by one
+c Start from the two extremes and converge
+ call chainbuild
+ do while (i.le.j)
+ min=PHImin
+ max=PHImax
+c$$$c Move the first two residues by less than the others
+c$$$ if (i-n_start.lt.3) then
+c$$$ if (i-n_start.eq.0) then
+c$$$ min=0.4*PHImin
+c$$$ max=0.4*PHImax
+c$$$ else if (i-n_start.eq.1) then
+c$$$ min=0.8*PHImin
+c$$$ max=0.8*PHImax
+c$$$ else if (i-n_start.eq.2) then
+c$$$ min=PHImin
+c$$$ max=PHImax
+c$$$ endif
+c$$$ endif
+
+c The actual move, on residue i
+ iretcode=move_res(min,max,i,c) ! Discard iretcode
+ i=i+1
+
+ if (i.le.j) then
+ min=PHImin
+ max=PHImax
+c$$$c Move the last two residues by less than the others
+c$$$ if (n_end-j.lt.3) then
+c$$$ if (n_end-j.eq.0) then
+c$$$ min=0.4*PHImin
+c$$$ max=0.4*PHImax
+c$$$ else if (n_end-j.eq.1) then
+c$$$ min=0.8*PHImin
+c$$$ max=0.8*PHImax
+c$$$ else if (n_end-j.eq.2) then
+c$$$ min=PHImin
+c$$$ max=PHImax
+c$$$ endif
+c$$$ endif
+
+c The actual move, on residue j
+ iretcode=move_res(min,max,j,c) ! Discard iretcode
+ j=j-1
+ endif
+ enddo
+
+ call int_from_cart(.false.,.false.)
+
+ return
+ end
+
+c-------------------------------------------------------------
+
+ subroutine output_tabs
+c Prints out the contents of a_..., b_..., res_...
+ implicit none
+
+c Includes
+ include 'COMMON.GEO'
+ include 'COMMON.LOCMOVE'
+
+c Local variables
+ integer i,j
+
+
+ write(6,*)'a_...'
+ write(6,'(8f7.1)')(a_ang(i)*rad2deg,i=0,a_n-1)
+ write(6,'(8(2x,3l1,2x))')((a_tab(i,j),i=0,2),j=0,a_n-1)
+
+ write(6,*)'b_...'
+ write(6,'(4f7.1)')(b_ang(i)*rad2deg,i=0,b_n-1)
+ write(6,'(4(2x,3l1,2x))')((b_tab(i,j),i=0,2),j=0,b_n-1)
+
+ write(6,*)'res_...'
+ write(6,'(12f7.1)')(res_ang(i)*rad2deg,i=0,res_n-1)
+ write(6,'(12(2x,3l1,2x))')((res_tab(0,i,j),i=0,2),j=0,res_n-1)
+ write(6,'(12(2x,3l1,2x))')((res_tab(1,i,j),i=0,2),j=0,res_n-1)
+ write(6,'(12(2x,3l1,2x))')((res_tab(2,i,j),i=0,2),j=0,res_n-1)
+
+ return
+ end
+
+c-------------------------------------------------------------
+
+ subroutine angles2tab(PHImin,PHImax,n,ang,tab)
+c Only uses angles if [0,PI] (but PHImin cannot be 0.,
+c and PHImax cannot be PI)
+ implicit none
+
+c Includes
+ include 'COMMON.GEO'
+
+c INPUT arguments
+ double precision PHImin,PHImax
+
+c OUTPUT arguments
+ integer n
+ double precision ang(0:3)
+ logical tab(0:2,0:3)
+
+
+ if (PHImin .eq. PHImax) then
+c Special case with two 010's
+ n = 2;
+ ang(0) = -PHImin;
+ ang(1) = PHImin;
+ tab(0,0) = .false.
+ tab(2,0) = .false.
+ tab(0,1) = .false.
+ tab(2,1) = .false.
+ tab(1,0) = .true.
+ tab(1,1) = .true.
+ else if (PHImin .eq. PI) then
+c Special case with one 010
+ n = 1
+ ang(0) = PI
+ tab(0,0) = .false.
+ tab(2,0) = .false.
+ tab(1,0) = .true.
+ else if (PHImax .eq. 0.) then
+c Special case with one 010
+ n = 1
+ ang(0) = 0.
+ tab(0,0) = .false.
+ tab(2,0) = .false.
+ tab(1,0) = .true.
+ else
+c Standard cases
+ n = 0
+ if (PHImin .gt. 0.) then
+c Start of range (011)
+ ang(n) = PHImin
+ tab(0,n) = .false.
+ tab(1,n) = .true.
+ tab(2,n) = .true.
+c End of range (110)
+ ang(n+1) = -PHImin
+ tab(0,n+1) = .true.
+ tab(1,n+1) = .true.
+ tab(2,n+1) = .false.
+ n = n+2
+ endif
+ if (PHImax .lt. PI) then
+c Start of range (011)
+ ang(n) = -PHImax
+ tab(0,n) = .false.
+ tab(1,n) = .true.
+ tab(2,n) = .true.
+c End of range (110)
+ ang(n+1) = PHImax
+ tab(0,n+1) = .true.
+ tab(1,n+1) = .true.
+ tab(2,n+1) = .false.
+ n = n+2
+ endif
+ endif
+
+ return
+ end
+
+c-------------------------------------------------------------
+
+ subroutine minmax_angles(x,y,z,r,n,ang,tab)
+c When solutions do not exist, assume all angles
+c are acceptable - i.e., initial geometry must be correct
+ implicit none
+
+c Includes
+ include 'COMMON.GEO'
+ include 'COMMON.LOCMOVE'
+
+c Input arguments
+ double precision x,y,z,r
+
+c Output arguments
+ integer n
+ double precision ang(0:3)
+ logical tab(0:2,0:3)
+
+c Local variables
+ double precision num, denom, phi
+ double precision Kmin, Kmax
+ integer i
+
+
+ num = x*x + y*y + z*z
+ denom = x*x + y*y
+ n = 0
+ if (denom .gt. 0.) then
+ phi = atan2(y,x)
+ denom = 2.*r*sqrt(denom)
+ num = num+r*r
+ Kmin = (num - dmin2)/denom
+ Kmax = (num - dmax2)/denom
+
+c Allowed values of K (else all angles are acceptable)
+c -1 <= Kmin < 1
+c -1 < Kmax <= 1
+ if (Kmin .gt. 1. .or. abs(Kmin-1.) .lt. small2) then
+ Kmin = -flag
+ else if (Kmin .lt. -1. .or. abs(Kmin+1.) .lt. small2) then
+ Kmin = PI
+ else
+ Kmin = acos(Kmin)
+ endif
+
+ if (Kmax .lt. -1. .or. abs(Kmax+1.) .lt. small2) then
+ Kmax = flag
+ else if (Kmax .gt. 1. .or. abs(Kmax-1.) .lt. small2) then
+ Kmax = 0.
+ else
+ Kmax = acos(Kmax)
+ endif
+
+ if (Kmax .lt. Kmin) Kmax = Kmin
+
+ call angles2tab(Kmin, Kmax, n, ang, tab)
+
+c Add phi and check that angles are within range (-PI,PI]
+ do i=0,n-1
+ ang(i) = ang(i)+phi
+ if (ang(i) .le. -PI) then
+ ang(i) = ang(i)+2.*PI
+ else if (ang(i) .gt. PI) then
+ ang(i) = ang(i)-2.*PI
+ endif
+ enddo
+ endif
+
+ return
+ end
+
+c-------------------------------------------------------------
+
+ subroutine construct_tab
+c Take a_... and b_... values and produces the results res_...
+c x_ang are assumed to be all different (diff > small)
+c x_tab(1,i) must be 1 for all i (i.e., all x_ang are acceptable)
+ implicit none
+
+c Includes
+ include 'COMMON.LOCMOVE'
+
+c Local variables
+ integer n_max,i,j,index
+ logical done
+ double precision phi
+
+
+ n_max = a_n + b_n
+ if (n_max .eq. 0) then
+ res_n = 0
+ return
+ endif
+
+ do i=0,n_max-1
+ do j=0,1
+ res_tab(j,0,i) = .true.
+ res_tab(j,2,i) = .true.
+ res_tab(j,1,i) = .false.
+ enddo
+ enddo
+
+ index = 0
+ phi = -flag
+ done = .false.
+ do while (.not.done)
+ res_ang(index) = flag
+
+c Check a first...
+ do i=0,a_n-1
+ if ((a_ang(i)-phi).gt.small .and.
+ + a_ang(i) .lt. res_ang(index)) then
+c Found a lower angle
+ res_ang(index) = a_ang(i)
+c Copy the values from a_tab into res_tab(0,,)
+ res_tab(0,0,index) = a_tab(0,i)
+ res_tab(0,1,index) = a_tab(1,i)
+ res_tab(0,2,index) = a_tab(2,i)
+c Set default values for res_tab(1,,)
+ res_tab(1,0,index) = .true.
+ res_tab(1,1,index) = .false.
+ res_tab(1,2,index) = .true.
+ else if (abs(a_ang(i)-res_ang(index)).lt.small) then
+c Found an equal angle (can only be equal to a b_ang)
+ res_tab(0,0,index) = a_tab(0,i)
+ res_tab(0,1,index) = a_tab(1,i)
+ res_tab(0,2,index) = a_tab(2,i)
+ endif
+ enddo
+c ...then check b
+ do i=0,b_n-1
+ if ((b_ang(i)-phi).gt.small .and.
+ + b_ang(i) .lt. res_ang(index)) then
+c Found a lower angle
+ res_ang(index) = b_ang(i)
+c Copy the values from b_tab into res_tab(1,,)
+ res_tab(1,0,index) = b_tab(0,i)
+ res_tab(1,1,index) = b_tab(1,i)
+ res_tab(1,2,index) = b_tab(2,i)
+c Set default values for res_tab(0,,)
+ res_tab(0,0,index) = .true.
+ res_tab(0,1,index) = .false.
+ res_tab(0,2,index) = .true.
+ else if (abs(b_ang(i)-res_ang(index)).lt.small) then
+c Found an equal angle (can only be equal to an a_ang)
+ res_tab(1,0,index) = b_tab(0,i)
+ res_tab(1,1,index) = b_tab(1,i)
+ res_tab(1,2,index) = b_tab(2,i)
+ endif
+ enddo
+
+ if (res_ang(index) .eq. flag) then
+ res_n = index
+ done = .true.
+ else if (index .eq. n_max-1) then
+ res_n = n_max
+ done = .true.
+ else
+ phi = res_ang(index) ! Store previous angle
+ index = index+1
+ endif
+ enddo
+
+c Fill the gaps
+c First a...
+ index = 0
+ if (a_n .gt. 0) then
+ do while (.not.res_tab(0,1,index))
+ index=index+1
+ enddo
+ done = res_tab(0,2,index)
+ do i=index+1,res_n-1
+ if (res_tab(0,1,i)) then
+ done = res_tab(0,2,i)
+ else
+ res_tab(0,0,i) = done
+ res_tab(0,1,i) = done
+ res_tab(0,2,i) = done
+ endif
+ enddo
+ done = res_tab(0,0,index)
+ do i=index-1,0,-1
+ if (res_tab(0,1,i)) then
+ done = res_tab(0,0,i)
+ else
+ res_tab(0,0,i) = done
+ res_tab(0,1,i) = done
+ res_tab(0,2,i) = done
+ endif
+ enddo
+ else
+ do i=0,res_n-1
+ res_tab(0,0,i) = .true.
+ res_tab(0,1,i) = .true.
+ res_tab(0,2,i) = .true.
+ enddo
+ endif
+c ...then b
+ index = 0
+ if (b_n .gt. 0) then
+ do while (.not.res_tab(1,1,index))
+ index=index+1
+ enddo
+ done = res_tab(1,2,index)
+ do i=index+1,res_n-1
+ if (res_tab(1,1,i)) then
+ done = res_tab(1,2,i)
+ else
+ res_tab(1,0,i) = done
+ res_tab(1,1,i) = done
+ res_tab(1,2,i) = done
+ endif
+ enddo
+ done = res_tab(1,0,index)
+ do i=index-1,0,-1
+ if (res_tab(1,1,i)) then
+ done = res_tab(1,0,i)
+ else
+ res_tab(1,0,i) = done
+ res_tab(1,1,i) = done
+ res_tab(1,2,i) = done
+ endif
+ enddo
+ else
+ do i=0,res_n-1
+ res_tab(1,0,i) = .true.
+ res_tab(1,1,i) = .true.
+ res_tab(1,2,i) = .true.
+ enddo
+ endif
+
+c Finally fill the last row with AND operation
+ do i=0,res_n-1
+ do j=0,2
+ res_tab(2,j,i) = (res_tab(0,j,i) .and. res_tab(1,j,i))
+ enddo
+ enddo
+
+ return
+ end
+
+c-------------------------------------------------------------
+
+ subroutine construct_ranges(phi_n,phi_start,phi_end)
+c Given the data in res_..., construct a table of
+c min/max allowed angles
+ implicit none
+
+c Includes
+ include 'COMMON.GEO'
+ include 'COMMON.LOCMOVE'
+
+c Output arguments
+ integer phi_n
+ double precision phi_start(0:11),phi_end(0:11)
+
+c Local variables
+ logical done
+ integer index
+
+
+ if (res_n .eq. 0) then
+c Any move is allowed
+ phi_n = 1
+ phi_start(0) = -PI
+ phi_end(0) = PI
+ else
+ phi_n = 0
+ index = 0
+ done = .false.
+ do while (.not.done)
+c Find start of range (01x)
+ done = .false.
+ do while (.not.done)
+ if (res_tab(2,0,index).or.(.not.res_tab(2,1,index))) then
+ index=index+1
+ else
+ done = .true.
+ phi_start(phi_n) = res_ang(index)
+ endif
+ if (index .eq. res_n) done = .true.
+ enddo
+c If a start was found (index < res_n), find the end of range (x10)
+c It may not be found without wrapping around
+ if (index .lt. res_n) then
+ done = .false.
+ do while (.not.done)
+ if ((.not.res_tab(2,1,index)).or.res_tab(2,2,index)) then
+ index=index+1
+ else
+ done = .true.
+ endif
+ if (index .eq. res_n) done = .true.
+ enddo
+ if (index .lt. res_n) then
+c Found the end of the range
+ phi_end(phi_n) = res_ang(index)
+ phi_n=phi_n+1
+ index=index+1
+ if (index .eq. res_n) then
+ done = .true.
+ else
+ done = .false.
+ endif
+ else
+c Need to wrap around
+ done = .true.
+ phi_end(phi_n) = flag
+ endif
+ endif
+ enddo
+c Take care of the last one if need to wrap around
+ if (phi_end(phi_n) .eq. flag) then
+ index = 0
+ do while ((.not.res_tab(2,1,index)).or.res_tab(2,2,index))
+ index=index+1
+ enddo
+ phi_end(phi_n) = res_ang(index) + 2.*PI
+ phi_n=phi_n+1
+ endif
+ endif
+
+ return
+ end
+
+c-------------------------------------------------------------
+
+ subroutine fix_no_moves(phi)
+ implicit none
+
+c Includes
+ include 'COMMON.GEO'
+ include 'COMMON.LOCMOVE'
+
+c Output arguments
+ double precision phi
+
+c Local variables
+ integer index
+ double precision diff,temp
+
+
+c Look for first 01x in gammas (there MUST be at least one)
+ diff = flag
+ index = 0
+ do while (res_tab(1,0,index) .or. (.not.res_tab(1,1,index)))
+ index=index+1
+ enddo
+ if (res_ang(index) .le. 0.D0) then ! Make sure it's from PHImax
+c Try to increase PHImax
+ if (index .gt. 0) then
+ phi = res_ang(index-1)
+ diff = abs(res_ang(index) - res_ang(index-1))
+ endif
+c Look for last (corresponding) x10
+ index = res_n - 1
+ do while ((.not.res_tab(1,1,index)) .or. res_tab(1,2,index))
+ index=index-1
+ enddo
+ if (index .lt. res_n-1) then
+ temp = abs(res_ang(index) - res_ang(index+1))
+ if (temp .lt. diff) then
+ phi = res_ang(index+1)
+ diff = temp
+ endif
+ endif
+ endif
+
+c If increasing PHImax didn't work, decreasing PHImin
+c will (with one exception)
+c Look for first x10 (there MUST be at least one)
+ index = 0
+ do while ((.not.res_tab(1,1,index)) .or. res_tab(1,2,index))
+ index=index+1
+ enddo
+ if (res_ang(index) .lt. 0.D0) then ! Make sure it's from PHImin
+c Try to decrease PHImin
+ if (index .lt. res_n-1) then
+ temp = abs(res_ang(index) - res_ang(index+1))
+ if (res_ang(index+1) .le. 0.D0 .and. temp .lt. diff) then
+ phi = res_ang(index+1)
+ diff = temp
+ endif
+ endif
+c Look for last (corresponding) 01x
+ index = res_n - 1
+ do while (res_tab(1,0,index) .or. (.not.res_tab(1,1,index)))
+ index=index-1
+ enddo
+ if (index .gt. 0) then
+ temp = abs(res_ang(index) - res_ang(index-1))
+ if (res_ang(index-1) .ge. 0.D0 .and. temp .lt. diff) then
+ phi = res_ang(index-1)
+ diff = temp
+ endif
+ endif
+ endif
+
+c If it still didn't work, it must be PHImax == 0. or PHImin == PI
+ if (diff .eq. flag) then
+ index = 0
+ if (res_tab(index,1,0) .or. (.not.res_tab(index,1,1)) .or.
+ + res_tab(index,1,2)) index = res_n - 1
+c This MUST work at this point
+ if (index .eq. 0) then
+ phi = res_ang(1)
+ else
+ phi = res_ang(index - 1)
+ endif
+ endif
+
+ return
+ end
+
+c-------------------------------------------------------------
+
+ integer function move_res(PHImin,PHImax,i_move)
+c Moves residue i_move (in array c), leaving everything else fixed
+c Starting geometry is not checked, it should be correct!
+c R(,i_move) is the only residue that will move, but must have
+c 1 < i_move < nres (i.e., cannot move ends)
+c Whether any output is done is controlled by locmove_output
+crc implicit none
+
+c Includes
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCMOVE'
+
+c External functions
+ double precision ran_number
+ external ran_number
+
+c Input arguments
+ double precision PHImin,PHImax
+ integer i_move
+
+c RETURN VALUES:
+c 0: move successfull
+c 1: Dmin or Dmax had to be modified
+c 2: move failed - check your input geometry
+
+
+c Local variables
+ double precision X(0:2),Y(0:2),Z(0:2),Orig(0:2)
+ double precision P(0:2)
+ logical no_moves,done
+ integer index,i,j
+ double precision phi,temp,radius
+ double precision phi_start(0:11), phi_end(0:11)
+ integer phi_n
+
+c Set up the coordinate system
+ do i=0,2
+ Orig(i)=0.5*(c(i+1,i_move-1)+c(i+1,i_move+1)) ! Position of origin
+ enddo
+
+ do i=0,2
+ Z(i)=c(i+1,i_move+1)-c(i+1,i_move-1)
+ enddo
+ temp=sqrt(Z(0)*Z(0)+Z(1)*Z(1)+Z(2)*Z(2))
+ do i=0,2
+ Z(i)=Z(i)/temp
+ enddo
+
+ do i=0,2
+ X(i)=c(i+1,i_move)-Orig(i)
+ enddo
+c radius is the radius of the circle on which c(,i_move) can move
+ radius=sqrt(X(0)*X(0)+X(1)*X(1)+X(2)*X(2))
+ do i=0,2
+ X(i)=X(i)/radius
+ enddo
+
+ Y(0)=Z(1)*X(2)-X(1)*Z(2)
+ Y(1)=X(0)*Z(2)-Z(0)*X(2)
+ Y(2)=Z(0)*X(1)-X(0)*Z(1)
+
+c Calculate min, max angles coming from dmin, dmax to c(,i_move-2)
+ if (i_move.gt.2) then
+ do i=0,2
+ P(i)=c(i+1,i_move-2)-Orig(i)
+ enddo
+ call minmax_angles(P(0)*X(0)+P(1)*X(1)+P(2)*X(2),
+ + P(0)*Y(0)+P(1)*Y(1)+P(2)*Y(2),
+ + P(0)*Z(0)+P(1)*Z(1)+P(2)*Z(2),
+ + radius,a_n,a_ang,a_tab)
+ else
+ a_n=0
+ endif
+
+c Calculate min, max angles coming from dmin, dmax to c(,i_move+2)
+ if (i_move.lt.nres-2) then
+ do i=0,2
+ P(i)=c(i+1,i_move+2)-Orig(i)
+ enddo
+ call minmax_angles(P(0)*X(0)+P(1)*X(1)+P(2)*X(2),
+ + P(0)*Y(0)+P(1)*Y(1)+P(2)*Y(2),
+ + P(0)*Z(0)+P(1)*Z(1)+P(2)*Z(2),
+ + radius,b_n,b_ang,b_tab)
+ else
+ b_n=0
+ endif
+
+c Construct the resulting table for alpha and beta
+ call construct_tab()
+
+ if (locmove_output) then
+ print *,'ALPHAS & BETAS TABLE'
+ call output_tabs()
+ endif
+
+c Check that there is at least one possible move
+ no_moves = .true.
+ if (res_n .eq. 0) then
+ no_moves = .false.
+ else
+ index = 0
+ do while ((index .lt. res_n) .and. no_moves)
+ if (res_tab(2,1,index)) no_moves = .false.
+ index=index+1
+ enddo
+ endif
+ if (no_moves) then
+ if (locmove_output) print *,' *** Cannot move anywhere'
+ move_res=2
+ return
+ endif
+
+c Transfer res_... into a_...
+ a_n = 0
+ do i=0,res_n-1
+ if ( (res_tab(2,0,i).neqv.res_tab(2,1,i)) .or.
+ + (res_tab(2,0,i).neqv.res_tab(2,2,i)) ) then
+ a_ang(a_n) = res_ang(i)
+ do j=0,2
+ a_tab(j,a_n) = res_tab(2,j,i)
+ enddo
+ a_n=a_n+1
+ endif
+ enddo
+
+c Check that the PHI's are within [0,PI]
+ if (PHImin .lt. 0. .or. abs(PHImin) .lt. small) PHImin = -flag
+ if (PHImin .gt. PI .or. abs(PHImin-PI) .lt. small) PHImin = PI
+ if (PHImax .gt. PI .or. abs(PHImax-PI) .lt. small) PHImax = flag
+ if (PHImax .lt. 0. .or. abs(PHImax) .lt. small) PHImax = 0.
+ if (PHImax .lt. PHImin) PHImax = PHImin
+c Calculate min and max angles coming from PHImin and PHImax,
+c and put them in b_...
+ call angles2tab(PHImin, PHImax, b_n, b_ang, b_tab)
+c Construct the final table
+ call construct_tab()
+
+ if (locmove_output) then
+ print *,'FINAL TABLE'
+ call output_tabs()
+ endif
+
+c Check that there is at least one possible move
+ no_moves = .true.
+ if (res_n .eq. 0) then
+ no_moves = .false.
+ else
+ index = 0
+ do while ((index .lt. res_n) .and. no_moves)
+ if (res_tab(2,1,index)) no_moves = .false.
+ index=index+1
+ enddo
+ endif
+
+ if (no_moves) then
+c Take care of the case where no solution exists...
+ call fix_no_moves(phi)
+ if (locmove_output) then
+ print *,' *** Had to modify PHImin or PHImax'
+ print *,'phi: ',phi*rad2deg
+ endif
+ move_res=1
+ else
+c ...or calculate the solution
+c Construct phi_start/phi_end arrays
+ call construct_ranges(phi_n, phi_start, phi_end)
+c Choose random angle phi in allowed range(s)
+ temp = 0.
+ do i=0,phi_n-1
+ temp = temp + phi_end(i) - phi_start(i)
+ enddo
+ phi = ran_number(phi_start(0),phi_start(0)+temp)
+ index = 0
+ done = .false.
+ do while (.not.done)
+ if (phi .lt. phi_end(index)) then
+ done = .true.
+ else
+ index=index+1
+ endif
+ if (index .eq. phi_n) then
+ done = .true.
+ else if (.not.done) then
+ phi = phi + phi_start(index) - phi_end(index-1)
+ endif
+ enddo
+ if (index.eq.phi_n) phi=phi_end(phi_n-1) ! Fix numerical errors
+ if (phi .gt. PI) phi = phi-2.*PI
+
+ if (locmove_output) then
+ print *,'ALLOWED RANGE(S)'
+ do i=0,phi_n-1
+ print *,phi_start(i)*rad2deg,phi_end(i)*rad2deg
+ enddo
+ print *,'phi: ',phi*rad2deg
+ endif
+ move_res=0
+ endif
+
+c Re-use radius as temp variable
+ temp=radius*cos(phi)
+ radius=radius*sin(phi)
+ do i=0,2
+ c(i+1,i_move)=Orig(i)+temp*X(i)+radius*Y(i)
+ enddo
+
+ return
+ end
+
+c-------------------------------------------------------------
+
+ subroutine loc_test
+crc implicit none
+
+c Includes
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.LOCMOVE'
+
+c External functions
+ integer move_res
+ external move_res
+
+c Local variables
+ integer i,j
+ integer phi_n
+ double precision phi_start(0:11),phi_end(0:11)
+ double precision phi
+ double precision R(0:2,0:5)
+
+ locmove_output=.true.
+
+c call angles2tab(30.*deg2rad,70.*deg2rad,a_n,a_ang,a_tab)
+c call angles2tab(80.*deg2rad,130.*deg2rad,b_n,b_ang,b_tab)
+c call minmax_angles(0.D0,3.8D0,0.D0,3.8D0,b_n,b_ang,b_tab)
+c call construct_tab
+c call output_tabs
+
+c call construct_ranges(phi_n,phi_start,phi_end)
+c do i=0,phi_n-1
+c print *,phi_start(i)*rad2deg,phi_end(i)*rad2deg
+c enddo
+
+c call fix_no_moves(phi)
+c print *,'NO MOVES FOUND, BEST PHI IS',phi*rad2deg
+
+ R(0,0)=0.D0
+ R(1,0)=0.D0
+ R(2,0)=0.D0
+ R(0,1)=0.D0
+ R(1,1)=-cos(28.D0*deg2rad)
+ R(2,1)=-0.5D0-sin(28.D0*deg2rad)
+ R(0,2)=0.D0
+ R(1,2)=0.D0
+ R(2,2)=-0.5D0
+ R(0,3)=cos(30.D0*deg2rad)
+ R(1,3)=0.D0
+ R(2,3)=0.D0
+ R(0,4)=0.D0
+ R(1,4)=0.D0
+ R(2,4)=0.5D0
+ R(0,5)=0.D0
+ R(1,5)=cos(26.D0*deg2rad)
+ R(2,5)=0.5D0+sin(26.D0*deg2rad)
+ do i=1,5
+ do j=0,2
+ R(j,i)=vbl*R(j,i)
+ enddo
+ enddo
+ i=move_res(R(0,1),0.D0*deg2rad,180.D0*deg2rad)
+ print *,'RETURNED ',i
+ print *,(R(i,3)/vbl,i=0,2)
+
+ return
+ end
+
+c-------------------------------------------------------------
--- /dev/null
+ subroutine map
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.MAP'
+ include 'COMMON.VAR'
+ include 'COMMON.GEO'
+ include 'COMMON.DERIV'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ include 'COMMON.CONTROL'
+ include 'COMMON.TORCNSTR'
+ double precision energia(0:n_ene)
+ character*5 angid(4) /'PHI','THETA','ALPHA','OMEGA'/
+ double precision ang_list(10)
+ double precision g(maxvar),x(maxvar)
+ integer nn(10)
+ write (iout,'(a,i3,a)')'Energy map constructed in the following ',
+ & nmap,' groups of variables:'
+ do i=1,nmap
+ write (iout,'(2a,i3,a,i3)') angid(kang(i)),' of residues ',
+ & res1(i),' to ',res2(i)
+ enddo
+ nmax=nstep(1)
+ do i=2,nmap
+ if (nmax.lt.nstep(i)) nmax=nstep(i)
+ enddo
+ ntot=nmax**nmap
+ iii=0
+ write (istat,'(1h#,a14,29a15)') (" ",k=1,nmap),
+ & (ename(print_order(k)),k=1,nprint_ene),"ETOT","GNORM"
+ do i=0,ntot-1
+ ii=i
+ do j=1,nmap
+ nn(j)=mod(ii,nmax)+1
+ ii=ii/nmax
+ enddo
+ do j=1,nmap
+ if (nn(j).gt.nstep(j)) goto 10
+ enddo
+ iii=iii+1
+Cd write (iout,*) i,iii,(nn(j),j=1,nmap)
+ do j=1,nmap
+ ang_list(j)=ang_from(j)
+ & +(nn(j)-1)*(ang_to(j)-ang_from(j))/nstep(j)
+ do k=res1(j),res2(j)
+ goto (1,2,3,4), kang(j)
+ 1 phi(k)=deg2rad*ang_list(j)
+ if (minim) phi0(k-res1(j)+1)=deg2rad*ang_list(j)
+ goto 5
+ 2 theta(k)=deg2rad*ang_list(j)
+ goto 5
+ 3 alph(k)=deg2rad*ang_list(j)
+ goto 5
+ 4 omeg(k)=deg2rad*ang_list(j)
+ 5 continue
+ enddo ! k
+ enddo ! j
+ call chainbuild
+ call int_from_cart1(.false.)
+ if (minim) then
+ call geom_to_var(nvar,x)
+ call minimize(etot,x,iretcode,nfun)
+ print *,'SUMSL return code is',iretcode,' eval ',nfun
+c call intout
+ else
+ call zerograd
+ call geom_to_var(nvar,x)
+ endif
+ call etotal(energia(0))
+ etot = energia(0)
+ nf=1
+ nfl=3
+ call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
+ gnorm=0.0d0
+ do k=1,nvar
+ gnorm=gnorm+g(k)**2
+ enddo
+ etot=energia(0)
+
+ gnorm=dsqrt(gnorm)
+c write (iout,'(6(1pe15.5))') (ang_list(k),k=1,nmap),etot,gnorm
+ write (istat,'(30e15.5)') (ang_list(k),k=1,nmap),
+ & (energia(print_order(ii)),ii=1,nprint_ene),etot,gnorm
+c write (iout,*) 'POINT',I,' ANGLES:',(ang_list(k),k=1,nmap)
+c call intout
+c call enerprint(energia)
+ 10 continue
+ enddo ! i
+ return
+ end
--- /dev/null
+ SUBROUTINE MATMULT(A1,A2,A3)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ DIMENSION A1(3,3),A2(3,3),A3(3,3)
+ DIMENSION AI3(3,3)
+ DO 1 I=1,3
+ DO 2 J=1,3
+ A3IJ=0.0
+ DO 3 K=1,3
+ 3 A3IJ=A3IJ+A1(I,K)*A2(K,J)
+ AI3(I,J)=A3IJ
+ 2 CONTINUE
+ 1 CONTINUE
+ DO 4 I=1,3
+ DO 4 J=1,3
+ 4 A3(I,J)=AI3(I,J)
+ RETURN
+ END
--- /dev/null
+ subroutine monte_carlo
+C Does Boltzmann and entropic sampling without energy minimization
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+#ifdef MPL
+ include 'COMMON.INFO'
+#endif
+ include 'COMMON.GEO'
+ include 'COMMON.CHAIN'
+ include 'COMMON.MCM'
+ include 'COMMON.MCE'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.INTERACT'
+ include 'COMMON.THREAD'
+ include 'COMMON.NAMES'
+ logical accepted,not_done,over,ovrtim,error,lprint
+ integer MoveType,nbond,nbins
+ integer conf_comp
+ double precision RandOrPert
+ double precision varia(maxvar),elowest,elowest1,
+ & ehighest,ehighest1,eold
+ double precision przes(3),obr(3,3)
+ double precision varold(maxvar)
+ logical non_conv
+ integer moves1(-1:MaxMoveType+1,0:MaxProcs-1),
+ & moves_acc1(-1:MaxMoveType+1,0:MaxProcs-1)
+#ifdef MPL
+ double precision etot_temp,etot_all(0:MaxProcs)
+ external d_vadd,d_vmin,d_vmax
+ double precision entropy1(-max_ene:max_ene),
+ & nhist1(-max_ene:max_ene)
+ integer nbond_move1(maxres*(MaxProcs+1)),
+ & nbond_acc1(maxres*(MaxProcs+1)),itemp(2)
+#endif
+ double precision var_lowest(maxvar)
+ double precision energia(0:n_ene),energia_ave(0:n_ene)
+C
+ write(iout,'(a,i8,2x,a,f10.5)')
+ & 'pool_read_freq=',pool_read_freq,' pool_fraction=',pool_fraction
+ open (istat,file=statname)
+ WhatsUp=0
+ indminn=-max_ene
+ indmaxx=max_ene
+ facee=1.0D0/(maxacc*delte)
+C Number of bins in energy histogram
+ nbins=e_up/delte-1
+ write (iout,*) 'NBINS=',nbins
+ conste=dlog(facee)
+C Read entropy from previous simulations.
+ if (ent_read) then
+ read (ientin,*) indminn,indmaxx,emin,emax
+ print *,'indminn=',indminn,' indmaxx=',indmaxx,' emin=',emin,
+ & ' emax=',emax
+ do i=-max_ene,max_ene
+ entropy(i)=0.0D0
+ enddo
+ read (ientin,*) (ijunk,ejunk,entropy(i),i=indminn,indmaxx)
+ indmin=indminn
+ indmax=indmaxx
+ write (iout,*) 'indminn=',indminn,' indmaxx=',indmaxx,
+ & ' emin=',emin,' emax=',emax
+ write (iout,'(/a)') 'Initial entropy'
+ do i=indminn,indmaxx
+ write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i)
+ enddo
+ endif ! ent_read
+C Read the pool of conformations
+ call read_pool
+ elowest=1.0D+10
+ ehighest=-1.0D+10
+C----------------------------------------------------------------------------
+C Entropy-sampling simulations with continually updated entropy;
+C set NSWEEP=1 for Boltzmann sampling.
+C Loop thru simulations
+C----------------------------------------------------------------------------
+ DO ISWEEP=1,NSWEEP
+C
+C Initialize the IFINISH array.
+C
+#ifdef MPL
+ do i=1,nctasks
+ ifinish(i)=0
+ enddo
+#endif
+c---------------------------------------------------------------------------
+C Initialize counters.
+c---------------------------------------------------------------------------
+C Total number of generated confs.
+ ngen=0
+C Total number of moves. In general this won't be equal to the number of
+C attempted moves, because we may want to reject some "bad" confs just by
+C overlap check.
+ nmove=0
+C Total number of shift (nbond_move(1)), spike, crankshaft, three-bond,...
+C motions.
+ do i=1,nres
+ nbond_move(i)=0
+ nbond_acc(i)=0
+ enddo
+C Initialize total and accepted number of moves of various kind.
+ do i=-1,MaxMoveType
+ moves(i)=0
+ moves_acc(i)=0
+ enddo
+C Total number of energy evaluations.
+ neneval=0
+ nfun=0
+C----------------------------------------------------------------------------
+C Take a conformation from the pool
+C----------------------------------------------------------------------------
+ rewind(istat)
+ write (iout,*) 'emin=',emin,' emax=',emax
+ if (npool.gt.0) then
+ ii=iran_num(1,npool)
+ do i=1,nvar
+ varia(i)=xpool(i,ii)
+ enddo
+ write (iout,*) 'Took conformation',ii,' from the pool energy=',
+ & epool(ii)
+ call var_to_geom(nvar,varia)
+C Print internal coordinates of the initial conformation
+ call intout
+ else if (isweep.gt.1) then
+ if (eold.lt.emax) then
+ do i=1,nvar
+ varia(i)=varold(i)
+ enddo
+ else
+ do i=1,nvar
+ varia(i)=var_lowest(i)
+ enddo
+ endif
+ call var_to_geom(nvar,varia)
+ endif
+C----------------------------------------------------------------------------
+C Compute and print initial energies.
+C----------------------------------------------------------------------------
+ nsave=0
+ Kwita=0
+ WhatsUp=0
+ write (iout,'(/80(1h*)/a,i2/80(1h*)/)') 'MCE iteration #',isweep
+ write (iout,'(/80(1h*)/a)') 'Initial energies:'
+ call chainbuild
+ call geom_to_var(nvar,varia)
+ call etotal(energia(0))
+ etot = energia(0)
+ call enerprint(energia(0))
+ if (refstr) then
+ call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup),nsup,przes,
+ & obr,non_conv)
+ rms=dsqrt(rms)
+ call contact(.false.,ncont,icont,co)
+ frac=contact_fract(ncont,ncont_ref,icont,icont_ref)
+ write (iout,'(a,f8.3,a,f8.3,a,f8.3)')
+ & 'RMS deviation from the reference structure:',rms,
+ & ' % of native contacts:',frac*100,' contact order',co
+ write (istat,'(i10,16(1pe14.5))') 0,
+ & (energia(print_order(i)),i=1,nprint_ene),
+ & etot,rms,frac,co
+ else
+ write (istat,'(i10,14(1pe14.5))') 0,
+ & (energia(print_order(i)),i=1,nprint_ene),etot
+ endif
+c close(istat)
+ neneval=neneval+1
+ if (.not. ent_read) then
+C Initialize the entropy array
+#ifdef MPL
+C Collect total energies from other processors.
+ etot_temp=etot
+ etot_all(0)=etot
+ call mp_gather(etot_temp,etot_all,8,MasterID,cgGroupID)
+ if (MyID.eq.MasterID) then
+C Get the lowest and the highest energy.
+ print *,'MASTER: etot_temp: ',(etot_all(i),i=0,nprocs-1),
+ & ' emin=',emin,' emax=',emax
+ emin=1.0D10
+ emax=-1.0D10
+ do i=0,nprocs
+ if (emin.gt.etot_all(i)) emin=etot_all(i)
+ if (emax.lt.etot_all(i)) emax=etot_all(i)
+ enddo
+ emax=emin+e_up
+ endif ! MyID.eq.MasterID
+ etot_all(1)=emin
+ etot_all(2)=emax
+ print *,'Processor',MyID,' calls MP_BCAST to send/recv etot_all'
+ call mp_bcast(etot_all(1),16,MasterID,cgGroupID)
+ print *,'Processor',MyID,' MP_BCAST to send/recv etot_all ended'
+ if (MyID.ne.MasterID) then
+ print *,'Processor:',MyID,etot_all(1),etot_all(2),
+ & etot_all(1),etot_all(2)
+ emin=etot_all(1)
+ emax=etot_all(2)
+ endif ! MyID.ne.MasterID
+ write (iout,*) 'After MP_GATHER etot_temp=',
+ & etot_temp,' emin=',emin
+#else
+ emin=etot
+ emax=emin+e_up
+ indminn=0
+ indmin=0
+#endif
+ IF (MULTICAN) THEN
+C Multicanonical sampling - start from Boltzmann distribution
+ do i=-max_ene,max_ene
+ entropy(i)=(emin+i*delte)*betbol
+ enddo
+ ELSE
+C Entropic sampling - start from uniform distribution of the density of states
+ do i=-max_ene,max_ene
+ entropy(i)=0.0D0
+ enddo
+ ENDIF ! MULTICAN
+ write (iout,'(/a)') 'Initial entropy'
+ do i=indminn,indmaxx
+ write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i)
+ enddo
+ if (isweep.eq.1) then
+ emax=emin+e_up
+ indminn=0
+ indmin=0
+ indmaxx=indminn+nbins
+ indmax=indmaxx
+ endif ! isweep.eq.1
+ endif ! .not. ent_read
+#ifdef MPL
+ call recv_stop_sig(Kwita)
+ if (whatsup.eq.1) then
+ call send_stop_sig(-2)
+ not_done=.false.
+ else if (whatsup.le.-2) then
+ not_done=.false.
+ else if (whatsup.eq.2) then
+ not_done=.false.
+ else
+ not_done=.true.
+ endif
+#else
+ not_done=.true.
+#endif
+ write (iout,'(/80(1h*)/20x,a/80(1h*))')
+ & 'Enter Monte Carlo procedure.'
+ close(igeom)
+ call briefout(0,etot)
+ do i=1,nvar
+ varold(i)=varia(i)
+ enddo
+ eold=etot
+ call entropia(eold,sold,indeold)
+C NACC is the counter for the accepted conformations of a given processor
+ nacc=0
+C NACC_TOT counts the total number of accepted conformations
+ nacc_tot=0
+C Main loop.
+c----------------------------------------------------------------------------
+C Zero out average energies
+ do i=0,n_ene
+ energia_ave(i)=0.0d0
+ enddo
+C Initialize energy histogram
+ do i=-max_ene,max_ene
+ nhist(i)=0.0D0
+ enddo ! i
+C Zero out iteration counter.
+ it=0
+ do j=1,nvar
+ varold(j)=varia(j)
+ enddo
+C Begin MC iteration loop.
+ do while (not_done)
+ it=it+1
+C Initialize local counter.
+ ntrial=0 ! # of generated non-overlapping confs.
+ noverlap=0 ! # of overlapping confs.
+ accepted=.false.
+ do while (.not. accepted .and. WhatsUp.eq.0 .and. Kwita.eq.0)
+ ntrial=ntrial+1
+C Retrieve the angles of previously accepted conformation
+ do j=1,nvar
+ varia(j)=varold(j)
+ enddo
+ call var_to_geom(nvar,varia)
+C Rebuild the chain.
+ call chainbuild
+ MoveType=0
+ nbond=0
+ lprint=.true.
+C Decide whether to take a conformation from the pool or generate/perturb one
+C randomly
+ from_pool=ran_number(0.0D0,1.0D0)
+ if (npool.gt.0 .and. from_pool.lt.pool_fraction) then
+C Throw a dice to choose the conformation from the pool
+ ii=iran_num(1,npool)
+ do i=1,nvar
+ varia(i)=xpool(i,ii)
+ enddo
+ call var_to_geom(nvar,varia)
+ call chainbuild
+cd call intout
+cd write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar)
+ if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it)
+ & write (iout,'(a,i3,a,f10.5)')
+ & 'Try conformation',ii,' from the pool energy=',epool(ii)
+ MoveType=-1
+ moves(-1)=moves(-1)+1
+ else
+C Decide whether to generate a random conformation or perturb the old one
+ RandOrPert=ran_number(0.0D0,1.0D0)
+ if (RandOrPert.gt.RanFract) then
+ if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it)
+ & write (iout,'(a)') 'Perturbation-generated conformation.'
+ call perturb(error,lprint,MoveType,nbond,0.1D0)
+ if (error) goto 20
+ if (MoveType.lt.1 .or. MoveType.gt.MaxMoveType) then
+ write (iout,'(/a,i7,a/)') 'Error - unknown MoveType=',
+ & MoveType,' returned from PERTURB.'
+ goto 20
+ endif
+ call chainbuild
+ else
+ MoveType=0
+ moves(0)=moves(0)+1
+ nstart_grow=iran_num(3,nres)
+ if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it)
+ & write (iout,'(2a,i3)') 'Random-generated conformation',
+ & ' - chain regrown from residue',nstart_grow
+ call gen_rand_conf(nstart_grow,*30)
+ endif
+ call geom_to_var(nvar,varia)
+ endif ! pool
+Cd write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar)
+ ngen=ngen+1
+ if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it)
+ & write (iout,'(a,i5,a,i10,a,i10)')
+ & 'Processor',MyId,' trial move',ntrial,' total generated:',ngen
+ if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it)
+ & write (*,'(a,i5,a,i10,a,i10)')
+ & 'Processor',MyId,' trial move',ntrial,' total generated:',ngen
+ call etotal(energia(0))
+ etot = energia(0)
+ neneval=neneval+1
+cd call enerprint(energia(0))
+cd write(iout,*)'it=',it,' etot=',etot
+ if (etot-elowest.gt.overlap_cut) then
+ if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it)
+ & write (iout,'(a,i5,a,1pe14.5)') 'Iteration',it,
+ & ' Overlap detected in the current conf.; energy is',etot
+ accepted=.false.
+ noverlap=noverlap+1
+ if (noverlap.gt.maxoverlap) then
+ write (iout,'(a)') 'Too many overlapping confs.'
+ goto 20
+ endif
+ else
+C--------------------------------------------------------------------------
+C... Acceptance test
+C--------------------------------------------------------------------------
+ accepted=.false.
+ if (WhatsUp.eq.0)
+ & call accept_mc(it,etot,eold,scur,sold,varia,varold,accepted)
+ if (accepted) then
+ nacc=nacc+1
+ nacc_tot=nacc_tot+1
+ if (elowest.gt.etot) then
+ elowest=etot
+ do i=1,nvar
+ var_lowest(i)=varia(i)
+ enddo
+ endif
+ if (ehighest.lt.etot) ehighest=etot
+ moves_acc(MoveType)=moves_acc(MoveType)+1
+ if (MoveType.eq.1) then
+ nbond_acc(nbond)=nbond_acc(nbond)+1
+ endif
+C Compare with reference structure.
+ if (refstr) then
+ call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup),
+ & nsup,przes,obr,non_conv)
+ rms=dsqrt(rms)
+ call contact(.false.,ncont,icont,co)
+ frac=contact_fract(ncont,ncont_ref,icont,icont_ref)
+ endif ! refstr
+C
+C Periodically save average energies and confs.
+C
+ do i=0,n_ene
+ energia_ave(i)=energia_ave(i)+energia(i)
+ enddo
+ moves(MaxMoveType+1)=nmove
+ moves_acc(MaxMoveType+1)=nacc
+ IF ((it/save_frequency)*save_frequency.eq.it) THEN
+ do i=0,n_ene
+ energia_ave(i)=energia_ave(i)/save_frequency
+ enddo
+ etot_ave=energia_ave(0)
+C#ifdef AIX
+C open (istat,file=statname,position='append')
+C#else
+C open (istat,file=statname,access='append')
+Cendif
+ if (print_mc.gt.0)
+ & write (iout,'(80(1h*)/20x,a,i20)')
+ & 'Iteration #',it
+ if (refstr .and. print_mc.gt.0) then
+ write (iout,'(a,f8.3,a,f8.3,a,f8.3)')
+ & 'RMS deviation from the reference structure:',rms,
+ & ' % of native contacts:',frac*100,' contact order:',co
+ endif
+ if (print_stat) then
+ if (refstr) then
+ write (istat,'(i10,10(1pe14.5))') it,
+ & (energia_ave(print_order(i)),i=1,nprint_ene),
+ & etot_ave,rms_ave,frac_ave
+ else
+ write (istat,'(i10,10(1pe14.5))') it,
+ & (energia_ave(print_order(i)),i=1,nprint_ene),
+ & etot_ave
+ endif
+ endif
+c close(istat)
+ if (print_mc.gt.0)
+ & call statprint(nacc,nfun,iretcode,etot,elowest)
+C Print internal coordinates.
+ if (print_int) call briefout(nacc,etot)
+ do i=0,n_ene
+ energia_ave(i)=0.0d0
+ enddo
+ ENDIF ! ( (it/save_frequency)*save_frequency.eq.it)
+C Update histogram
+ inde=icialosc((etot-emin)/delte)
+ nhist(inde)=nhist(inde)+1.0D0
+#ifdef MPL
+ if ( (it/message_frequency)*message_frequency.eq.it
+ & .and. (MyID.ne.MasterID) ) then
+ call recv_stop_sig(Kwita)
+ call send_MCM_info(message_frequency)
+ endif
+#endif
+C Store the accepted conf. and its energy.
+ eold=etot
+ sold=scur
+ do i=1,nvar
+ varold(i)=varia(i)
+ enddo
+#ifdef MPL
+ if (Kwita.eq.0) call recv_stop_sig(kwita)
+#endif
+ endif ! accepted
+ endif ! overlap
+#ifdef MPL
+ if (MyID.eq.MasterID .and.
+ & (it/message_frequency)*message_frequency.eq.it) then
+ call receive_MC_info
+ if (nacc_tot.ge.maxacc) accepted=.true.
+ endif
+#endif
+C if ((ntrial.gt.maxtrial_iter
+C & .or. (it/pool_read_freq)*pool_read_freq.eq.it)
+C & .and. npool.gt.0) then
+C Take a conformation from the pool
+C ii=iran_num(1,npool)
+C do i=1,nvar
+C varold(i)=xpool(i,ii)
+C enddo
+C if (ntrial.gt.maxtrial_iter)
+C & write (iout,*) 'Iteration',it,' max. # of trials exceeded.'
+C write (iout,*)
+C & 'Take conformation',ii,' from the pool energy=',epool(ii)
+C if (print_mc.gt.2)
+C & write (iout,'(10f8.3)') (rad2deg*varold(i),i=1,nvar)
+C ntrial=0
+C eold=epool(ii)
+C call entropia(eold,sold,indeold)
+C accepted=.true.
+C endif ! (ntrial.gt.maxtrial_iter .and. npool.gt.0)
+ 30 continue
+ enddo ! accepted
+#ifdef MPL
+ if (MyID.eq.MasterID .and.
+ & (it/message_frequency)*message_frequency.eq.it) then
+ call receive_MC_info
+ endif
+ if (Kwita.eq.0) call recv_stop_sig(kwita)
+#endif
+ if (ovrtim()) WhatsUp=-1
+cd write (iout,*) 'WhatsUp=',WhatsUp,' Kwita=',Kwita
+ not_done = (nacc_tot.lt.maxacc) .and. (WhatsUp.eq.0)
+ & .and. (Kwita.eq.0)
+cd write (iout,*) 'not_done=',not_done
+#ifdef MPL
+ if (Kwita.lt.0) then
+ print *,'Processor',MyID,
+ & ' has received STOP signal =',Kwita,' in EntSamp.'
+cd print *,'not_done=',not_done
+ if (Kwita.lt.-1) WhatsUp=Kwita
+ if (MyID.ne.MasterID) call send_MCM_info(-1)
+ else if (nacc_tot.ge.maxacc) then
+ print *,'Processor',MyID,' calls send_stop_sig,',
+ & ' because a sufficient # of confs. have been collected.'
+cd print *,'not_done=',not_done
+ call send_stop_sig(-1)
+ if (MyID.ne.MasterID) call send_MCM_info(-1)
+ else if (WhatsUp.eq.-1) then
+ print *,'Processor',MyID,
+ & ' calls send_stop_sig because of timeout.'
+cd print *,'not_done=',not_done
+ call send_stop_sig(-2)
+ if (MyID.ne.MasterID) call send_MCM_info(-1)
+ endif
+#endif
+ enddo ! not_done
+
+C-----------------------------------------------------------------
+C... Construct energy histogram & update entropy
+C-----------------------------------------------------------------
+ go to 21
+ 20 WhatsUp=-3
+#ifdef MPL
+ write (iout,*) 'Processor',MyID,
+ & ' is broadcasting ERROR-STOP signal.'
+ write (*,*) 'Processor',MyID,
+ & ' is broadcasting ERROR-STOP signal.'
+ call send_stop_sig(-3)
+ if (MyID.ne.MasterID) call send_MCM_info(-1)
+#endif
+ 21 continue
+ write (iout,'(/a)') 'Energy histogram'
+ do i=-100,100
+ write (iout,'(i5,2f20.5)') i,emin+i*delte,nhist(i)
+ enddo
+#ifdef MPL
+C Wait until every processor has sent complete MC info.
+ if (MyID.eq.MasterID) then
+ not_done=.true.
+ do while (not_done)
+C write (*,*) 'The IFINISH array:'
+C write (*,*) (ifinish(i),i=1,nctasks)
+ not_done=.false.
+ do i=2,nctasks
+ not_done=not_done.or.(ifinish(i).ge.0)
+ enddo
+ if (not_done) call receive_MC_info
+ enddo
+ endif
+C Make collective histogram from the work of all processors.
+ msglen=(2*max_ene+1)*8
+ print *,
+ & 'Processor',MyID,' calls MP_REDUCE to send/receive histograms',
+ & ' msglen=',msglen
+ call mp_reduce(nhist,nhist1,msglen,MasterID,d_vadd,
+ & cgGroupID)
+ print *,'Processor',MyID,' MP_REDUCE accomplished for histogr.'
+ do i=-max_ene,max_ene
+ nhist(i)=nhist1(i)
+ enddo
+C Collect min. and max. energy
+ print *,
+ &'Processor',MyID,' calls MP_REDUCE to send/receive energy borders'
+ call mp_reduce(elowest,elowest1,8,MasterID,d_vmin,cgGroupID)
+ call mp_reduce(ehighest,ehighest1,8,MasterID,d_vmax,cgGroupID)
+ print *,'Processor',MyID,' MP_REDUCE accomplished for energies.'
+ IF (MyID.eq.MasterID) THEN
+ elowest=elowest1
+ ehighest=ehighest1
+#endif
+ write (iout,'(a,i10)') '# of accepted confs:',nacc_tot
+ write (iout,'(a,f10.5,a,f10.5)') 'Lowest energy:',elowest,
+ & ' Highest energy',ehighest
+ indmin=icialosc((elowest-emin)/delte)
+ imdmax=icialosc((ehighest-emin)/delte)
+ if (indmin.lt.indminn) then
+ emax=emin+indmin*delte+e_up
+ indmaxx=indmin+nbins
+ indminn=indmin
+ endif
+ if (.not.ent_read) ent_read=.true.
+ write(iout,*)'indminn=',indminn,' indmaxx=',indmaxx
+C Update entropy (density of states)
+ do i=indmin,indmax
+ if (nhist(i).gt.0) then
+ entropy(i)=entropy(i)+dlog(nhist(i)+0.0D0)
+ endif
+ enddo
+ write (iout,'(/80(1h*)/a,i2/80(1h*)/)')
+ & 'End of macroiteration',isweep
+ write (iout,'(a,f10.5,a,f10.5)') 'Elowest=',elowest,
+ & ' Ehighest=',ehighest
+ write (iout,'(/a)') 'Energy histogram'
+ do i=indminn,indmaxx
+ write (iout,'(i5,2f20.5)') i,emin+i*delte,nhist(i)
+ enddo
+ write (iout,'(/a)') 'Entropy'
+ do i=indminn,indmaxx
+ write (iout,'(i5,2f20.5)') i,emin+i*delte,entropy(i)
+ enddo
+C-----------------------------------------------------------------
+C... End of energy histogram construction
+C-----------------------------------------------------------------
+#ifdef MPL
+ ELSE
+ if (.not. ent_read) ent_read=.true.
+ ENDIF ! MyID .eq. MaterID
+ if (MyID.eq.MasterID) then
+ itemp(1)=indminn
+ itemp(2)=indmaxx
+ endif
+ print *,'before mp_bcast processor',MyID,' indminn=',indminn,
+ & ' indmaxx=',indmaxx,' itemp=',itemp(1),itemp(2)
+ call mp_bcast(itemp(1),8,MasterID,cgGroupID)
+ call mp_bcast(emax,8,MasterID,cgGroupID)
+ print *,'after mp_bcast processor',MyID,' indminn=',indminn,
+ & ' indmaxx=',indmaxx,' itemp=',itemp(1),itemp(2)
+ if (MyID .ne. MasterID) then
+ indminn=itemp(1)
+ indmaxx=itemp(2)
+ endif
+ msglen=(indmaxx-indminn+1)*8
+ print *,'processor',MyID,' calling mp_bcast msglen=',msglen,
+ & ' indminn=',indminn,' indmaxx=',indmaxx,' isweep=',isweep
+ call mp_bcast(entropy(indminn),msglen,MasterID,cgGroupID)
+ IF(MyID.eq.MasterID .and. .not. ovrtim() .and. WhatsUp.ge.0)THEN
+ open (ientout,file=entname,status='unknown')
+ write (ientout,'(2i5,2e25.17)') indminn,indmaxx,emin,emax
+ do i=indminn,indmaxx
+ write (ientout,'(i5,f10.5,f20.15)') i,emin+i*delte,entropy(i)
+ enddo
+ close(ientout)
+ ELSE
+ write (iout,*) 'Received from master:'
+ write (iout,*) 'indminn=',indminn,' indmaxx=',indmaxx,
+ & ' emin=',emin,' emax=',emax
+ write (iout,'(/a)') 'Entropy'
+ do i=indminn,indmaxx
+ write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i)
+ enddo
+ ENDIF ! MyID.eq.MasterID
+ print *,'Processor',MyID,' calls MP_GATHER'
+ call mp_gather(nbond_move,nbond_move1,4*Nbm,MasterID,
+ & cgGroupID)
+ call mp_gather(nbond_acc,nbond_acc1,4*Nbm,MasterID,
+ & cgGroupID)
+ print *,'Processor',MyID,' MP_GATHER call accomplished'
+ if (MyID.eq.MasterID) then
+
+ write (iout,'(/80(1h*)/20x,a)') 'Summary run statistics:'
+ call statprint(nacc_tot,nfun,iretcode,etot,elowest)
+ write (iout,'(a)')
+ & 'Statistics of multiple-bond motions. Total motions:'
+ write (iout,'(8i10)') (nbond_move(i),i=1,Nbm)
+ write (iout,'(a)') 'Accepted motions:'
+ write (iout,'(8i10)') (nbond_acc(i),i=1,Nbm)
+
+ write (iout,'(a)')
+ & 'Statistics of multi-bond moves of respective processors:'
+ do iproc=1,Nprocs-1
+ do i=1,Nbm
+ ind=iproc*nbm+i
+ nbond_move(i)=nbond_move(i)+nbond_move1(ind)
+ nbond_acc(i)=nbond_acc(i)+nbond_acc1(ind)
+ enddo
+ enddo
+ do iproc=0,NProcs-1
+ write (iout,*) 'Processor',iproc,' nbond_move:',
+ & (nbond_move1(iproc*nbm+i),i=1,Nbm),
+ & ' nbond_acc:',(nbond_acc1(iproc*nbm+i),i=1,Nbm)
+ enddo
+ endif
+ call mp_gather(moves,moves1,4*(MaxMoveType+3),MasterID,
+ & cgGroupID)
+ call mp_gather(moves_acc,moves_acc1,4*(MaxMoveType+3),
+ & MasterID,cgGroupID)
+ if (MyID.eq.MasterID) then
+ do iproc=1,Nprocs-1
+ do i=-1,MaxMoveType+1
+ moves(i)=moves(i)+moves1(i,iproc)
+ moves_acc(i)=moves_acc(i)+moves_acc1(i,iproc)
+ enddo
+ enddo
+ nmove=0
+ do i=0,MaxMoveType+1
+ nmove=nmove+moves(i)
+ enddo
+ do iproc=0,NProcs-1
+ write (iout,*) 'Processor',iproc,' moves',
+ & (moves1(i,iproc),i=0,MaxMoveType+1),
+ & ' moves_acc:',(moves_acc1(i,iproc),i=0,MaxMoveType+1)
+ enddo
+ endif
+#else
+ open (ientout,file=entname,status='unknown')
+ write (ientout,'(2i5,2e25.17)') indminn,indmaxx,emin,emax
+ do i=indminn,indmaxx
+ write (ientout,'(i5,f10.5,f20.15)') i,emin+i*delte,entropy(i)
+ enddo
+ close(ientout)
+#endif
+ write (iout,'(/80(1h*)/20x,a)') 'Summary run statistics:'
+ call statprint(nacc_tot,nfun,iretcode,etot,elowest)
+ write (iout,'(a)')
+ & 'Statistics of multiple-bond motions. Total motions:'
+ write (iout,'(8i10)') (nbond_move(i),i=1,Nbm)
+ write (iout,'(a)') 'Accepted motions:'
+ write (iout,'(8i10)') (nbond_acc(i),i=1,Nbm)
+ if (ovrtim() .or. WhatsUp.lt.0) return
+
+C---------------------------------------------------------------------------
+ ENDDO ! ISWEEP
+C---------------------------------------------------------------------------
+
+ runtime=tcpu()
+
+ if (isweep.eq.nsweep .and. it.ge.maxacc)
+ &write (iout,'(/80(1h*)/20x,a/80(1h*)/)') 'All iterations done.'
+ return
+ end
+c------------------------------------------------------------------------------
+ subroutine accept_mc(it,ecur,eold,scur,sold,x,xold,accepted)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.MCM'
+ include 'COMMON.MCE'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.VAR'
+#ifdef MPL
+ include 'COMMON.INFO'
+#endif
+ include 'COMMON.GEO'
+ double precision ecur,eold,xx,ran_number,bol
+ double precision x(maxvar),xold(maxvar)
+ logical accepted
+C Check if the conformation is similar.
+cd write (iout,*) 'Enter ACCEPTING'
+cd write (iout,*) 'Old PHI angles:'
+cd write (iout,*) (rad2deg*xold(i),i=1,nphi)
+cd write (iout,*) 'Current angles'
+cd write (iout,*) (rad2deg*x(i),i=1,nphi)
+cd ddif=dif_ang(nphi,x,xold)
+cd write (iout,*) 'Angle norm:',ddif
+cd write (iout,*) 'ecur=',ecur,' emax=',emax
+ if (ecur.gt.emax) then
+ accepted=.false.
+ if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it)
+ & write (iout,'(a)') 'Conformation rejected as too high in energy'
+ return
+ endif
+C Else evaluate the entropy of the conf and compare it with that of the previous
+C one.
+ call entropia(ecur,scur,indecur)
+cd print *,'Processor',MyID,' ecur=',ecur,' indecur=',indecur,
+cd & ' scur=',scur,' eold=',eold,' sold=',sold
+cd print *,'deix=',deix,' dent=',dent,' delte=',delte
+ if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) then
+ write(iout,*)'it=',it,'ecur=',ecur,' indecur=',indecur,
+ & ' scur=',scur
+ write(iout,*)'eold=',eold,' sold=',sold
+ endif
+ if (scur.le.sold) then
+ accepted=.true.
+ else
+C Else carry out acceptance test
+ xx=ran_number(0.0D0,1.0D0)
+ xxh=scur-sold
+ if (xxh.gt.50.0D0) then
+ bol=0.0D0
+ else
+ bol=exp(-xxh)
+ endif
+ if (bol.gt.xx) then
+ accepted=.true.
+ if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it)
+ & write (iout,'(a)') 'Conformation accepted.'
+ else
+ accepted=.false.
+ if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it)
+ & write (iout,'(a)') 'Conformation rejected.'
+ endif
+ endif
+ return
+ end
+c--------------------------------------------------------------------------
+ integer function icialosc(x)
+ double precision x
+ if (x.lt.0.0D0) then
+ icialosc=dint(x)-1
+ else
+ icialosc=dint(x)
+ endif
+ return
+ end
+c--------------------------------------------------------------------------
+ subroutine entropia(ecur,scur,indecur)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.MCM'
+ include 'COMMON.MCE'
+ include 'COMMON.IOUNITS'
+ double precision ecur,scur
+ integer indecur
+ indecur=icialosc((ecur-emin)/delte)
+ if (iabs(indecur).gt.max_ene) then
+ if ((it/print_freq)*it.eq.it) write (iout,'(a,2i5)')
+ & 'Accepting: Index out of range:',indecur
+ scur=1000.0D0
+ else if (indecur.ge.indmaxx) then
+ scur=entropy(indecur)
+ if (print_mc.gt.0 .and. (it/print_freq)*it.eq.it)
+ & write (iout,*)'Energy boundary reached',
+ & indmaxx,indecur,entropy(indecur)
+ else
+ deix=ecur-(emin+indecur*delte)
+ dent=entropy(indecur+1)-entropy(indecur)
+ scur=entropy(indecur)+(dent/delte)*deix
+ endif
+ return
+ end
--- /dev/null
+ subroutine mcm_setup
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.MCM'
+ include 'COMMON.CONTROL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.NAMES'
+ include 'COMMON.CHAIN'
+ include 'COMMON.VAR'
+C
+C Set up variables used in MC/MCM.
+C
+ write (iout,'(80(1h*)/20x,a/80(1h*))') 'MCM control parameters:'
+ write (iout,'(5(a,i7))') 'Maxacc:',maxacc,' MaxTrial:',MaxTrial,
+ & ' MaxRepm:',MaxRepm,' MaxGen:',MaxGen,' MaxOverlap:',MaxOverlap
+ write (iout,'(4(a,f8.1)/2(a,i3))')
+ & 'Tmin:',Tmin,' Tmax:',Tmax,' TstepH:',TstepH,
+ & ' TstepC:',TstepC,'NstepH:',NstepH,' NstepC:',NstepC
+ if (nwindow.gt.0) then
+ write (iout,'(a)') 'Perturbation windows:'
+ do i=1,nwindow
+ i1=winstart(i)
+ i2=winend(i)
+ it1=itype(i1)
+ it2=itype(i2)
+ write (iout,'(a,i3,a,i3,a,i3)') restyp(it1),i1,restyp(it2),i2,
+ & ' length',winlen(i)
+ enddo
+ endif
+C Rbolt=8.3143D-3*2.388459D-01 kcal/(mol*K)
+ RBol=1.9858D-3
+C Number of "end bonds".
+ koniecl=0
+c koniecl=nphi
+ print *,'koniecl=',koniecl
+ write (iout,'(a)') 'Probabilities of move types:'
+ write (*,'(a)') 'Probabilities of move types:'
+ do i=1,MaxMoveType
+ write (iout,'(a,f10.5)') MovTypID(i),
+ & sumpro_type(i)-sumpro_type(i-1)
+ write (*,'(a,f10.5)') MovTypID(i),
+ & sumpro_type(i)-sumpro_type(i-1)
+ enddo
+ write (iout,*)
+C Maximum length of N-bond segment to be moved
+c nbm=nres-1-(2*koniecl-1)
+ if (nwindow.gt.0) then
+ maxwinlen=winlen(1)
+ do i=2,nwindow
+ if (winlen(i).gt.maxwinlen) maxwinlen=winlen(i)
+ enddo
+ nbm=min0(maxwinlen,6)
+ write (iout,'(a,i3,a,i3)') 'Nbm=',Nbm,' Maxwinlen=',Maxwinlen
+ else
+ nbm=min0(6,nres-2)
+ endif
+ sumpro_bond(0)=0.0D0
+ sumpro_bond(1)=0.0D0
+ do i=2,nbm
+ sumpro_bond(i)=sumpro_bond(i-1)+1.0D0/dfloat(i)
+ enddo
+ write (iout,'(a)') 'The SumPro_Bond array:'
+ write (iout,'(8f10.5)') (sumpro_bond(i),i=1,nbm)
+ write (*,'(a)') 'The SumPro_Bond array:'
+ write (*,'(8f10.5)') (sumpro_bond(i),i=1,nbm)
+C Maximum number of side chains moved simultaneously
+c print *,'nnt=',nnt,' nct=',nct
+ ngly=0
+ do i=nnt,nct
+ if (itype(i).eq.10) ngly=ngly+1
+ enddo
+ mmm=nct-nnt-ngly+1
+ if (mmm.gt.0) then
+ MaxSideMove=min0((nct-nnt+1)/2,mmm)
+ endif
+c print *,'MaxSideMove=',MaxSideMove
+C Max. number of generated confs (not used at present).
+ maxgen=10000
+C Set initial temperature
+ Tcur=Tmin
+ betbol=1.0D0/(Rbol*Tcur)
+ write (iout,'(a,f8.1,a,f10.5)') 'Initial temperature:',Tcur,
+ & ' BetBol:',betbol
+ write (iout,*) 'RanFract=',ranfract
+ return
+ end
+c------------------------------------------------------------------------------
+#ifndef MPI
+ subroutine do_mcm(i_orig)
+C Monte-Carlo-with-Minimization calculations - serial code.
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.CHAIN'
+ include 'COMMON.MCM'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CACHE'
+crc include 'COMMON.DEFORM'
+crc include 'COMMON.DEFORM1'
+ include 'COMMON.NAMES'
+ logical accepted,over,ovrtim,error,lprint,not_done,my_conf,
+ & enelower,non_conv
+ integer MoveType,nbond,conf_comp
+ integer ifeed(max_cache)
+ double precision varia(maxvar),varold(maxvar),elowest,eold,
+ & przes(3),obr(3,3)
+ double precision energia(0:n_ene)
+ double precision coord1(maxres,3)
+
+C---------------------------------------------------------------------------
+C Initialize counters.
+C---------------------------------------------------------------------------
+C Total number of generated confs.
+ ngen=0
+C Total number of moves. In general this won't be equal to the number of
+C attempted moves, because we may want to reject some "bad" confs just by
+C overlap check.
+ nmove=0
+C Total number of temperature jumps.
+ ntherm=0
+C Total number of shift (nbond_move(1)), spike, crankshaft, three-bond,...
+C motions.
+ ncache=0
+ do i=1,nres
+ nbond_move(i)=0
+ enddo
+C Initialize total and accepted number of moves of various kind.
+ do i=0,MaxMoveType
+ moves(i)=0
+ moves_acc(i)=0
+ enddo
+C Total number of energy evaluations.
+ neneval=0
+ nfun=0
+ nsave=0
+
+ write (iout,*) 'RanFract=',RanFract
+
+ WhatsUp=0
+ Kwita=0
+
+c----------------------------------------------------------------------------
+C Compute and print initial energies.
+c----------------------------------------------------------------------------
+ call intout
+ write (iout,'(/80(1h*)/a)') 'Initial energies:'
+ call chainbuild
+ nf=0
+
+ call etotal(energia(0))
+ etot = energia(0)
+C Minimize the energy of the first conformation.
+ if (minim) then
+ call geom_to_var(nvar,varia)
+! write (iout,*) 'The VARIA array'
+! write (iout,'(8f10.4)') (rad2deg*varia(i),i=1,nvar)
+ call minimize(etot,varia,iretcode,nfun)
+ call var_to_geom(nvar,varia)
+ call chainbuild
+ write (iout,*) 'etot from MINIMIZE:',etot
+! write (iout,*) 'Tha VARIA array'
+! write (iout,'(8f10.4)') (rad2deg*varia(i),i=1,nvar)
+
+ call etotal(energia(0))
+ etot=energia(0)
+ call enerprint(energia(0))
+ endif
+ if (refstr) then
+ call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup),nsup,przes,
+ & obr,non_conv)
+ rms=dsqrt(rms)
+ call contact(.false.,ncont,icont,co)
+ frac=contact_fract(ncont,ncont_ref,icont,icont_ref)
+ write (iout,'(a,f8.3,a,f8.3,a,f8.3)')
+ & 'RMS deviation from the reference structure:',rms,
+ & ' % of native contacts:',frac*100,' contact order:',co
+ if (print_stat)
+ & write (istat,'(i5,17(1pe14.5))') 0,
+ & (energia(print_order(i)),i=1,nprint_ene),
+ & etot,rms,frac,co
+ else
+ if (print_stat) write (istat,'(i5,16(1pe14.5))') 0,
+ & (energia(print_order(i)),i=1,nprint_ene),etot
+ endif
+ if (print_stat) close(istat)
+ neneval=neneval+nfun+1
+ write (iout,'(/80(1h*)/20x,a/80(1h*))')
+ & 'Enter Monte Carlo procedure.'
+ if (print_int) then
+ close(igeom)
+ call briefout(0,etot)
+ endif
+ eold=etot
+ do i=1,nvar
+ varold(i)=varia(i)
+ enddo
+ elowest=etot
+ call zapis(varia,etot)
+ nacc=0 ! total # of accepted confs of the current processor.
+ nacc_tot=0 ! total # of accepted confs of all processors.
+
+ not_done = (iretcode.ne.11)
+
+C----------------------------------------------------------------------------
+C Main loop.
+c----------------------------------------------------------------------------
+ it=0
+ nout=0
+ do while (not_done)
+ it=it+1
+ write (iout,'(80(1h*)/20x,a,i7)')
+ & 'Beginning iteration #',it
+C Initialize local counter.
+ ntrial=0 ! # of generated non-overlapping confs.
+ accepted=.false.
+ do while (.not. accepted)
+
+C Retrieve the angles of previously accepted conformation
+ noverlap=0 ! # of overlapping confs.
+ do j=1,nvar
+ varia(j)=varold(j)
+ enddo
+ call var_to_geom(nvar,varia)
+C Rebuild the chain.
+ call chainbuild
+C Heat up the system, if necessary.
+ call heat(over)
+C If temperature cannot be further increased, stop.
+ if (over) goto 20
+ MoveType=0
+ nbond=0
+ lprint=.true.
+cd write (iout,'(a)') 'Old variables:'
+cd write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar)
+C Decide whether to generate a random conformation or perturb the old one
+ RandOrPert=ran_number(0.0D0,1.0D0)
+ if (RandOrPert.gt.RanFract) then
+ if (print_mc.gt.0)
+ & write (iout,'(a)') 'Perturbation-generated conformation.'
+ call perturb(error,lprint,MoveType,nbond,1.0D0)
+ if (error) goto 20
+ if (MoveType.lt.1 .or. MoveType.gt.MaxMoveType) then
+ write (iout,'(/a,i7,a/)') 'Error - unknown MoveType=',
+ & MoveType,' returned from PERTURB.'
+ goto 20
+ endif
+ call chainbuild
+ else
+ MoveType=0
+ moves(0)=moves(0)+1
+ nstart_grow=iran_num(3,nres)
+ if (print_mc.gt.0)
+ & write (iout,'(2a,i3)') 'Random-generated conformation',
+ & ' - chain regrown from residue',nstart_grow
+ call gen_rand_conf(nstart_grow,*30)
+ endif
+ call geom_to_var(nvar,varia)
+cd write (iout,'(a)') 'New variables:'
+cd write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar)
+ ngen=ngen+1
+
+ call etotal(energia(0))
+ etot=energia(0)
+c call enerprint(energia(0))
+c write (iout,'(2(a,1pe14.5))') 'Etot=',Etot,' Elowest=',Elowest
+ if (etot-elowest.gt.overlap_cut) then
+ if(iprint.gt.1.or.etot.lt.1d20)
+ & write (iout,'(a,1pe14.5)')
+ & 'Overlap detected in the current conf.; energy is',etot
+ neneval=neneval+1
+ accepted=.false.
+ noverlap=noverlap+1
+ if (noverlap.gt.maxoverlap) then
+ write (iout,'(a)') 'Too many overlapping confs.'
+ goto 20
+ endif
+ else
+ if (minim) then
+ call minimize(etot,varia,iretcode,nfun)
+cd write (iout,*) 'etot from MINIMIZE:',etot
+cd write (iout,'(a)') 'Variables after minimization:'
+cd write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar)
+
+ call etotal(energia(0))
+ etot = energia(0)
+ neneval=neneval+nfun+2
+ endif
+c call enerprint(energia(0))
+ write (iout,'(a,i6,a,1pe16.6)') 'Conformation:',ngen,
+ & ' energy:',etot
+C--------------------------------------------------------------------------
+C... Do Metropolis test
+C--------------------------------------------------------------------------
+ accepted=.false.
+ my_conf=.false.
+
+ if (WhatsUp.eq.0 .and. Kwita.eq.0) then
+ call metropolis(nvar,varia,varold,etot,eold,accepted,
+ & my_conf,EneLower,it)
+ endif
+ write (iout,*) 'My_Conf=',My_Conf,' EneLower=',EneLower
+ if (accepted) then
+
+ nacc=nacc+1
+ nacc_tot=nacc_tot+1
+ if (elowest.gt.etot) elowest=etot
+ moves_acc(MoveType)=moves_acc(MoveType)+1
+ if (MoveType.eq.1) then
+ nbond_acc(nbond)=nbond_acc(nbond)+1
+ endif
+C Check against conformation repetitions.
+ irepet=conf_comp(varia,etot)
+ if (print_stat) then
+#if defined(AIX) || defined(PGI)
+ open (istat,file=statname,position='append')
+#else
+ open (istat,file=statname,access='append')
+#endif
+ endif
+ call statprint(nacc,nfun,iretcode,etot,elowest)
+ if (refstr) then
+ call var_to_geom(nvar,varia)
+ call chainbuild
+ call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup),
+ & nsup,przes,obr,non_conv)
+ rms=dsqrt(rms)
+ call contact(.false.,ncont,icont,co)
+ frac=contact_fract(ncont,ncont_ref,icont,icont_ref)
+ write (iout,'(a,f8.3,a,f8.3)')
+ & 'RMS deviation from the reference structure:',rms,
+ & ' % of native contacts:',frac*100,' contact order',co
+ endif ! refstr
+ if (My_Conf) then
+ nout=nout+1
+ write (iout,*) 'Writing new conformation',nout
+ if (refstr) then
+ write (istat,'(i5,16(1pe14.5))') nout,
+ & (energia(print_order(i)),i=1,nprint_ene),
+ & etot,rms,frac
+ else
+ if (print_stat)
+ & write (istat,'(i5,17(1pe14.5))') nout,
+ & (energia(print_order(i)),i=1,nprint_ene),etot
+ endif ! refstr
+ if (print_stat) close(istat)
+C Print internal coordinates.
+ if (print_int) call briefout(nout,etot)
+C Accumulate the newly accepted conf in the coord1 array, if it is different
+C from all confs that are already there.
+ call compare_s1(n_thr,max_thread2,etot,varia,ii,
+ & enetb1,coord1,rms_deform,.true.,iprint)
+ write (iout,*) 'After compare_ss: n_thr=',n_thr
+ if (ii.eq.1 .or. ii.eq.3) then
+ write (iout,'(8f10.4)')
+ & (rad2deg*coord1(i,n_thr),i=1,nvar)
+ endif
+ else
+ write (iout,*) 'Conformation from cache, not written.'
+ endif ! My_Conf
+
+ if (nrepm.gt.maxrepm) then
+ write (iout,'(a)') 'Too many conformation repetitions.'
+ goto 20
+ endif
+C Store the accepted conf. and its energy.
+ eold=etot
+ do i=1,nvar
+ varold(i)=varia(i)
+ enddo
+ if (irepet.eq.0) call zapis(varia,etot)
+C Lower the temperature, if necessary.
+ call cool
+
+ else
+
+ ntrial=ntrial+1
+ endif ! accepted
+ endif ! overlap
+
+ 30 continue
+ enddo ! accepted
+C Check for time limit.
+ if (ovrtim()) WhatsUp=-1
+ not_done = (nacc_tot.lt.maxacc) .and. (WhatsUp.eq.0)
+ & .and. (Kwita.eq.0)
+
+ enddo ! not_done
+ goto 21
+ 20 WhatsUp=-3
+
+ 21 continue
+ runtime=tcpu()
+ write (iout,'(/80(1h*)/20x,a)') 'Summary run statistics:'
+ call statprint(nacc,nfun,iretcode,etot,elowest)
+ write (iout,'(a)')
+ & 'Statistics of multiple-bond motions. Total motions:'
+ write (iout,'(16i5)') (nbond_move(i),i=1,Nbm)
+ write (iout,'(a)') 'Accepted motions:'
+ write (iout,'(16i5)') (nbond_acc(i),i=1,Nbm)
+ if (it.ge.maxacc)
+ &write (iout,'(/80(1h*)/20x,a/80(1h*)/)') 'All iterations done.'
+
+ return
+ end
+#endif
+#ifdef MPI
+c------------------------------------------------------------------------------
+ subroutine do_mcm(i_orig)
+C Monte-Carlo-with-Minimization calculations - parallel code.
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'mpif.h'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.CHAIN'
+ include 'COMMON.MCM'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.INTERACT'
+ include 'COMMON.INFO'
+ include 'COMMON.CACHE'
+crc include 'COMMON.DEFORM'
+crc include 'COMMON.DEFORM1'
+crc include 'COMMON.DEFORM2'
+ include 'COMMON.MINIM'
+ include 'COMMON.NAMES'
+ logical accepted,over,ovrtim,error,lprint,not_done,similar,
+ & enelower,non_conv,flag,finish
+ integer MoveType,nbond,conf_comp
+ double precision varia(maxvar),varold(maxvar),elowest,eold,
+ & x1(maxvar), varold1(maxvar), przes(3),obr(3,3)
+ integer iparentx(max_threadss2)
+ integer iparentx1(max_threadss2)
+ integer imtasks(150),imtasks_n
+ double precision energia(0:n_ene)
+
+ print *,'Master entered DO_MCM'
+ nodenum = nprocs
+
+ finish=.false.
+ imtasks_n=0
+ do i=1,nodenum-1
+ imtasks(i)=0
+ enddo
+C---------------------------------------------------------------------------
+C Initialize counters.
+C---------------------------------------------------------------------------
+C Total number of generated confs.
+ ngen=0
+C Total number of moves. In general this won`t be equal to the number of
+C attempted moves, because we may want to reject some "bad" confs just by
+C overlap check.
+ nmove=0
+C Total number of temperature jumps.
+ ntherm=0
+C Total number of shift (nbond_move(1)), spike, crankshaft, three-bond,...
+C motions.
+ ncache=0
+ do i=1,nres
+ nbond_move(i)=0
+ enddo
+C Initialize total and accepted number of moves of various kind.
+ do i=0,MaxMoveType
+ moves(i)=0
+ moves_acc(i)=0
+ enddo
+C Total number of energy evaluations.
+ neneval=0
+ nfun=0
+ nsave=0
+c write (iout,*) 'RanFract=',RanFract
+ WhatsUp=0
+ Kwita=0
+c----------------------------------------------------------------------------
+C Compute and print initial energies.
+c----------------------------------------------------------------------------
+ call intout
+ write (iout,'(/80(1h*)/a)') 'Initial energies:'
+ call chainbuild
+ nf=0
+ call etotal(energia(0))
+ etot = energia(0)
+ call enerprint(energia(0))
+C Request energy computation from slave processors.
+ call geom_to_var(nvar,varia)
+! write (iout,*) 'The VARIA array'
+! write (iout,'(8f10.4)') (rad2deg*varia(i),i=1,nvar)
+ call minimize(etot,varia,iretcode,nfun)
+ call var_to_geom(nvar,varia)
+ call chainbuild
+ write (iout,*) 'etot from MINIMIZE:',etot
+! write (iout,*) 'Tha VARIA array'
+! write (iout,'(8f10.4)') (rad2deg*varia(i),i=1,nvar)
+ neneval=0
+ eneglobal=1.0d99
+ if (print_mc .gt. 0) write (iout,'(/80(1h*)/20x,a/80(1h*))')
+ & 'Enter Monte Carlo procedure.'
+ if (print_mc .gt. 0) write (iout,'(i5,1pe14.5)' ) i_orig,etot
+ eold=etot
+ do i=1,nvar
+ varold(i)=varia(i)
+ enddo
+ elowest=etot
+ call zapis(varia,etot)
+c diagnostics
+ call var_to_geom(nvar,varia)
+ call chainbuild
+ call etotal(energia(0))
+ if (print_mc.gt.0) write (iout,*) 'Initial energy:',etot
+c end diagnostics
+ nacc=0 ! total # of accepted confs of the current processor.
+ nacc_tot=0 ! total # of accepted confs of all processors.
+ not_done=.true.
+C----------------------------------------------------------------------------
+C Main loop.
+c----------------------------------------------------------------------------
+ it=0
+ nout=0
+ LOOP1:do while (not_done)
+ it=it+1
+ if (print_mc.gt.0) write (iout,'(80(1h*)/20x,a,i7)')
+ & 'Beginning iteration #',it
+C Initialize local counter.
+ ntrial=0 ! # of generated non-overlapping confs.
+ noverlap=0 ! # of overlapping confs.
+ accepted=.false.
+ LOOP2:do while (.not. accepted)
+
+ LOOP3:do while (imtasks_n.lt.nodenum-1.and..not.finish)
+ do i=1,nodenum-1
+ if(imtasks(i).eq.0) then
+ is=i
+ exit
+ endif
+ enddo
+C Retrieve the angles of previously accepted conformation
+ do j=1,nvar
+ varia(j)=varold(j)
+ enddo
+ call var_to_geom(nvar,varia)
+C Rebuild the chain.
+ call chainbuild
+C Heat up the system, if necessary.
+ call heat(over)
+C If temperature cannot be further increased, stop.
+ if (over) then
+ finish=.true.
+ endif
+ MoveType=0
+ nbond=0
+c write (iout,'(a)') 'Old variables:'
+c write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar)
+C Decide whether to generate a random conformation or perturb the old one
+ RandOrPert=ran_number(0.0D0,1.0D0)
+ if (RandOrPert.gt.RanFract) then
+ if (print_mc.gt.0)
+ & write (iout,'(a)') 'Perturbation-generated conformation.'
+ call perturb(error,lprint,MoveType,nbond,1.0D0)
+c print *,'after perturb',error,finish
+ if (error) finish = .true.
+ if (MoveType.lt.1 .or. MoveType.gt.MaxMoveType) then
+ write (iout,'(/a,i7,a/)') 'Error - unknown MoveType=',
+ & MoveType,' returned from PERTURB.'
+ finish=.true.
+ write (*,'(/a,i7,a/)') 'Error - unknown MoveType=',
+ & MoveType,' returned from PERTURB.'
+ endif
+ call chainbuild
+ else
+ MoveType=0
+ moves(0)=moves(0)+1
+ nstart_grow=iran_num(3,nres)
+ if (print_mc.gt.0)
+ & write (iout,'(2a,i3)') 'Random-generated conformation',
+ & ' - chain regrown from residue',nstart_grow
+ call gen_rand_conf(nstart_grow,*30)
+ endif
+ call geom_to_var(nvar,varia)
+ ngen=ngen+1
+c print *,'finish=',finish
+ if (etot-elowest.gt.overlap_cut) then
+ if (print_mc.gt.1) write (iout,'(a,1pe14.5)')
+ & 'Overlap detected in the current conf.; energy is',etot
+ if(iprint.gt.1.or.etot.lt.1d19) print *,
+ & 'Overlap detected in the current conf.; energy is',etot
+ neneval=neneval+1
+ accepted=.false.
+ noverlap=noverlap+1
+ if (noverlap.gt.maxoverlap) then
+ write (iout,*) 'Too many overlapping confs.',
+ & ' etot, elowest, overlap_cut', etot, elowest, overlap_cut
+ finish=.true.
+ endif
+ else if (.not. finish) then
+C Distribute tasks to processors
+c print *,'Master sending order'
+ call MPI_SEND(12, 1, MPI_INTEGER, is, tag,
+ & CG_COMM, ierr)
+c write (iout,*) '12: tag=',tag
+c print *,'Master sent order to processor',is
+ call MPI_SEND(it, 1, MPI_INTEGER, is, tag,
+ & CG_COMM, ierr)
+c write (iout,*) 'it: tag=',tag
+ call MPI_SEND(eold, 1, MPI_DOUBLE_PRECISION, is, tag,
+ & CG_COMM, ierr)
+c write (iout,*) 'eold: tag=',tag
+ call MPI_SEND(varia(1), nvar, MPI_DOUBLE_PRECISION,
+ & is, tag,
+ & CG_COMM, ierr)
+c write (iout,*) 'varia: tag=',tag
+ call MPI_SEND(varold(1), nvar, MPI_DOUBLE_PRECISION,
+ & is, tag,
+ & CG_COMM, ierr)
+c write (iout,*) 'varold: tag=',tag
+#ifdef AIX
+ call flush_(iout)
+#else
+ call flush(iout)
+#endif
+ imtasks(is)=1
+ imtasks_n=imtasks_n+1
+C End distribution
+ endif ! overlap
+ enddo LOOP3
+
+ flag = .false.
+ LOOP_RECV:do while(.not.flag)
+ do is=1, nodenum-1
+ call MPI_IPROBE(is,tag,CG_COMM,flag,status,ierr)
+ if(flag) then
+ call MPI_RECV(iitt, 1, MPI_INTEGER, is, tag,
+ & CG_COMM, status, ierr)
+ call MPI_RECV(eold1, 1, MPI_DOUBLE_PRECISION, is, tag,
+ & CG_COMM, status, ierr)
+ call MPI_RECV(etot, 1, MPI_DOUBLE_PRECISION, is, tag,
+ & CG_COMM, status, ierr)
+ call MPI_RECV(varia(1), nvar, MPI_DOUBLE_PRECISION,is,tag,
+ & CG_COMM, status, ierr)
+ call MPI_RECV(varold1(1), nvar, MPI_DOUBLE_PRECISION, is,
+ & tag, CG_COMM, status, ierr)
+ call MPI_RECV(ii_grnum_d, 1, MPI_INTEGER, is, tag,
+ & CG_COMM, status, ierr)
+ call MPI_RECV(ii_ennum_d, 1, MPI_INTEGER, is, tag,
+ & CG_COMM, status, ierr)
+ call MPI_RECV(ii_hesnum_d, 1, MPI_INTEGER, is, tag,
+ & CG_COMM, status, ierr)
+ i_grnum_d=i_grnum_d+ii_grnum_d
+ i_ennum_d=i_ennum_d+ii_ennum_d
+ neneval = neneval+ii_ennum_d
+ i_hesnum_d=i_hesnum_d+ii_hesnum_d
+ i_minimiz=i_minimiz+1
+ imtasks(is)=0
+ imtasks_n=imtasks_n-1
+ exit
+ endif
+ enddo
+ enddo LOOP_RECV
+
+ if(print_mc.gt.0) write (iout,'(a,i6,a,i6,a,i6,a,1pe16.6)')
+ & 'From Worker #',is,' iitt',iitt,
+ & ' Conformation:',ngen,' energy:',etot
+C--------------------------------------------------------------------------
+C... Do Metropolis test
+C--------------------------------------------------------------------------
+ call metropolis(nvar,varia,varold1,etot,eold1,accepted,
+ & similar,EneLower)
+ if(iitt.ne.it.and..not.similar) then
+ call metropolis(nvar,varia,varold,etot,eold,accepted,
+ & similar,EneLower)
+ accepted=enelower
+ endif
+ if(etot.lt.eneglobal)eneglobal=etot
+c if(mod(it,100).eq.0)
+ write(iout,*)'CHUJOJEB ',neneval,eneglobal
+ if (accepted) then
+C Write the accepted conformation.
+ nout=nout+1
+ if (refstr) then
+ call var_to_geom(nvar,varia)
+ call chainbuild
+ call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup),
+ & nsup,przes,obr,non_conv)
+ rms=dsqrt(rms)
+ call contact(.false.,ncont,icont,co)
+ frac=contact_fract(ncont,ncont_ref,icont,icont_ref)
+ write (iout,'(a,f8.3,a,f8.3,a,f8.3)')
+ & 'RMS deviation from the reference structure:',rms,
+ & ' % of native contacts:',frac*100,' contact order:',co
+ endif ! refstr
+ if (print_mc.gt.0)
+ & write (iout,*) 'Writing new conformation',nout
+ if (print_stat) then
+ call var_to_geom(nvar,varia)
+#if defined(AIX) || defined(PGI)
+ open (istat,file=statname,position='append')
+#else
+ open (istat,file=statname,access='append')
+#endif
+ if (refstr) then
+ write (istat,'(i5,16(1pe14.5))') nout,
+ & (energia(print_order(i)),i=1,nprint_ene),
+ & etot,rms,frac
+ else
+ write (istat,'(i5,16(1pe14.5))') nout,
+ & (energia(print_order(i)),i=1,nprint_ene),etot
+ endif ! refstr
+ close(istat)
+ endif ! print_stat
+C Print internal coordinates.
+ if (print_int) call briefout(nout,etot)
+ nacc=nacc+1
+ nacc_tot=nacc_tot+1
+ if (elowest.gt.etot) elowest=etot
+ moves_acc(MoveType)=moves_acc(MoveType)+1
+ if (MoveType.eq.1) then
+ nbond_acc(nbond)=nbond_acc(nbond)+1
+ endif
+C Check against conformation repetitions.
+ irepet=conf_comp(varia,etot)
+ if (nrepm.gt.maxrepm) then
+ if (print_mc.gt.0)
+ & write (iout,'(a)') 'Too many conformation repetitions.'
+ finish=.true.
+ endif
+C Store the accepted conf. and its energy.
+ eold=etot
+ do i=1,nvar
+ varold(i)=varia(i)
+ enddo
+ if (irepet.eq.0) call zapis(varia,etot)
+C Lower the temperature, if necessary.
+ call cool
+ else
+ ntrial=ntrial+1
+ endif ! accepted
+ 30 continue
+ if(finish.and.imtasks_n.eq.0)exit LOOP2
+ enddo LOOP2 ! accepted
+C Check for time limit.
+ not_done = (it.lt.max_mcm_it) .and. (nacc_tot.lt.maxacc)
+ if(.not.not_done .or. finish) then
+ if(imtasks_n.gt.0) then
+ not_done=.true.
+ else
+ not_done=.false.
+ endif
+ finish=.true.
+ endif
+ enddo LOOP1 ! not_done
+ runtime=tcpu()
+ if (print_mc.gt.0) then
+ write (iout,'(/80(1h*)/20x,a)') 'Summary run statistics:'
+ call statprint(nacc,nfun,iretcode,etot,elowest)
+ write (iout,'(a)')
+ & 'Statistics of multiple-bond motions. Total motions:'
+ write (iout,'(16i5)') (nbond_move(i),i=1,Nbm)
+ write (iout,'(a)') 'Accepted motions:'
+ write (iout,'(16i5)') (nbond_acc(i),i=1,Nbm)
+ if (it.ge.maxacc)
+ &write (iout,'(/80(1h*)/20x,a/80(1h*)/)') 'All iterations done.'
+ endif
+#ifdef AIX
+ call flush_(iout)
+#else
+ call flush(iout)
+#endif
+ do is=1,nodenum-1
+ call MPI_SEND(999, 1, MPI_INTEGER, is, tag,
+ & CG_COMM, ierr)
+ enddo
+ return
+ end
+c------------------------------------------------------------------------------
+ subroutine execute_slave(nodeinfo,iprint)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'mpif.h'
+ include 'COMMON.TIME1'
+ include 'COMMON.IOUNITS'
+crc include 'COMMON.DEFORM'
+crc include 'COMMON.DEFORM1'
+crc include 'COMMON.DEFORM2'
+ include 'COMMON.LOCAL'
+ include 'COMMON.VAR'
+ include 'COMMON.INFO'
+ include 'COMMON.MINIM'
+ character*10 nodeinfo
+ double precision x(maxvar),x1(maxvar)
+ nodeinfo='chujwdupe'
+c print *,'Processor:',MyID,' Entering execute_slave'
+ tag=0
+c call MPI_SEND(nodeinfo, 10, MPI_CHARACTER, 0, tag,
+c & CG_COMM, ierr)
+
+1001 call MPI_RECV(i_switch, 1, MPI_INTEGER, 0, tag,
+ & CG_COMM, status, ierr)
+c write(iout,*)'12: tag=',tag
+ if(iprint.ge.2)print *, MyID,' recv order ',i_switch
+ if (i_switch.eq.12) then
+ i_grnum_d=0
+ i_ennum_d=0
+ i_hesnum_d=0
+ call MPI_RECV(iitt, 1, MPI_INTEGER, 0, tag,
+ & CG_COMM, status, ierr)
+c write(iout,*)'12: tag=',tag
+ call MPI_RECV(ener, 1, MPI_DOUBLE_PRECISION, 0, tag,
+ & CG_COMM, status, ierr)
+c write(iout,*)'ener: tag=',tag
+ call MPI_RECV(x(1), nvar, MPI_DOUBLE_PRECISION, 0, tag,
+ & CG_COMM, status, ierr)
+c write(iout,*)'x: tag=',tag
+ call MPI_RECV(x1(1), nvar, MPI_DOUBLE_PRECISION, 0, tag,
+ & CG_COMM, status, ierr)
+c write(iout,*)'x1: tag=',tag
+#ifdef AIX
+ call flush_(iout)
+#else
+ call flush(iout)
+#endif
+c print *,'calling minimize'
+ call minimize(energyx,x,iretcode,nfun)
+ if(iprint.gt.0)
+ & write(iout,100)'minimized energy = ',energyx,
+ & ' # funeval:',nfun,' iret ',iretcode
+ write(*,100)'minimized energy = ',energyx,
+ & ' # funeval:',nfun,' iret ',iretcode
+ 100 format(a20,f10.5,a12,i5,a6,i2)
+ if(iretcode.eq.10) then
+ do iminrep=2,3
+ if(iprint.gt.1)
+ & write(iout,*)' ... not converged - trying again ',iminrep
+ call minimize(energyx,x,iretcode,nfun)
+ if(iprint.gt.1)
+ & write(iout,*)'minimized energy = ',energyx,
+ & ' # funeval:',nfun,' iret ',iretcode
+ if(iretcode.ne.10)go to 812
+ enddo
+ if(iretcode.eq.10) then
+ if(iprint.gt.1)
+ & write(iout,*)' ... not converged again - giving up'
+ go to 812
+ endif
+ endif
+812 continue
+c print *,'Sending results'
+ call MPI_SEND(iitt, 1, MPI_INTEGER, 0, tag,
+ & CG_COMM, ierr)
+ call MPI_SEND(ener, 1, MPI_DOUBLE_PRECISION, 0, tag,
+ & CG_COMM, ierr)
+ call MPI_SEND(energyx, 1, MPI_DOUBLE_PRECISION, 0, tag,
+ & CG_COMM, ierr)
+ call MPI_SEND(x(1), nvar, MPI_DOUBLE_PRECISION, 0, tag,
+ & CG_COMM, ierr)
+ call MPI_SEND(x1(1), nvar, MPI_DOUBLE_PRECISION, 0, tag,
+ & CG_COMM, ierr)
+ call MPI_SEND(i_grnum_d, 1, MPI_INTEGER, 0, tag,
+ & CG_COMM, ierr)
+ call MPI_SEND(nfun, 1, MPI_INTEGER, 0, tag,
+ & CG_COMM, ierr)
+ call MPI_SEND(i_hesnum_d, 1, MPI_INTEGER, 0, tag,
+ & CG_COMM, ierr)
+c print *,'End sending'
+ go to 1001
+ endif
+
+ return
+ end
+#endif
+c------------------------------------------------------------------------------
+ subroutine statprint(it,nfun,iretcode,etot,elowest)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.MCM'
+ if (minim) then
+ write (iout,
+ & '(80(1h*)/a,i5,a,1pe14.5,a,1pe14.5/a,i3,a,i10,a,i5,a,i5)')
+ & 'Finished iteration #',it,' energy is',etot,
+ & ' lowest energy:',elowest,
+ & 'SUMSL return code:',iretcode,
+ & ' # of energy evaluations:',neneval,
+ & '# of temperature jumps:',ntherm,
+ & ' # of minima repetitions:',nrepm
+ else
+ write (iout,'(80(1h*)/a,i8,a,1pe14.5,a,1pe14.5)')
+ & 'Finished iteration #',it,' energy is',etot,
+ & ' lowest energy:',elowest
+ endif
+ write (iout,'(/4a)')
+ & 'Kind of move ',' total',' accepted',
+ & ' fraction'
+ write (iout,'(58(1h-))')
+ do i=-1,MaxMoveType
+ if (moves(i).eq.0) then
+ fr_mov_i=0.0d0
+ else
+ fr_mov_i=dfloat(moves_acc(i))/dfloat(moves(i))
+ endif
+ write(iout,'(a,2i15,f10.5)')MovTypID(i),moves(i),moves_acc(i),
+ & fr_mov_i
+ enddo
+ write (iout,'(a,2i15,f10.5)') 'total ',nmove,nacc_tot,
+ & dfloat(nacc_tot)/dfloat(nmove)
+ write (iout,'(58(1h-))')
+ write (iout,'(a,1pe12.4)') 'Elapsed time:',tcpu()
+ return
+ end
+c------------------------------------------------------------------------------
+ subroutine heat(over)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.MCM'
+ include 'COMMON.IOUNITS'
+ logical over
+C Check if there`s a need to increase temperature.
+ if (ntrial.gt.maxtrial) then
+ if (NstepH.gt.0) then
+ if (dabs(Tcur-TMax).lt.1.0D-7) then
+ if (print_mc.gt.0)
+ & write (iout,'(/80(1h*)/a,f8.3,a/80(1h*))')
+ & 'Upper limit of temperature reached. Terminating.'
+ over=.true.
+ Tcur=Tmin
+ else
+ Tcur=Tcur*TstepH
+ if (Tcur.gt.Tmax) Tcur=Tmax
+ betbol=1.0D0/(Rbol*Tcur)
+ if (print_mc.gt.0)
+ & write (iout,'(/80(1h*)/a,f8.3,a,f10.5/80(1h*))')
+ & 'System heated up to ',Tcur,' K; BetBol:',betbol
+ ntherm=ntherm+1
+ ntrial=0
+ over=.false.
+ endif
+ else
+ if (print_mc.gt.0)
+ & write (iout,'(a)')
+ & 'Maximum number of trials in a single MCM iteration exceeded.'
+ over=.true.
+ Tcur=Tmin
+ endif
+ else
+ over=.false.
+ endif
+ return
+ end
+c------------------------------------------------------------------------------
+ subroutine cool
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.MCM'
+ include 'COMMON.IOUNITS'
+ if (nstepC.gt.0 .and. dabs(Tcur-Tmin).gt.1.0D-7) then
+ Tcur=Tcur/TstepC
+ if (Tcur.lt.Tmin) Tcur=Tmin
+ betbol=1.0D0/(Rbol*Tcur)
+ if (print_mc.gt.0)
+ & write (iout,'(/80(1h*)/a,f8.3,a,f10.5/80(1h*))')
+ & 'System cooled down up to ',Tcur,' K; BetBol:',betbol
+ endif
+ return
+ end
+C---------------------------------------------------------------------------
+ subroutine zapis(varia,etot)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MP
+ include 'mpif.h'
+ include 'COMMON.INFO'
+#endif
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.MCM'
+ include 'COMMON.IOUNITS'
+ integer itemp(maxsave)
+ double precision varia(maxvar)
+ logical lprint
+ lprint=.false.
+ if (lprint) then
+ write (iout,'(a,i5,a,i5)') 'Enter ZAPIS NSave=',Nsave,
+ & ' MaxSave=',MaxSave
+ write (iout,'(a)') 'Current energy and conformation:'
+ write (iout,'(1pe14.5)') etot
+ write (iout,'(10f8.3)') (rad2deg*varia(i),i=1,nvar)
+ endif
+C Shift the contents of the esave and varsave arrays if filled up.
+ call add2cache(maxvar,maxsave,nsave,nvar,MyID,itemp,
+ & etot,varia,esave,varsave)
+ if (lprint) then
+ write (iout,'(a)') 'Energies and the VarSave array.'
+ do i=1,nsave
+ write (iout,'(i5,1pe14.5)') i,esave(i)
+ write (iout,'(10f8.3)') (rad2deg*varsave(j,i),j=1,nvar)
+ enddo
+ endif
+ return
+ end
+C---------------------------------------------------------------------------
+ subroutine perturb(error,lprint,MoveType,nbond,max_phi)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ parameter (MMaxSideMove=100)
+ include 'COMMON.MCM'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.VAR'
+ include 'COMMON.GEO'
+ include 'COMMON.NAMES'
+ include 'COMMON.IOUNITS'
+crc include 'COMMON.DEFORM1'
+ logical error,lprint,fail
+ integer MoveType,nbond,end_select,ind_side(MMaxSideMove)
+ double precision max_phi
+ double precision psi,gen_psi
+ external iran_num
+ integer iran_num
+ integer ifour
+ data ifour /4/
+ error=.false.
+ lprint=.false.
+C Perturb the conformation according to a randomly selected move.
+ call SelectMove(MoveType)
+c write (iout,*) 'MoveType=',MoveType
+ itrial=0
+ goto (100,200,300,400,500) MoveType
+C------------------------------------------------------------------------------
+C Backbone N-bond move.
+C Select the number of bonds (length of the segment to perturb).
+ 100 continue
+ if (itrial.gt.1000) then
+ write (iout,'(a)') 'Too many attempts at multiple-bond move.'
+ error=.true.
+ return
+ endif
+ bond_prob=ran_number(0.0D0,sumpro_bond(nbm))
+c print *,'sumpro_bond(nbm)=',sumpro_bond(nbm),
+c & ' Bond_prob=',Bond_Prob
+ do i=1,nbm-1
+c print *,i,Bond_Prob,sumpro_bond(i),sumpro_bond(i+1)
+ if (bond_prob.ge.sumpro_bond(i) .and.
+ & bond_prob.le.sumpro_bond(i+1)) then
+ nbond=i+1
+ goto 10
+ endif
+ enddo
+ write (iout,'(2a)') 'In PERTURB: Error - number of bonds',
+ & ' to move out of range.'
+ error=.true.
+ return
+ 10 continue
+ if (nwindow.gt.0) then
+C Select the first residue to perturb
+ iwindow=iran_num(1,nwindow)
+ print *,'iwindow=',iwindow
+ iiwin=1
+ do while (winlen(iwindow).lt.nbond)
+ iwindow=iran_num(1,nwindow)
+ iiwin=iiwin+1
+ if (iiwin.gt.1000) then
+ write (iout,'(a)') 'Cannot select moveable residues.'
+ error=.true.
+ return
+ endif
+ enddo
+ nstart=iran_num(winstart(iwindow),winend(iwindow))
+ else
+ nstart = iran_num(koniecl+2,nres-nbond-koniecl)
+cd print *,'nres=',nres,' nbond=',nbond,' koniecl=',koniecl,
+cd & ' nstart=',nstart
+ endif
+ psi = gen_psi()
+ if (psi.eq.0.0) then
+ error=.true.
+ return
+ endif
+ if (print_mc.gt.1) write (iout,'(a,i4,a,i4,a,f8.3)')
+ & 'PERTURB: nbond=',nbond,' nstart=',nstart,' psi=',psi*rad2deg
+cd print *,'nstart=',nstart
+ call bond_move(nbond,nstart,psi,.false.,error)
+ if (error) then
+ write (iout,'(2a)')
+ & 'Could not define reference system in bond_move, ',
+ & 'choosing ahother segment.'
+ itrial=itrial+1
+ goto 100
+ endif
+ nbond_move(nbond)=nbond_move(nbond)+1
+ moves(1)=moves(1)+1
+ nmove=nmove+1
+ return
+C------------------------------------------------------------------------------
+C Backbone endmove. Perturb a SINGLE angle of a residue close to the end of
+C the chain.
+ 200 continue
+ lprint=.true.
+c end_select=iran_num(1,2*koniecl)
+c if (end_select.gt.koniecl) then
+c end_select=nphi-(end_select-koniecl)
+c else
+c end_select=koniecl+3
+c endif
+c if (nwindow.gt.0) then
+c iwin=iran_num(1,nwindow)
+c i1=max0(4,winstart(iwin))
+c i2=min0(winend(imin)+2,nres)
+c end_select=iran_num(i1,i2)
+c else
+c iselect = iran_num(1,nmov_var)
+c jj = 0
+c do i=1,nphi
+c if (isearch_tab(i).eq.1) jj = jj+1
+c if (jj.eq.iselect) then
+c end_select=i+3
+c exit
+c endif
+c enddo
+c endif
+ end_select = iran_num(4,nres)
+ psi=max_phi*gen_psi()
+ if (psi.eq.0.0D0) then
+ error=.true.
+ return
+ endif
+ phi(end_select)=pinorm(phi(end_select)+psi)
+ if (print_mc.gt.1) write (iout,'(a,i4,a,f8.3,a,f8.3)')
+ & 'End angle',end_select,' moved by ',psi*rad2deg,' new angle:',
+ & phi(end_select)*rad2deg
+c if (end_select.gt.3)
+c & theta(end_select-1)=gen_theta(itype(end_select-2),
+c & phi(end_select-1),phi(end_select))
+c if (end_select.lt.nres)
+c & theta(end_select)=gen_theta(itype(end_select-1),
+c & phi(end_select),phi(end_select+1))
+cd print *,'nres=',nres,' end_select=',end_select
+cd print *,'theta',end_select-1,theta(end_select-1)
+cd print *,'theta',end_select,theta(end_select)
+ moves(2)=moves(2)+1
+ nmove=nmove+1
+ lprint=.false.
+ return
+C------------------------------------------------------------------------------
+C Side chain move.
+C Select the number of SCs to perturb.
+ 300 isctry=0
+ 301 nside_move=iran_num(1,MaxSideMove)
+c print *,'nside_move=',nside_move,' MaxSideMove',MaxSideMove
+C Select the indices.
+ do i=1,nside_move
+ icount=0
+ 111 inds=iran_num(nnt,nct)
+ icount=icount+1
+ if (icount.gt.1000) then
+ write (iout,'(a)')'Error - cannot select side chains to move.'
+ error=.true.
+ return
+ endif
+ if (itype(inds).eq.10) goto 111
+ do j=1,i-1
+ if (inds.eq.ind_side(j)) goto 111
+ enddo
+ do j=1,i-1
+ if (inds.lt.ind_side(j)) then
+ indx=j
+ goto 112
+ endif
+ enddo
+ indx=i
+ 112 do j=i,indx+1,-1
+ ind_side(j)=ind_side(j-1)
+ enddo
+ 113 ind_side(indx)=inds
+ enddo
+C Carry out perturbation.
+ do i=1,nside_move
+ ii=ind_side(i)
+ iti=itype(ii)
+ call gen_side(iti,theta(ii+1),alph(ii),omeg(ii),fail)
+ if (fail) then
+ isctry=isctry+1
+ if (isctry.gt.1000) then
+ write (iout,'(a)') 'Too many errors in SC generation.'
+ error=.true.
+ return
+ endif
+ goto 301
+ endif
+ if (print_mc.gt.1) write (iout,'(2a,i4,a,2f8.3)')
+ & 'Side chain ',restyp(iti),ii,' moved to ',
+ & alph(ii)*rad2deg,omeg(ii)*rad2deg
+ enddo
+ moves(3)=moves(3)+1
+ nmove=nmove+1
+ return
+C------------------------------------------------------------------------------
+C THETA move
+ 400 end_select=iran_num(3,nres)
+ theta_new=gen_theta(itype(end_select),phi(end_select),
+ & phi(end_select+1))
+ if (print_mc.gt.1) write (iout,'(a,i3,a,f8.3,a,f8.3)')
+ & 'Theta ',end_select,' moved from',theta(end_select)*rad2deg,
+ & ' to ',theta_new*rad2deg
+ theta(end_select)=theta_new
+ moves(4)=moves(4)+1
+ nmove=nmove+1
+ return
+C------------------------------------------------------------------------------
+C Error returned from SelectMove.
+ 500 error=.true.
+ return
+ end
+C------------------------------------------------------------------------------
+ subroutine SelectMove(MoveType)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.MCM'
+ include 'COMMON.IOUNITS'
+ what_move=ran_number(0.0D0,sumpro_type(MaxMoveType))
+ do i=1,MaxMoveType
+ if (what_move.ge.sumpro_type(i-1).and.
+ & what_move.lt.sumpro_type(i)) then
+ MoveType=i
+ return
+ endif
+ enddo
+ write (iout,'(a)')
+ & 'Fatal error in SelectMoveType: cannot select move.'
+ MoveType=MaxMoveType+1
+ return
+ end
+c----------------------------------------------------------------------------
+ double precision function gen_psi()
+ implicit none
+ integer i
+ double precision x,ran_number
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ x=0.0D0
+ do i=1,100
+ x=ran_number(-pi,pi)
+ if (dabs(x).gt.angmin) then
+ gen_psi=x
+ return
+ endif
+ enddo
+ write (iout,'(a)')'From Gen_Psi: Cannot generate angle increment.'
+ gen_psi=0.0D0
+ return
+ end
+c----------------------------------------------------------------------------
+ subroutine metropolis(n,xcur,xold,ecur,eold,accepted,similar,
+ & enelower)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.MCM'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.VAR'
+ include 'COMMON.GEO'
+crc include 'COMMON.DEFORM'
+ double precision ecur,eold,xx,ran_number,bol
+ double precision xcur(n),xold(n)
+ double precision ecut1 ,ecut2 ,tola
+ logical accepted,similar,not_done,enelower
+ logical lprn
+ data ecut1 /-1.0D-5/,ecut2 /5.0D-3/,tola/5.0D0/
+! ecut1=-5*enedif
+! ecut2=50*enedif
+! tola=5.0d0
+C Set lprn=.true. for debugging.
+ lprn=.false.
+ if (lprn)
+ &write(iout,*)'enedif',enedif,' ecut1',ecut1,' ecut2',ecut2
+ similar=.false.
+ enelower=.false.
+ accepted=.false.
+C Check if the conformation is similar.
+ difene=ecur-eold
+ reldife=difene/dmax1(dabs(eold),dabs(ecur),1.0D0)
+ if (lprn) then
+ write (iout,*) 'Metropolis'
+ write(iout,*)'ecur,eold,difene,reldife',ecur,eold,difene,reldife
+ endif
+C If energy went down remarkably, we accept the new conformation
+C unconditionally.
+cjp if (reldife.lt.ecut1) then
+ if (difene.lt.ecut1) then
+ accepted=.true.
+ EneLower=.true.
+ if (lprn) write (iout,'(a)')
+ & 'Conformation accepted, because energy has lowered remarkably.'
+! elseif (reldife.lt.ecut2 .and. dif_ang(nphi,xcur,xold).lt.tola)
+cjp elseif (reldife.lt.ecut2)
+ elseif (difene.lt.ecut2)
+ & then
+C Reject the conf. if energy has changed insignificantly and there is not
+C much change in conformation.
+ if (lprn)
+ & write (iout,'(2a)') 'Conformation rejected, because it is',
+ & ' similar to the preceding one.'
+ accepted=.false.
+ similar=.true.
+ else
+C Else carry out Metropolis test.
+ EneLower=.false.
+ xx=ran_number(0.0D0,1.0D0)
+ xxh=betbol*difene
+ if (lprn)
+ & write (iout,*) 'betbol=',betbol,' difene=',difene,' xxh=',xxh
+ if (xxh.gt.50.0D0) then
+ bol=0.0D0
+ else
+ bol=exp(-xxh)
+ endif
+ if (lprn) write (iout,*) 'bol=',bol,' xx=',xx
+ if (bol.gt.xx) then
+ accepted=.true.
+ if (lprn) write (iout,'(a)')
+ & 'Conformation accepted, because it passed Metropolis test.'
+ else
+ accepted=.false.
+ if (lprn) write (iout,'(a)')
+ & 'Conformation rejected, because it did not pass Metropolis test.'
+ endif
+ endif
+#ifdef AIX
+ call flush_(iout)
+#else
+ call flush(iout)
+#endif
+ return
+ end
+c------------------------------------------------------------------------------
+ integer function conf_comp(x,ene)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.MCM'
+ include 'COMMON.VAR'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ double precision etol , angtol
+ double precision x(maxvar)
+ double precision dif_ang,difa
+ data etol /0.1D0/, angtol /20.0D0/
+ do ii=nsave,1,-1
+c write (iout,*) 'ii=',ii,'ene=',ene,esave(ii),dabs(ene-esave(ii))
+ if (dabs(ene-esave(ii)).lt.etol) then
+ difa=dif_ang(nphi,x,varsave(1,ii))
+c do i=1,nphi
+c write(iout,'(i3,3f8.3)')i,rad2deg*x(i),
+c & rad2deg*varsave(i,ii)
+c enddo
+c write(iout,*) 'ii=',ii,' difa=',difa,' angtol=',angtol
+ if (difa.le.angtol) then
+ if (print_mc.gt.0) then
+ write (iout,'(a,i5,2(a,1pe15.4))')
+ & 'Current conformation matches #',ii,
+ & ' in the store array ene=',ene,' esave=',esave(ii)
+c write (*,'(a,i5,a)') 'Current conformation matches #',ii,
+c & ' in the store array.'
+ endif ! print_mc.gt.0
+ if (print_mc.gt.1) then
+ do i=1,nphi
+ write(iout,'(i3,3f8.3)')i,rad2deg*x(i),
+ & rad2deg*varsave(i,ii)
+ enddo
+ endif ! print_mc.gt.1
+ nrepm=nrepm+1
+ conf_comp=ii
+ return
+ endif
+ endif
+ enddo
+ conf_comp=0
+ return
+ end
+C----------------------------------------------------------------------------
+ double precision function dif_ang(n,x,y)
+ implicit none
+ integer i,n
+ double precision x(n),y(n)
+ double precision w,wa,dif,difa
+ double precision pinorm
+ include 'COMMON.GEO'
+ wa=0.0D0
+ difa=0.0D0
+ do i=1,n
+ dif=dabs(pinorm(y(i)-x(i)))
+ if (dabs(dif-dwapi).lt.dif) dif=dabs(dif-dwapi)
+ w=1.0D0-(2.0D0*(i-1)/(n-1)-1.0D0)**2+1.0D0/n
+ wa=wa+w
+ difa=difa+dif*dif*w
+ enddo
+ dif_ang=rad2deg*dsqrt(difa/wa)
+ return
+ end
+c--------------------------------------------------------------------------
+ subroutine add2cache(n1,n2,ncache,nvar,SourceID,CachSrc,
+ & ecur,xcur,ecache,xcache)
+ implicit none
+ include 'COMMON.GEO'
+ include 'COMMON.IOUNITS'
+ integer n1,n2,ncache,nvar,SourceID,CachSrc(n2)
+ integer i,ii,j
+ double precision ecur,xcur(nvar),ecache(n2),xcache(n1,n2)
+cd write (iout,*) 'Enter ADD2CACHE ncache=',ncache ,' ecur',ecur
+cd write (iout,'(10f8.3)') (rad2deg*xcur(i),i=1,nvar)
+cd write (iout,*) 'Old CACHE array:'
+cd do i=1,ncache
+cd write (iout,*) 'i=',i,' ecache=',ecache(i),' CachSrc',CachSrc(i)
+cd write (iout,'(10f8.3)') (rad2deg*xcache(j,i),j=1,nvar)
+cd enddo
+
+ i=ncache
+ do while (i.gt.0 .and. ecur.lt.ecache(i))
+ i=i-1
+ enddo
+ i=i+1
+cd write (iout,*) 'i=',i,' ncache=',ncache
+ if (ncache.eq.n2) then
+ write (iout,*) 'Cache dimension exceeded',ncache,n2
+ write (iout,*) 'Highest-energy conformation will be removed.'
+ ncache=ncache-1
+ endif
+ do ii=ncache,i,-1
+ ecache(ii+1)=ecache(ii)
+ CachSrc(ii+1)=CachSrc(ii)
+ do j=1,nvar
+ xcache(j,ii+1)=xcache(j,ii)
+ enddo
+ enddo
+ ecache(i)=ecur
+ CachSrc(i)=SourceID
+ do j=1,nvar
+ xcache(j,i)=xcur(j)
+ enddo
+ ncache=ncache+1
+cd write (iout,*) 'New CACHE array:'
+cd do i=1,ncache
+cd write (iout,*) 'i=',i,' ecache=',ecache(i),' CachSrc',CachSrc(i)
+cd write (iout,'(10f8.3)') (rad2deg*xcache(j,i),j=1,nvar)
+cd enddo
+ return
+ end
+c--------------------------------------------------------------------------
+ subroutine rm_from_cache(i,n1,n2,ncache,nvar,CachSrc,ecache,
+ & xcache)
+ implicit none
+ include 'COMMON.GEO'
+ include 'COMMON.IOUNITS'
+ integer n1,n2,ncache,nvar,CachSrc(n2)
+ integer i,ii,j
+ double precision ecache(n2),xcache(n1,n2)
+
+cd write (iout,*) 'Enter RM_FROM_CACHE'
+cd write (iout,*) 'Old CACHE array:'
+cd do ii=1,ncache
+cd write (iout,*)'i=',ii,' ecache=',ecache(ii),' CachSrc',CachSrc(ii)
+cd write (iout,'(10f8.3)') (rad2deg*xcache(j,ii),j=1,nvar)
+cd enddo
+
+ do ii=i+1,ncache
+ ecache(ii-1)=ecache(ii)
+ CachSrc(ii-1)=CachSrc(ii)
+ do j=1,nvar
+ xcache(j,ii-1)=xcache(j,ii)
+ enddo
+ enddo
+ ncache=ncache-1
+cd write (iout,*) 'New CACHE array:'
+cd do i=1,ncache
+cd write (iout,*) 'i=',i,' ecache=',ecache(i),' CachSrc',CachSrc(i)
+cd write (iout,'(10f8.3)') (rad2deg*xcache(j,i),j=1,nvar)
+cd enddo
+ return
+ end
--- /dev/null
+#ifdef MPI
+ subroutine minim_mcmf
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2))
+ include 'COMMON.VAR'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.MINIM'
+ include 'mpif.h'
+ external func,gradient,fdum
+ real ran1,ran2,ran3
+ include 'COMMON.SETUP'
+ include 'COMMON.GEO'
+ include 'COMMON.CHAIN'
+ include 'COMMON.FFIELD'
+ dimension muster(mpi_status_size)
+ dimension var(maxvar),erg(mxch*(mxch+1)/2+1)
+ double precision d(maxvar),v(1:lv+1),garbage(maxvar)
+ dimension indx(6)
+ dimension iv(liv)
+ dimension idum(1),rdum(1)
+ double precision przes(3),obrot(3,3)
+ logical non_conv
+ data rad /1.745329252d-2/
+ common /przechowalnia/ v
+
+ ichuj=0
+ 10 continue
+ ichuj = ichuj + 1
+ call mpi_recv(indx,6,mpi_integer,king,idint,CG_COMM,
+ * muster,ierr)
+ if (indx(1).eq.0) return
+c print *, 'worker ',me,' received order ',n,ichuj
+ call mpi_recv(var,nvar,mpi_double_precision,
+ * king,idreal,CG_COMM,muster,ierr)
+ call mpi_recv(ene0,1,mpi_double_precision,
+ * king,idreal,CG_COMM,muster,ierr)
+c print *, 'worker ',me,' var read '
+
+
+ call deflt(2,iv,liv,lv,v)
+* 12 means fresh start, dont call deflt
+ iv(1)=12
+* max num of fun calls
+ if (maxfun.eq.0) maxfun=500
+ iv(17)=maxfun
+* max num of iterations
+ if (maxmin.eq.0) maxmin=1000
+ iv(18)=maxmin
+* controls output
+ iv(19)=2
+* selects output unit
+c iv(21)=iout
+ iv(21)=0
+* 1 means to print out result
+ iv(22)=0
+* 1 means to print out summary stats
+ iv(23)=0
+* 1 means to print initial x and d
+ iv(24)=0
+* min val for v(radfac) default is 0.1
+ v(24)=0.1D0
+* max val for v(radfac) default is 4.0
+ v(25)=2.0D0
+* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease)
+* the sumsl default is 0.1
+ v(26)=0.1D0
+* false conv if (act fnctn decrease) .lt. v(34)
+* the sumsl default is 100*machep
+ v(34)=v(34)/100.0D0
+* absolute convergence
+ if (tolf.eq.0.0D0) tolf=1.0D-4
+ v(31)=tolf
+* relative convergence
+ if (rtolf.eq.0.0D0) rtolf=1.0D-4
+ v(32)=rtolf
+* controls initial step size
+ v(35)=1.0D-1
+* large vals of d correspond to small components of step
+ do i=1,nphi
+ d(i)=1.0D-1
+ enddo
+ do i=nphi+1,nvar
+ d(i)=1.0D-1
+ enddo
+c minimize energy
+
+ call func(nvar,var,nf,eee,idum,rdum,fdum)
+ if(eee.gt.1.0d18) then
+c print *,'MINIM_JLEE: ',me,' CHUJ NASTAPIL'
+c print *,' energy before SUMSL =',eee
+c print *,' aborting local minimization'
+ iv(1)=-1
+ v(10)=eee
+ nf=1
+ go to 201
+ endif
+
+ call sumsl(nvar,d,var,func,gradient,iv,liv,lv,v,idum,rdum,fdum)
+c find which conformation was returned from sumsl
+ nf=iv(7)+1
+ 201 continue
+c total # of ftn evaluations (for iwf=0, it includes all minimizations).
+ indx(4)=nf
+ indx(5)=iv(1)
+ eee=v(10)
+
+ call mpi_send(indx,6,mpi_integer,king,idint,CG_COMM,
+ * ierr)
+c print '(a5,i3,15f10.5)', 'ENEX0',indx(1),v(10)
+ call mpi_send(var,nvar,mpi_double_precision,
+ * king,idreal,CG_COMM,ierr)
+ call mpi_send(eee,1,mpi_double_precision,king,idreal,
+ * CG_COMM,ierr)
+ call mpi_send(ene0,1,mpi_double_precision,king,idreal,
+ * CG_COMM,ierr)
+ go to 10
+
+ return
+ end
+#endif
--- /dev/null
+ subroutine minimize(etot,x,iretcode,nfun)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2))
+*********************************************************************
+* OPTIMIZE sets up SUMSL or DFP and provides a simple interface for *
+* the calling subprogram. *
+* when d(i)=1.0, then v(35) is the length of the initial step, *
+* calculated in the usual pythagorean way. *
+* absolute convergence occurs when the function is within v(31) of *
+* zero. unless you know the minimum value in advance, abs convg *
+* is probably not useful. *
+* relative convergence is when the model predicts that the function *
+* will decrease by less than v(32)*abs(fun). *
+*********************************************************************
+ include 'COMMON.IOUNITS'
+ include 'COMMON.VAR'
+ include 'COMMON.GEO'
+ include 'COMMON.MINIM'
+ common /srutu/ icall
+ dimension iv(liv)
+ double precision minval,x(maxvar),d(maxvar),v(1:lv),xx(maxvar)
+ double precision energia(0:n_ene)
+ external func,gradient,fdum
+ external func_restr,grad_restr
+ logical not_done,change,reduce
+c common /przechowalnia/ v
+
+ icall = 1
+
+ NOT_DONE=.TRUE.
+
+c DO WHILE (NOT_DONE)
+
+ call deflt(2,iv,liv,lv,v)
+* 12 means fresh start, dont call deflt
+ iv(1)=12
+* max num of fun calls
+ if (maxfun.eq.0) maxfun=500
+ iv(17)=maxfun
+* max num of iterations
+ if (maxmin.eq.0) maxmin=1000
+ iv(18)=maxmin
+* controls output
+ iv(19)=2
+* selects output unit
+ iv(21)=0
+ if (print_min_ini+print_min_stat+print_min_res.gt.0) iv(21)=iout
+* 1 means to print out result
+ iv(22)=print_min_res
+* 1 means to print out summary stats
+ iv(23)=print_min_stat
+* 1 means to print initial x and d
+ iv(24)=print_min_ini
+* min val for v(radfac) default is 0.1
+ v(24)=0.1D0
+* max val for v(radfac) default is 4.0
+ v(25)=2.0D0
+c v(25)=4.0D0
+* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease)
+* the sumsl default is 0.1
+ v(26)=0.1D0
+* false conv if (act fnctn decrease) .lt. v(34)
+* the sumsl default is 100*machep
+ v(34)=v(34)/100.0D0
+* absolute convergence
+ if (tolf.eq.0.0D0) tolf=1.0D-4
+ v(31)=tolf
+* relative convergence
+ if (rtolf.eq.0.0D0) rtolf=1.0D-4
+ v(32)=rtolf
+* controls initial step size
+ v(35)=1.0D-1
+* large vals of d correspond to small components of step
+ do i=1,nphi
+ d(i)=1.0D-1
+ enddo
+ do i=nphi+1,nvar
+ d(i)=1.0D-1
+ enddo
+cd print *,'Calling SUMSL'
+c call var_to_geom(nvar,x)
+c call chainbuild
+c call etotal(energia(0))
+c etot = energia(0)
+ IF (mask_r) THEN
+ call x2xx(x,xx,nvar_restr)
+ call sumsl(nvar_restr,d,xx,func_restr,grad_restr,
+ & iv,liv,lv,v,idum,rdum,fdum)
+ call xx2x(x,xx)
+ ELSE
+ call sumsl(nvar,d,x,func,gradient,iv,liv,lv,v,idum,rdum,fdum)
+ ENDIF
+ etot=v(10)
+ iretcode=iv(1)
+cd print *,'Exit SUMSL; return code:',iretcode,' energy:',etot
+cd write (iout,'(/a,i4/)') 'SUMSL return code:',iv(1)
+c call intout
+c change=reduce(x)
+ call var_to_geom(nvar,x)
+c if (change) then
+c write (iout,'(a)') 'Reduction worked, minimizing again...'
+c else
+c not_done=.false.
+c endif
+ call chainbuild
+c call etotal(energia(0))
+c etot=energia(0)
+c call enerprint(energia(0))
+ nfun=iv(6)
+
+c write (*,*) 'Processor',MyID,' leaves MINIMIZE.'
+
+c ENDDO ! NOT_DONE
+
+ return
+ end
+#ifdef MPI
+c----------------------------------------------------------------------------
+ subroutine ergastulum
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include "mpif.h"
+#endif
+ include 'COMMON.SETUP'
+ include 'COMMON.DERIV'
+ include 'COMMON.VAR'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.FFIELD'
+ include 'COMMON.INTERACT'
+ include 'COMMON.MD'
+ include 'COMMON.TIME1'
+ double precision z(maxres6),d_a_tmp(maxres6)
+ double precision edum(0:n_ene),time_order(0:10)
+ double precision Gcopy(maxres2,maxres2)
+ common /przechowalnia/ Gcopy
+ integer icall /0/
+C Workers wait for variables and NF, and NFL from the boss
+ iorder=0
+ do while (iorder.ge.0)
+c write (*,*) 'Processor',fg_rank,' CG group',kolor,
+c & ' receives order from Master'
+ time00=MPI_Wtime()
+ call MPI_Bcast(iorder,1,MPI_INTEGER,king,FG_COMM,IERR)
+ time_Bcast=time_Bcast+MPI_Wtime()-time00
+ if (icall.gt.4 .and. iorder.ge.0)
+ & time_order(iorder)=time_order(iorder)+MPI_Wtime()-time00
+ icall=icall+1
+c write (*,*)
+c & 'Processor',fg_rank,' completed receive MPI_BCAST order',iorder
+ if (iorder.eq.0) then
+ call zerograd
+ call etotal(edum)
+c write (2,*) "After etotal"
+c write (2,*) "dimen",dimen," dimen3",dimen3
+c call flush(2)
+ else if (iorder.eq.2) then
+ call zerograd
+ call etotal_short(edum)
+c write (2,*) "After etotal_short"
+c write (2,*) "dimen",dimen," dimen3",dimen3
+c call flush(2)
+ else if (iorder.eq.3) then
+ call zerograd
+ call etotal_long(edum)
+c write (2,*) "After etotal_long"
+c write (2,*) "dimen",dimen," dimen3",dimen3
+c call flush(2)
+ else if (iorder.eq.1) then
+ call sum_gradient
+c write (2,*) "After sum_gradient"
+c write (2,*) "dimen",dimen," dimen3",dimen3
+c call flush(2)
+ else if (iorder.eq.4) then
+ call ginv_mult(z,d_a_tmp)
+ else if (iorder.eq.5) then
+c Setup MD things for a slave
+ dimen=(nct-nnt+1)+nside
+ dimen1=(nct-nnt)+(nct-nnt+1)
+ dimen3=dimen*3
+c write (2,*) "dimen",dimen," dimen3",dimen3
+c call flush(2)
+ call int_bounds(dimen,igmult_start,igmult_end)
+ igmult_start=igmult_start-1
+ call MPI_Allgather(3*igmult_start,1,MPI_INTEGER,
+ & ng_start(0),1,MPI_INTEGER,FG_COMM,IERROR)
+ my_ng_count=igmult_end-igmult_start
+ call MPI_Allgather(3*my_ng_count,1,MPI_INTEGER,ng_counts(0),1,
+ & MPI_INTEGER,FG_COMM,IERROR)
+c write (2,*) "ng_start",(ng_start(i),i=0,nfgtasks-1)
+c write (2,*) "ng_counts",(ng_counts(i),i=0,nfgtasks-1)
+ myginv_ng_count=maxres2*my_ng_count
+c write (2,*) "igmult_start",igmult_start," igmult_end",
+c & igmult_end," my_ng_count",my_ng_count
+c call flush(2)
+ call MPI_Allgather(maxres2*igmult_start,1,MPI_INTEGER,
+ & nginv_start(0),1,MPI_INTEGER,FG_COMM,IERROR)
+ call MPI_Allgather(myginv_ng_count,1,MPI_INTEGER,
+ & nginv_counts(0),1,MPI_INTEGER,FG_COMM,IERROR)
+c write (2,*) "nginv_start",(nginv_start(i),i=0,nfgtasks-1)
+c write (2,*) "nginv_counts",(nginv_counts(i),i=0,nfgtasks-1)
+c call flush(2)
+c call MPI_Barrier(FG_COMM,IERROR)
+ time00=MPI_Wtime()
+ call MPI_Scatterv(ginv(1,1),nginv_counts(0),
+ & nginv_start(0),MPI_DOUBLE_PRECISION,gcopy(1,1),
+ & myginv_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERR)
+#ifdef TIMING
+ time_scatter_ginv=time_scatter_ginv+MPI_Wtime()-time00
+#endif
+ do i=1,dimen
+ do j=1,2*my_ng_count
+ ginv(j,i)=gcopy(i,j)
+ enddo
+ enddo
+c write (2,*) "dimen",dimen," dimen3",dimen3
+c write (2,*) "End MD setup"
+c call flush(2)
+c write (iout,*) "My chunk of ginv_block"
+c call MATOUT2(my_ng_count,dimen3,maxres2,maxers2,ginv_block)
+ else if (iorder.eq.6) then
+ call int_from_cart1(.false.)
+ else if (iorder.eq.7) then
+ call chainbuild_cart
+ else if (iorder.eq.8) then
+ call intcartderiv
+ else if (iorder.eq.9) then
+ call fricmat_mult(z,d_a_tmp)
+ else if (iorder.eq.10) then
+ call setup_fricmat
+ endif
+ enddo
+ write (*,*) 'Processor',fg_rank,' CG group',kolor,
+ & ' absolute rank',myrank,' leves ERGASTULUM.'
+ write(*,*)'Processor',fg_rank,' wait times for respective orders',
+ & (' order[',i,']',time_order(i),i=0,10)
+ return
+ end
+#endif
+************************************************************************
+ subroutine func(n,x,nf,f,uiparm,urparm,ufparm)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.DERIV'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ common /chuju/ jjj
+ double precision energia(0:n_ene)
+ integer jjj
+ double precision ufparm
+ external ufparm
+ integer uiparm(1)
+ real*8 urparm(1)
+ dimension x(maxvar)
+c if (jjj.gt.0) then
+c write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
+c endif
+ nfl=nf
+ icg=mod(nf,2)+1
+cd print *,'func',nf,nfl,icg
+ call var_to_geom(n,x)
+ call zerograd
+ call chainbuild
+cd write (iout,*) 'ETOTAL called from FUNC'
+ call etotal(energia(0))
+ call sum_gradient
+ f=energia(0)
+c if (jjj.gt.0) then
+c write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
+c write (iout,*) 'f=',etot
+c jjj=0
+c endif
+ return
+ end
+************************************************************************
+ subroutine func_restr(n,x,nf,f,uiparm,urparm,ufparm)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.DERIV'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ common /chuju/ jjj
+ double precision energia(0:n_ene)
+ integer jjj
+ double precision ufparm
+ external ufparm
+ integer uiparm(1)
+ real*8 urparm(1)
+ dimension x(maxvar)
+c if (jjj.gt.0) then
+c write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
+c endif
+ nfl=nf
+ icg=mod(nf,2)+1
+ call var_to_geom_restr(n,x)
+ call zerograd
+ call chainbuild
+cd write (iout,*) 'ETOTAL called from FUNC'
+ call etotal(energia(0))
+ call sum_gradient
+ f=energia(0)
+c if (jjj.gt.0) then
+c write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
+c write (iout,*) 'f=',etot
+c jjj=0
+c endif
+ return
+ end
+c-------------------------------------------------------
+ subroutine x2xx(x,xx,n)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.VAR'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ double precision xx(maxvar),x(maxvar)
+
+ do i=1,nvar
+ varall(i)=x(i)
+ enddo
+
+ ig=0
+ igall=0
+ do i=4,nres
+ igall=igall+1
+ if (mask_phi(i).eq.1) then
+ ig=ig+1
+ xx(ig)=x(igall)
+ endif
+ enddo
+
+ do i=3,nres
+ igall=igall+1
+ if (mask_theta(i).eq.1) then
+ ig=ig+1
+ xx(ig)=x(igall)
+ endif
+ enddo
+
+ do ij=1,2
+ do i=2,nres-1
+ if (itype(i).ne.10) then
+ igall=igall+1
+ if (mask_side(i).eq.1) then
+ ig=ig+1
+ xx(ig)=x(igall)
+ endif
+ endif
+ enddo
+ enddo
+
+ n=ig
+
+ return
+ end
+
+ subroutine xx2x(x,xx)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.VAR'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ double precision xx(maxvar),x(maxvar)
+
+ do i=1,nvar
+ x(i)=varall(i)
+ enddo
+
+ ig=0
+ igall=0
+ do i=4,nres
+ igall=igall+1
+ if (mask_phi(i).eq.1) then
+ ig=ig+1
+ x(igall)=xx(ig)
+ endif
+ enddo
+
+ do i=3,nres
+ igall=igall+1
+ if (mask_theta(i).eq.1) then
+ ig=ig+1
+ x(igall)=xx(ig)
+ endif
+ enddo
+
+ do ij=1,2
+ do i=2,nres-1
+ if (itype(i).ne.10) then
+ igall=igall+1
+ if (mask_side(i).eq.1) then
+ ig=ig+1
+ x(igall)=xx(ig)
+ endif
+ endif
+ enddo
+ enddo
+
+ return
+ end
+
+c----------------------------------------------------------
+ subroutine minim_dc(etot,iretcode,nfun)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2))
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.SETUP'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.VAR'
+ include 'COMMON.GEO'
+ include 'COMMON.MINIM'
+ include 'COMMON.CHAIN'
+ dimension iv(liv)
+ double precision minval,x(maxvar),d(maxvar),v(1:lv),xx(maxvar)
+c common /przechowalnia/ v
+
+ double precision energia(0:n_ene)
+ external func_dc,grad_dc,fdum
+ logical not_done,change,reduce
+ double precision g(maxvar),f1
+
+ call deflt(2,iv,liv,lv,v)
+* 12 means fresh start, dont call deflt
+ iv(1)=12
+* max num of fun calls
+ if (maxfun.eq.0) maxfun=500
+ iv(17)=maxfun
+* max num of iterations
+ if (maxmin.eq.0) maxmin=1000
+ iv(18)=maxmin
+* controls output
+ iv(19)=2
+* selects output unit
+ iv(21)=0
+ if (print_min_ini+print_min_stat+print_min_res.gt.0) iv(21)=iout
+* 1 means to print out result
+ iv(22)=print_min_res
+* 1 means to print out summary stats
+ iv(23)=print_min_stat
+* 1 means to print initial x and d
+ iv(24)=print_min_ini
+* min val for v(radfac) default is 0.1
+ v(24)=0.1D0
+* max val for v(radfac) default is 4.0
+ v(25)=2.0D0
+c v(25)=4.0D0
+* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease)
+* the sumsl default is 0.1
+ v(26)=0.1D0
+* false conv if (act fnctn decrease) .lt. v(34)
+* the sumsl default is 100*machep
+ v(34)=v(34)/100.0D0
+* absolute convergence
+ if (tolf.eq.0.0D0) tolf=1.0D-4
+ v(31)=tolf
+* relative convergence
+ if (rtolf.eq.0.0D0) rtolf=1.0D-4
+ v(32)=rtolf
+* controls initial step size
+ v(35)=1.0D-1
+* large vals of d correspond to small components of step
+ do i=1,6*nres
+ d(i)=1.0D-1
+ enddo
+
+ k=0
+ do i=1,nres-1
+ do j=1,3
+ k=k+1
+ x(k)=dc(j,i)
+ enddo
+ enddo
+ do i=2,nres-1
+ if (ialph(i,1).gt.0) then
+ do j=1,3
+ k=k+1
+ x(k)=dc(j,i+nres)
+ enddo
+ endif
+ enddo
+
+ call sumsl(k,d,x,func_dc,grad_dc,iv,liv,lv,v,idum,rdum,fdum)
+
+ k=0
+ do i=1,nres-1
+ do j=1,3
+ k=k+1
+ dc(j,i)=x(k)
+ enddo
+ enddo
+ do i=2,nres-1
+ if (ialph(i,1).gt.0) then
+ do j=1,3
+ k=k+1
+ dc(j,i+nres)=x(k)
+ enddo
+ endif
+ enddo
+ call chainbuild_cart
+
+cd call zerograd
+cd nf=0
+cd call func_dc(k,x,nf,f,idum,rdum,fdum)
+cd call grad_dc(k,x,nf,g,idum,rdum,fdum)
+cd
+cd do i=1,k
+cd x(i)=x(i)+1.0D-5
+cd call func_dc(k,x,nf,f1,idum,rdum,fdum)
+cd x(i)=x(i)-1.0D-5
+cd print '(i5,2f15.5)',i,g(i),(f1-f)/1.0D-5
+cd enddo
+
+ etot=v(10)
+ iretcode=iv(1)
+ nfun=iv(6)
+ return
+ end
+
+ subroutine func_dc(n,x,nf,f,uiparm,urparm,ufparm)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.SETUP'
+ include 'COMMON.DERIV'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.CHAIN'
+ include 'COMMON.VAR'
+ double precision energia(0:n_ene)
+ double precision ufparm
+ external ufparm
+ integer uiparm(1)
+ real*8 urparm(1)
+ dimension x(maxvar)
+ nfl=nf
+cbad icg=mod(nf,2)+1
+ icg=1
+
+ k=0
+ do i=1,nres-1
+ do j=1,3
+ k=k+1
+ dc(j,i)=x(k)
+ enddo
+ enddo
+ do i=2,nres-1
+ if (ialph(i,1).gt.0) then
+ do j=1,3
+ k=k+1
+ dc(j,i+nres)=x(k)
+ enddo
+ endif
+ enddo
+ call chainbuild_cart
+
+ call zerograd
+ call etotal(energia(0))
+ f=energia(0)
+
+cd print *,'func_dc ',nf,nfl,f
+
+ return
+ end
+
+ subroutine grad_dc(n,x,nf,g,uiparm,urparm,ufparm)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.SETUP'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.VAR'
+ include 'COMMON.INTERACT'
+ include 'COMMON.FFIELD'
+ include 'COMMON.MD'
+ include 'COMMON.IOUNITS'
+ external ufparm
+ integer uiparm(1),k
+ double precision urparm(1)
+ dimension x(maxvar),g(maxvar)
+c
+c
+c
+cbad icg=mod(nf,2)+1
+ icg=1
+cd print *,'grad_dc ',nf,nfl,nf-nfl+1,icg
+ if (nf-nfl+1) 20,30,40
+ 20 call func_dc(n,x,nf,f,uiparm,urparm,ufparm)
+cd print *,20
+ if (nf.eq.0) return
+ goto 40
+ 30 continue
+cd print *,30
+ k=0
+ do i=1,nres-1
+ do j=1,3
+ k=k+1
+ dc(j,i)=x(k)
+ enddo
+ enddo
+ do i=2,nres-1
+ if (ialph(i,1).gt.0) then
+ do j=1,3
+ k=k+1
+ dc(j,i+nres)=x(k)
+ enddo
+ endif
+ enddo
+ call chainbuild_cart
+
+C
+C Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
+C
+ 40 call cartgrad
+cd print *,40
+ k=0
+ do i=1,nres-1
+ do j=1,3
+ k=k+1
+ g(k)=gcart(j,i)
+ enddo
+ enddo
+ do i=2,nres-1
+ if (ialph(i,1).gt.0) then
+ do j=1,3
+ k=k+1
+ g(k)=gxcart(j,i)
+ enddo
+ endif
+ enddo
+
+ return
+ end
--- /dev/null
+C $Date: 1994/10/12 17:24:21 $
+C $Revision: 2.5 $
+C
+C
+C
+ logical function find_arg(ipos,line,errflag)
+ parameter (maxlen=80)
+ character*80 line
+ character*1 empty /' '/,equal /'='/
+ logical errflag
+* This function returns .TRUE., if an argument follows keyword keywd; if so
+* IPOS will point to the first non-blank character of the argument. Returns
+* .FALSE., if no argument follows the keyword; in this case IPOS points
+* to the first non-blank character of the next keyword.
+ do while (line(ipos:ipos) .eq. empty .and. ipos.le.maxlen)
+ ipos=ipos+1
+ enddo
+ errflag=.false.
+ if (line(ipos:ipos).eq.equal) then
+ find_arg=.true.
+ ipos=ipos+1
+ do while (line(ipos:ipos) .eq. empty .and. ipos.le.maxlen)
+ ipos=ipos+1
+ enddo
+ if (ipos.gt.maxlen) errflag=.true.
+ else
+ find_arg=.false.
+ endif
+ return
+ end
+ logical function find_group(iunit,jout,key1)
+ character*(*) key1
+ character*80 karta,ucase
+ integer ilen
+ external ilen
+ logical lcom
+ rewind (iunit)
+ karta=' '
+ ll=ilen(key1)
+ do while (index(ucase(karta),key1(1:ll)).eq.0.or.lcom(1,karta))
+ read (iunit,'(a)',end=10) karta
+ enddo
+ write (jout,'(2a)') '> ',karta(1:78)
+ find_group=.true.
+ return
+ 10 find_group=.false.
+ return
+ end
+ logical function iblnk(charc)
+ character*1 charc
+ integer n
+ n = ichar(charc)
+ iblnk = (n.eq.9) .or. (n.eq.10) .or. (charc.eq. ' ')
+ return
+ end
+ integer function ilen(string)
+ character*(*) string
+ logical iblnk
+
+ ilen = len(string)
+1 if ( ilen .gt. 0 ) then
+ if ( iblnk( string(ilen:ilen) ) ) then
+ ilen = ilen - 1
+ goto 1
+ endif
+ endif
+ return
+ end
+ integer function in_keywd_set(nkey,ikey,narg,keywd,keywdset)
+ character*16 keywd,keywdset(1:nkey,0:nkey)
+ character*16 ucase
+ do i=1,narg
+ if (ucase(keywd).eq.keywdset(i,ikey)) then
+* Match found
+ in_keywd_set=i
+ return
+ endif
+ enddo
+* No match to the allowed set of keywords if this point is reached.
+ in_keywd_set=0
+ return
+ end
+ character*(*) function lcase(string)
+ integer i, k, idiff
+ character*(*) string
+ character*1 c
+ character*40 chtmp
+c
+ i = len(lcase)
+ k = len(string)
+ if (i .lt. k) then
+ k = i
+ if (string(k+1:) .ne. ' ') then
+ chtmp = string
+ endif
+ endif
+ idiff = ichar('a') - ichar('A')
+ lcase = string
+ do 99 i = 1, k
+ c = string(i:i)
+ if (lge(c,'A') .and. lle(c,'Z')) then
+ lcase(i:i) = char(ichar(c) + idiff)
+ endif
+ 99 continue
+ return
+ end
+ logical function lcom(ipos,karta)
+ character*80 karta
+ character koment(2) /'!','#'/
+ lcom=.false.
+ do i=1,2
+ if (karta(ipos:ipos).eq.koment(i)) lcom=.true.
+ enddo
+ return
+ end
+ logical function lower_case(ch)
+ character*(*) ch
+ lower_case=(ch.ge.'a' .and. ch.le.'z')
+ return
+ end
+ subroutine mykey(line,keywd,ipos,blankline,errflag)
+* This subroutine seeks a non-empty substring keywd in the string LINE.
+* The substring begins with the first character different from blank and
+* "=" encountered right to the pointer IPOS (inclusively) and terminates
+* at the character left to the first blank or "=". When the subroutine is
+* exited, the pointer IPOS is moved to the position of the terminator in LINE.
+* The logical variable BLANKLINE is set at .TRUE., if LINE(IPOS:) contains
+* only separators or the maximum length of the data line (80) has been reached.
+* The logical variable ERRFLAG is set at .TRUE. if the string
+* consists only from a "=".
+ parameter (maxlen=80)
+ character*1 empty /' '/,equal /'='/,comma /','/
+ character*(*) keywd
+ character*80 line
+ logical blankline,errflag,lcom
+ errflag=.false.
+ do while (line(ipos:ipos).eq.empty .and. (ipos.le.maxlen))
+ ipos=ipos+1
+ enddo
+ if (ipos.gt.maxlen .or. lcom(ipos,line) ) then
+* At this point the rest of the input line turned out to contain only blanks
+* or to be commented out.
+ blankline=.true.
+ return
+ endif
+ blankline=.false.
+ istart=ipos
+* Checks whether the current char is a separator.
+ do while (line(ipos:ipos).ne.empty .and. line(ipos:ipos).ne.equal
+ & .and. line(ipos:ipos).ne.comma .and. ipos.le.maxlen)
+ ipos=ipos+1
+ enddo
+ iend=ipos-1
+* Error flag set to .true., if the length of the keyword was found less than 1.
+ if (iend.lt.istart) then
+ errflag=.true.
+ return
+ endif
+ keywd=line(istart:iend)
+ return
+ end
+ subroutine numstr(inum,numm)
+ character*10 huj /'0123456789'/
+ character*(*) numm
+ inumm=inum
+ inum1=inumm/10
+ inum2=inumm-10*inum1
+ inumm=inum1
+ numm(3:3)=huj(inum2+1:inum2+1)
+ inum1=inumm/10
+ inum2=inumm-10*inum1
+ inumm=inum1
+ numm(2:2)=huj(inum2+1:inum2+1)
+ inum1=inumm/10
+ inum2=inumm-10*inum1
+ inumm=inum1
+ numm(1:1)=huj(inum2+1:inum2+1)
+ return
+ end
+ character*(*) function ucase(string)
+ integer i, k, idiff
+ character*(*) string
+ character*1 c
+ character*40 chtmp
+c
+ i = len(ucase)
+ k = len(string)
+ if (i .lt. k) then
+ k = i
+ if (string(k+1:) .ne. ' ') then
+ chtmp = string
+ endif
+ endif
+ idiff = ichar('a') - ichar('A')
+ ucase = string
+ do 99 i = 1, k
+ c = string(i:i)
+ if (lge(c,'a') .and. lle(c,'z')) then
+ ucase(i:i) = char(ichar(c) - idiff)
+ endif
+ 99 continue
+ return
+ end
--- /dev/null
+ subroutine inertia_tensor
+c Calculating the intertia tensor for the entire protein in order to
+c remove the perpendicular components of velocity matrix which cause
+c the molecule to rotate.
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+
+ double precision Im(3,3),Imcp(3,3),cm(3),pr(3),M_SC,
+ & eigvec(3,3),Id(3,3),eigval(3),L(3),vp(3),vrot(3),
+ & vpp(3,0:MAXRES),vs_p(3),pr1(3,3),
+ & pr2(3,3),pp(3),incr(3),v(3),mag,mag2
+ common /gucio/ cm
+ integer iti,inres
+ do i=1,3
+ do j=1,3
+ Im(i,j)=0.0d0
+ pr1(i,j)=0.0d0
+ pr2(i,j)=0.0d0
+ enddo
+ L(i)=0.0d0
+ cm(i)=0.0d0
+ vrot(i)=0.0d0
+ enddo
+c calculating the center of the mass of the protein
+ do i=nnt,nct-1
+ do j=1,3
+ cm(j)=cm(j)+c(j,i)+0.5d0*dc(j,i)
+ enddo
+ enddo
+ do j=1,3
+ cm(j)=mp*cm(j)
+ enddo
+ M_SC=0.0d0
+ do i=nnt,nct
+ iti=itype(i)
+ M_SC=M_SC+msc(iti)
+ inres=i+nres
+ do j=1,3
+ cm(j)=cm(j)+msc(iti)*c(j,inres)
+ enddo
+ enddo
+ do j=1,3
+ cm(j)=cm(j)/(M_SC+(nct-nnt)*mp)
+ enddo
+
+ do i=nnt,nct-1
+ do j=1,3
+ pr(j)=c(j,i)+0.5d0*dc(j,i)-cm(j)
+ enddo
+ Im(1,1)=Im(1,1)+mp*(pr(2)*pr(2)+pr(3)*pr(3))
+ Im(1,2)=Im(1,2)-mp*pr(1)*pr(2)
+ Im(1,3)=Im(1,3)-mp*pr(1)*pr(3)
+ Im(2,3)=Im(2,3)-mp*pr(2)*pr(3)
+ Im(2,2)=Im(2,2)+mp*(pr(3)*pr(3)+pr(1)*pr(1))
+ Im(3,3)=Im(3,3)+mp*(pr(1)*pr(1)+pr(2)*pr(2))
+ enddo
+
+ do i=nnt,nct
+ iti=itype(i)
+ inres=i+nres
+ do j=1,3
+ pr(j)=c(j,inres)-cm(j)
+ enddo
+ Im(1,1)=Im(1,1)+msc(iti)*(pr(2)*pr(2)+pr(3)*pr(3))
+ Im(1,2)=Im(1,2)-msc(iti)*pr(1)*pr(2)
+ Im(1,3)=Im(1,3)-msc(iti)*pr(1)*pr(3)
+ Im(2,3)=Im(2,3)-msc(iti)*pr(2)*pr(3)
+ Im(2,2)=Im(2,2)+msc(iti)*(pr(3)*pr(3)+pr(1)*pr(1))
+ Im(3,3)=Im(3,3)+msc(iti)*(pr(1)*pr(1)+pr(2)*pr(2))
+ enddo
+
+ do i=nnt,nct-1
+ Im(1,1)=Im(1,1)+Ip*(1-dc_norm(1,i)*dc_norm(1,i))*
+ & vbld(i+1)*vbld(i+1)*0.25d0
+ Im(1,2)=Im(1,2)+Ip*(-dc_norm(1,i)*dc_norm(2,i))*
+ & vbld(i+1)*vbld(i+1)*0.25d0
+ Im(1,3)=Im(1,3)+Ip*(-dc_norm(1,i)*dc_norm(3,i))*
+ & vbld(i+1)*vbld(i+1)*0.25d0
+ Im(2,3)=Im(2,3)+Ip*(-dc_norm(2,i)*dc_norm(3,i))*
+ & vbld(i+1)*vbld(i+1)*0.25d0
+ Im(2,2)=Im(2,2)+Ip*(1-dc_norm(2,i)*dc_norm(2,i))*
+ & vbld(i+1)*vbld(i+1)*0.25d0
+ Im(3,3)=Im(3,3)+Ip*(1-dc_norm(3,i)*dc_norm(3,i))*
+ & vbld(i+1)*vbld(i+1)*0.25d0
+ enddo
+
+
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ iti=itype(i)
+ inres=i+nres
+ Im(1,1)=Im(1,1)+Isc(iti)*(1-dc_norm(1,inres)*
+ & dc_norm(1,inres))*vbld(inres)*vbld(inres)
+ Im(1,2)=Im(1,2)-Isc(iti)*(dc_norm(1,inres)*
+ & dc_norm(2,inres))*vbld(inres)*vbld(inres)
+ Im(1,3)=Im(1,3)-Isc(iti)*(dc_norm(1,inres)*
+ & dc_norm(3,inres))*vbld(inres)*vbld(inres)
+ Im(2,3)=Im(2,3)-Isc(iti)*(dc_norm(2,inres)*
+ & dc_norm(3,inres))*vbld(inres)*vbld(inres)
+ Im(2,2)=Im(2,2)+Isc(iti)*(1-dc_norm(2,inres)*
+ & dc_norm(2,inres))*vbld(inres)*vbld(inres)
+ Im(3,3)=Im(3,3)+Isc(iti)*(1-dc_norm(3,inres)*
+ & dc_norm(3,inres))*vbld(inres)*vbld(inres)
+ endif
+ enddo
+
+ call angmom(cm,L)
+c write(iout,*) "The angular momentum before adjustment:"
+c write(iout,*) (L(j),j=1,3)
+
+ Im(2,1)=Im(1,2)
+ Im(3,1)=Im(1,3)
+ Im(3,2)=Im(2,3)
+
+c Copying the Im matrix for the djacob subroutine
+ do i=1,3
+ do j=1,3
+ Imcp(i,j)=Im(i,j)
+ Id(i,j)=0.0d0
+ enddo
+ enddo
+
+c Finding the eigenvectors and eignvalues of the inertia tensor
+ call djacob(3,3,10000,1.0d-10,Imcp,eigvec,eigval)
+c write (iout,*) "Eigenvalues & Eigenvectors"
+c write (iout,'(5x,3f10.5)') (eigval(i),i=1,3)
+c write (iout,*)
+c do i=1,3
+c write (iout,'(i5,3f10.5)') i,(eigvec(i,j),j=1,3)
+c enddo
+c Constructing the diagonalized matrix
+ do i=1,3
+ if (dabs(eigval(i)).gt.1.0d-15) then
+ Id(i,i)=1.0d0/eigval(i)
+ else
+ Id(i,i)=0.0d0
+ endif
+ enddo
+ do i=1,3
+ do j=1,3
+ Imcp(i,j)=eigvec(j,i)
+ enddo
+ enddo
+ do i=1,3
+ do j=1,3
+ do k=1,3
+ pr1(i,j)=pr1(i,j)+Id(i,k)*Imcp(k,j)
+ enddo
+ enddo
+ enddo
+ do i=1,3
+ do j=1,3
+ do k=1,3
+ pr2(i,j)=pr2(i,j)+eigvec(i,k)*pr1(k,j)
+ enddo
+ enddo
+ enddo
+c Calculating the total rotational velocity of the molecule
+ do i=1,3
+ do j=1,3
+ vrot(i)=vrot(i)+pr2(i,j)*L(j)
+ enddo
+ enddo
+c Resetting the velocities
+ do i=nnt,nct-1
+ call vecpr(vrot(1),dc(1,i),vp)
+ do j=1,3
+ d_t(j,i)=d_t(j,i)-vp(j)
+ enddo
+ enddo
+ do i=nnt,nct
+ if(itype(i).ne.10) then
+ inres=i+nres
+ call vecpr(vrot(1),dc(1,inres),vp)
+ do j=1,3
+ d_t(j,inres)=d_t(j,inres)-vp(j)
+ enddo
+ endif
+ enddo
+ call angmom(cm,L)
+c write(iout,*) "The angular momentum after adjustment:"
+c write(iout,*) (L(j),j=1,3)
+ return
+ end
+c----------------------------------------------------------------------------
+ subroutine angmom(cm,L)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+
+ double precision L(3),cm(3),pr(3),vp(3),vrot(3),incr(3),v(3),
+ & pp(3)
+ integer iti,inres
+c Calculate the angular momentum
+ do j=1,3
+ L(j)=0.0d0
+ enddo
+ do j=1,3
+ incr(j)=d_t(j,0)
+ enddo
+ do i=nnt,nct-1
+ do j=1,3
+ pr(j)=c(j,i)+0.5d0*dc(j,i)-cm(j)
+ enddo
+ do j=1,3
+ v(j)=incr(j)+0.5d0*d_t(j,i)
+ enddo
+ do j=1,3
+ incr(j)=incr(j)+d_t(j,i)
+ enddo
+ call vecpr(pr(1),v(1),vp)
+ do j=1,3
+ L(j)=L(j)+mp*vp(j)
+ enddo
+ do j=1,3
+ pr(j)=0.5d0*dc(j,i)
+ pp(j)=0.5d0*d_t(j,i)
+ enddo
+ call vecpr(pr(1),pp(1),vp)
+ do j=1,3
+ L(j)=L(j)+Ip*vp(j)
+ enddo
+ enddo
+ do j=1,3
+ incr(j)=d_t(j,0)
+ enddo
+ do i=nnt,nct
+ iti=itype(i)
+ inres=i+nres
+ do j=1,3
+ pr(j)=c(j,inres)-cm(j)
+ enddo
+ if (itype(i).ne.10) then
+ do j=1,3
+ v(j)=incr(j)+d_t(j,inres)
+ enddo
+ else
+ do j=1,3
+ v(j)=incr(j)
+ enddo
+ endif
+ call vecpr(pr(1),v(1),vp)
+c write (iout,*) "i",i," iti",iti," pr",(pr(j),j=1,3),
+c & " v",(v(j),j=1,3)," vp",(vp(j),j=1,3)
+ do j=1,3
+ L(j)=L(j)+msc(iti)*vp(j)
+ enddo
+c write (iout,*) "L",(l(j),j=1,3)
+ if (itype(i).ne.10) then
+ do j=1,3
+ v(j)=incr(j)+d_t(j,inres)
+ enddo
+ call vecpr(dc(1,inres),d_t(1,inres),vp)
+ do j=1,3
+ L(j)=L(j)+Isc(iti)*vp(j)
+ enddo
+ endif
+ do j=1,3
+ incr(j)=incr(j)+d_t(j,i)
+ enddo
+ enddo
+ return
+ end
+c------------------------------------------------------------------------------
+ subroutine vcm_vel(vcm)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ double precision vcm(3),vv(3),summas,amas
+ do j=1,3
+ vcm(j)=0.0d0
+ vv(j)=d_t(j,0)
+ enddo
+ summas=0.0d0
+ do i=nnt,nct
+ if (i.lt.nct) then
+ summas=summas+mp
+ do j=1,3
+ vcm(j)=vcm(j)+mp*(vv(j)+0.5d0*d_t(j,i))
+ enddo
+ endif
+ amas=msc(itype(i))
+ summas=summas+amas
+ if (itype(i).ne.10) then
+ do j=1,3
+ vcm(j)=vcm(j)+amas*(vv(j)+d_t(j,i+nres))
+ enddo
+ else
+ do j=1,3
+ vcm(j)=vcm(j)+amas*vv(j)
+ enddo
+ endif
+ do j=1,3
+ vv(j)=vv(j)+d_t(j,i)
+ enddo
+ enddo
+c write (iout,*) "vcm",(vcm(j),j=1,3)," summas",summas
+ do j=1,3
+ vcm(j)=vcm(j)/summas
+ enddo
+ return
+ end
--- /dev/null
+ subroutine muca_delta(remd_t_bath,remd_ene,i,iex,delta)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.MUCA'
+ include 'COMMON.MD'
+ double precision remd_t_bath(maxprocs)
+ double precision remd_ene(maxprocs)
+ double precision muca_ene
+ double precision betai,betaiex,delta
+
+ betai=1.0/(Rb*remd_t_bath(i))
+ betaiex=1.0/(Rb*remd_t_bath(iex))
+
+ delta=betai*(muca_ene(remd_ene(iex),i,remd_t_bath)-
+ & muca_ene(remd_ene(i),i,remd_t_bath))
+ & -betaiex*(muca_ene(remd_ene(iex),iex,remd_t_bath)-
+ & muca_ene(remd_ene(i),iex,remd_t_bath))
+
+ return
+ end
+
+ double precision function muca_ene(energy,i,remd_t_bath)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.MUCA'
+ include 'COMMON.MD'
+ double precision y,yp,energy
+ double precision remd_t_bath(maxprocs)
+ integer i
+
+ if (energy.lt.elowi(i)) then
+ call splint(emuca,nemuca,nemuca2,nmuca,elowi(i),y,yp)
+ muca_ene=remd_t_bath(i)*Rb*(yp*(energy-elowi(i))+y)
+ elseif (energy.gt.ehighi(i)) then
+ call splint(emuca,nemuca,nemuca2,nmuca,ehighi(i),y,yp)
+ muca_ene=remd_t_bath(i)*Rb*(yp*(energy-ehighi(i))+y)
+ else
+ call splint(emuca,nemuca,nemuca2,nmuca,energy,y,yp)
+ muca_ene=remd_t_bath(i)*Rb*y
+ endif
+ return
+ end
+
+ subroutine read_muca
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.MUCA'
+ include 'COMMON.CONTROL'
+ include 'COMMON.MD'
+ include 'COMMON.REMD'
+ include 'COMMON.SETUP'
+ include 'COMMON.IOUNITS'
+ double precision yp1,ypn,yp,x,muca_factor,y,muca_ene
+ imtime=0
+ do i=1,4*maxres
+ hist(i)=0
+ enddo
+ if (modecalc.eq.14.and..not.remd_tlist) then
+ print *,"MUCAREMD works only with TLIST"
+ stop
+ endif
+ open(89,file='muca.input')
+ read(89,*)
+ read(89,*)
+ if (modecalc.eq.14) then
+ read(89,*) (elowi(i),ehighi(i),i=1,nrep)
+ if (remd_mlist) then
+ k=0
+ do i=1,nrep
+ do j=1,remd_m(i)
+ i2rep(k)=i
+ k=k+1
+ enddo
+ enddo
+ elow=elowi(i2rep(me))
+ ehigh=ehighi(i2rep(me))
+ elowi(me+1)=elow
+ ehighi(me+1)=ehigh
+ else
+ elow=elowi(me+1)
+ ehigh=ehighi(me+1)
+ endif
+ else
+ read(89,*) elow,ehigh
+ elowi(1)=elow
+ ehighi(1)=ehigh
+ endif
+ i=0
+ do while(.true.)
+ i=i+1
+ read(89,*,end=100) emuca(i),nemuca(i)
+cd nemuca(i)=nemuca(i)*remd_t(me+1)*Rb
+ enddo
+ 100 continue
+ nmuca=i-1
+ hbin=emuca(nmuca)-emuca(nmuca-1)
+ write (iout,*) 'hbin',hbin
+ write (iout,*) me,'elow,ehigh',elow,ehigh
+ yp1=0
+ ypn=0
+ call spline(emuca,nemuca,nmuca,yp1,ypn,nemuca2)
+ factor_min=0.0d0
+ factor_min=muca_factor(ehigh)
+ call print_muca
+ return
+ end
+
+
+ subroutine print_muca
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.MUCA'
+ include 'COMMON.CONTROL'
+ include 'COMMON.MD'
+ include 'COMMON.REMD'
+ include 'COMMON.SETUP'
+ include 'COMMON.IOUNITS'
+ double precision yp1,ypn,yp,x,muca_factor,y,muca_ene
+ double precision dummy(maxprocs)
+
+ if (remd_mlist) then
+ k=0
+ do i=1,nrep
+ do j=1,remd_m(i)
+ i2rep(k)=i
+ k=k+1
+ enddo
+ enddo
+ endif
+
+ do i=1,nmuca
+c print *,'nemuca ',emuca(i),nemuca(i)
+ do j=0,4
+ x=emuca(i)+hbin/5*j
+ if (modecalc.eq.14) then
+ if (remd_mlist) then
+ yp=muca_factor(x)*remd_t(i2rep(me))*Rb
+ dummy(me+1)=remd_t(i2rep(me))
+ y=muca_ene(x,me+1,dummy)
+ else
+ yp=muca_factor(x)*remd_t(me+1)*Rb
+ y=muca_ene(x,me+1,remd_t)
+ endif
+ write (iout,'(i4,i12,a12,2f15.5,a10,f15.5)') me,imtime,
+ & 'muca factor ',x,yp,' muca ene',y
+ else
+ yp=muca_factor(x)*t_bath*Rb
+ dummy(1)=t_bath
+ y=muca_ene(x,1,dummy)
+ write (iout,'(i4,i12,a12,2f15.5,a10,f15.5)') me,imtime,
+ & 'muca factor ',x,yp,' muca ene',y
+ endif
+ enddo
+ enddo
+ if(mucadyn.gt.0) then
+ do i=1,nmuca
+ write(iout,'(a13,i8,2f12.5)') 'nemuca after ',
+ & imtime,emuca(i),nemuca(i)
+ enddo
+ endif
+ return
+ end
+
+ subroutine muca_update(energy)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.MUCA'
+ include 'COMMON.CONTROL'
+ include 'COMMON.MD'
+ include 'COMMON.REMD'
+ include 'COMMON.SETUP'
+ include 'COMMON.IOUNITS'
+ double precision energy
+ double precision yp1,ypn
+ integer k
+ logical lnotend
+
+ k=int((energy-emuca(1))/hbin)+1
+
+ IF(muca_smooth.eq.1.or.muca_smooth.eq.3) THEN
+ if(energy.ge.ehigh)
+ & write (iout,*) 'MUCA reject',energy,emuca(k)
+ if(energy.ge.ehigh.and.(energy-ehigh).lt.hbin) then
+ write (iout,*) 'MUCA ehigh',energy,emuca(k)
+ do i=k,nmuca
+ hist(i)=hist(i)+1
+ enddo
+ endif
+ if(k.gt.0.and.energy.lt.ehigh) hist(k)=hist(k)+1
+ ELSE
+ if(k.gt.0.and.k.lt.4*maxres) hist(k)=hist(k)+1
+ ENDIF
+ if(mod(imtime,mucadyn).eq.0) then
+
+ do i=1,nmuca
+ IF(muca_smooth.eq.2.or.muca_smooth.eq.3) THEN
+ nemuca(i)=nemuca(i)+dlog(hist(i)+1)
+ ELSE
+ if (hist(i).gt.0) hist(i)=dlog(hist(i))
+ nemuca(i)=nemuca(i)+hist(i)
+ ENDIF
+ hist(i)=0
+ write(iout,'(a24,i8,2f12.5)')'nemuca before smoothing ',
+ & imtime,emuca(i),nemuca(i)
+ enddo
+
+
+ lnotend=.true.
+ ismooth=0
+ ist=2
+ ien=nmuca-1
+ IF(muca_smooth.eq.1.or.muca_smooth.eq.3) THEN
+c lnotend=.false.
+c do i=1,nmuca-1
+c do j=i+1,nmuca
+c if(nemuca(j).lt.nemuca(i)) lnotend=.true.
+c enddo
+c enddo
+ do while(lnotend)
+ ismooth=ismooth+1
+ write (iout,*) 'MUCA update smoothing',ist,ien
+ do i=ist,ien
+ nemuca(i)=(nemuca(i-1)+nemuca(i)+nemuca(i+1))/3
+ enddo
+ lnotend=.false.
+ ist=0
+ ien=0
+ do i=1,nmuca-1
+ do j=i+1,nmuca
+ if(nemuca(j).lt.nemuca(i)) then
+ lnotend=.true.
+ if(ist.eq.0) ist=i-1
+ if(ien.lt.j+1) ien=j+1
+ endif
+ enddo
+ enddo
+ enddo
+ ENDIF
+
+ write (iout,*) 'MUCA update ',imtime,' smooth= ',ismooth
+ yp1=0
+ ypn=0
+ call spline(emuca,nemuca,nmuca,yp1,ypn,nemuca2)
+ call print_muca
+
+ endif
+ return
+ end
+
+ double precision function muca_factor(energy)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.MUCA'
+ double precision y,yp,energy
+
+ if (energy.lt.elow) then
+ call splint(emuca,nemuca,nemuca2,nmuca,elow,y,yp)
+ elseif (energy.gt.ehigh) then
+ call splint(emuca,nemuca,nemuca2,nmuca,ehigh,y,yp)
+ else
+ call splint(emuca,nemuca,nemuca2,nmuca,energy,y,yp)
+ endif
+
+ if(yp.ge.factor_min) then
+ muca_factor=yp
+ else
+ muca_factor=factor_min
+ endif
+cd print *,'energy, muca_factor',energy,muca_factor
+ return
+ end
+
+
+ SUBROUTINE spline(x,y,n,yp1,ypn,y2)
+ INTEGER n,NMAX
+ REAL*8 yp1,ypn,x(n),y(n),y2(n)
+ PARAMETER (NMAX=500)
+ INTEGER i,k
+ REAL*8 p,qn,sig,un,u(NMAX)
+ if (yp1.gt..99e30) then
+ y2(1)=0.
+ u(1)=0.
+ else
+ y2(1)=-0.5
+ u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
+ endif
+ do i=2,n-1
+ sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
+ p=sig*y2(i-1)+2.
+ y2(i)=(sig-1.)/p
+ u(i)=(6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1))
+ * /(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p
+ enddo
+ if (ypn.gt..99e30) then
+ qn=0.
+ un=0.
+ else
+ qn=0.5
+ un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
+ endif
+ y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.)
+ do k=n-1,1,-1
+ y2(k)=y2(k)*y2(k+1)+u(k)
+ enddo
+ return
+ END
+
+
+ SUBROUTINE splint(xa,ya,y2a,n,x,y,yp)
+ INTEGER n
+ REAL*8 x,y,xa(n),y2a(n),ya(n),yp
+ INTEGER k,khi,klo
+ REAL*8 a,b,h
+ klo=1
+ khi=n
+ 1 if (khi-klo.gt.1) then
+ k=(khi+klo)/2
+ if (xa(k).gt.x) then
+ khi=k
+ else
+ klo=k
+ endif
+ goto 1
+ endif
+ h=xa(khi)-xa(klo)
+ if (h.eq.0.) pause 'bad xa input in splint'
+ a=(xa(khi)-x)/h
+ b=(x-xa(klo))/h
+ y=a*ya(klo)+b*ya(khi)+
+ * ((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6.
+ yp=-ya(klo)/h+ya(khi)/h-3*(a**2)*y2a(klo)*h/6.
+ + +(3*(b**2)-1)*y2a(khi)*h/6.
+ return
+ END
--- /dev/null
+ subroutine parmread
+C
+C Read the parameters of the probability distributions of the virtual-bond
+C valence angles and the side chains and energy parameters.
+C
+C Important! Energy-term weights ARE NOT read here; they are read from the
+C main input file instead, because NO defaults have yet been set for these
+C parameters.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include "mpif.h"
+ integer IERROR
+#endif
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.TORSION'
+ include 'COMMON.SCCOR'
+ include 'COMMON.SCROT'
+ include 'COMMON.FFIELD'
+ include 'COMMON.NAMES'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.MD'
+ include 'COMMON.SETUP'
+ character*1 t1,t2,t3
+ character*1 onelett(4) /"G","A","P","D"/
+ logical lprint,LaTeX
+ dimension blower(3,3,maxlob)
+ dimension b(13)
+ character*3 lancuch,ucase
+C
+C For printing parameters after they are read set the following in the UNRES
+C C-shell script:
+C
+C setenv PRINT_PARM YES
+C
+C To print parameters in LaTeX format rather than as ASCII tables:
+C
+C setenv LATEX YES
+C
+ call getenv_loc("PRINT_PARM",lancuch)
+ lprint = (ucase(lancuch).eq."YES" .or. ucase(lancuch).eq."Y")
+ call getenv_loc("LATEX",lancuch)
+ LaTeX = (ucase(lancuch).eq."YES" .or. ucase(lancuch).eq."Y")
+C
+ dwa16=2.0d0**(1.0d0/6.0d0)
+ itypro=20
+C Assign virtual-bond length
+ vbl=3.8D0
+ vblinv=1.0D0/vbl
+ vblinv2=vblinv*vblinv
+c
+c Read the virtual-bond parameters, masses, and moments of inertia
+c and Stokes' radii of the peptide group and side chains
+c
+#ifdef CRYST_BOND
+ read (ibond,*) vbldp0,akp,mp,ip,pstok
+ do i=1,ntyp
+ nbondterm(i)=1
+ read (ibond,*) 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,*) junk,vbldp0,akp,rjunk,mp,ip,pstok
+ do i=1,ntyp
+ read (ibond,*) 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/)')"Dynamic constants of the interaction sites:"
+ write (iout,'(a10,a3,6a10)') 'Type','N','VBL','K','A0','mass',
+ & 'inertia','Pstok'
+ write(iout,'(a10,i3,6f10.5)') "p",1,vbldp0,akp,0.0d0,mp,ip,pstok
+ do i=1,ntyp
+ write (iout,'(a10,i3,6f10.5)') restyp(i),nbondterm(i),
+ & vbldsc0(1,i),aksc(1,i),abond0(1,i),msc(i),isc(i),restok(i)
+ do j=2,nbondterm(i)
+ write (iout,'(13x,3f10.5)')
+ & vbldsc0(j,i),aksc(j,i),abond0(j,i)
+ enddo
+ enddo
+ endif
+#ifdef CRYST_THETA
+C
+C Read the parameters of the probability distribution/energy expression
+C of the virtual-bond valence angles theta
+C
+ do i=1,ntyp
+ read (ithep,*,err=111,end=111) a0thet(i),(athet(j,i),j=1,2),
+ & (bthet(j,i),j=1,2)
+ read (ithep,*,err=111,end=111) (polthet(j,i),j=0,3)
+ read (ithep,*,err=111,end=111) (gthet(j,i),j=1,3)
+ read (ithep,*,err=111,end=111) theta0(i),sig0(i),sigc0(i)
+ sigc0(i)=sigc0(i)**2
+ enddo
+ close (ithep)
+ if (lprint) then
+ if (.not.LaTeX) then
+ write (iout,'(a)')
+ & 'Parameters of the virtual-bond valence angles:'
+ write (iout,'(/a/9x,5a/79(1h-))') 'Fourier coefficients:',
+ & ' ATHETA0 ',' A1 ',' A2 ',
+ & ' B1 ',' B2 '
+ do i=1,ntyp
+ write(iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i,
+ & a0thet(i),(athet(j,i),j=1,2),(bthet(j,i),j=1,2)
+ enddo
+ write (iout,'(/a/9x,5a/79(1h-))')
+ & 'Parameters of the expression for sigma(theta_c):',
+ & ' ALPH0 ',' ALPH1 ',' ALPH2 ',
+ & ' ALPH3 ',' SIGMA0C '
+ do i=1,ntyp
+ write (iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i,
+ & (polthet(j,i),j=0,3),sigc0(i)
+ enddo
+ write (iout,'(/a/9x,5a/79(1h-))')
+ & 'Parameters of the second gaussian:',
+ & ' THETA0 ',' SIGMA0 ',' G1 ',
+ & ' G2 ',' G3 '
+ do i=1,ntyp
+ write (iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i,theta0(i),
+ & sig0(i),(gthet(j,i),j=1,3)
+ enddo
+ else
+ write (iout,'(a)')
+ & 'Parameters of the virtual-bond valence angles:'
+ write (iout,'(/a/9x,5a/79(1h-))')
+ & 'Coefficients of expansion',
+ & ' theta0 ',' a1*10^2 ',' a2*10^2 ',
+ & ' b1*10^1 ',' b2*10^1 '
+ do i=1,ntyp
+ write(iout,'(a3,1h&,2x,5(f8.3,1h&))') restyp(i),
+ & a0thet(i),(100*athet(j,i),j=1,2),(10*bthet(j,i),j=1,2)
+ enddo
+ write (iout,'(/a/9x,5a/79(1h-))')
+ & 'Parameters of the expression for sigma(theta_c):',
+ & ' alpha0 ',' alph1 ',' alph2 ',
+ & ' alhp3 ',' sigma0c '
+ do i=1,ntyp
+ write (iout,'(a3,1h&,2x,5(1pe12.3,1h&))') restyp(i),
+ & (polthet(j,i),j=0,3),sigc0(i)
+ enddo
+ write (iout,'(/a/9x,5a/79(1h-))')
+ & 'Parameters of the second gaussian:',
+ & ' theta0 ',' sigma0*10^2 ',' G1*10^-1',
+ & ' G2 ',' G3*10^1 '
+ do i=1,ntyp
+ write (iout,'(a3,1h&,2x,5(f8.3,1h&))') restyp(i),theta0(i),
+ & 100*sig0(i),gthet(1,i)*0.1D0,gthet(2,i),gthet(3,i)*10.0D0
+ enddo
+ endif
+ endif
+#else
+C
+C Read the parameters of Utheta determined from ab initio surfaces
+C Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
+C
+ read (ithep,*,err=111,end=111) nthetyp,ntheterm,ntheterm2,
+ & ntheterm3,nsingle,ndouble
+ nntheterm=max0(ntheterm,ntheterm2,ntheterm3)
+ read (ithep,*,err=111,end=111) (ithetyp(i),i=1,ntyp1)
+ do i=1,maxthetyp
+ do j=1,maxthetyp
+ do k=1,maxthetyp
+ aa0thet(i,j,k)=0.0d0
+ do l=1,ntheterm
+ aathet(l,i,j,k)=0.0d0
+ enddo
+ do l=1,ntheterm2
+ do m=1,nsingle
+ bbthet(m,l,i,j,k)=0.0d0
+ ccthet(m,l,i,j,k)=0.0d0
+ ddthet(m,l,i,j,k)=0.0d0
+ eethet(m,l,i,j,k)=0.0d0
+ enddo
+ enddo
+ do l=1,ntheterm3
+ do m=1,ndouble
+ do mm=1,ndouble
+ ffthet(mm,m,l,i,j,k)=0.0d0
+ ggthet(mm,m,l,i,j,k)=0.0d0
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ do i=1,nthetyp
+ do j=1,nthetyp
+ do k=1,nthetyp
+ read (ithep,'(3a)',end=111,err=111) res1,res2,res3
+ read (ithep,*,end=111,err=111) aa0thet(i,j,k)
+ read (ithep,*,end=111,err=111)(aathet(l,i,j,k),l=1,ntheterm)
+ read (ithep,*,end=111,err=111)
+ & ((bbthet(lll,ll,i,j,k),lll=1,nsingle),
+ & (ccthet(lll,ll,i,j,k),lll=1,nsingle),
+ & (ddthet(lll,ll,i,j,k),lll=1,nsingle),
+ & (eethet(lll,ll,i,j,k),lll=1,nsingle),ll=1,ntheterm2)
+ read (ithep,*,end=111,err=111)
+ & (((ffthet(llll,lll,ll,i,j,k),ffthet(lll,llll,ll,i,j,k),
+ & ggthet(llll,lll,ll,i,j,k),ggthet(lll,llll,ll,i,j,k),
+ & llll=1,lll-1),lll=2,ndouble),ll=1,ntheterm3)
+ enddo
+ enddo
+ enddo
+C
+C For dummy ends assign glycine-type coefficients of theta-only terms; the
+C coefficients of theta-and-gamma-dependent terms are zero.
+C
+ do i=1,nthetyp
+ do j=1,nthetyp
+ do l=1,ntheterm
+ aathet(l,i,j,nthetyp+1)=aathet(l,i,j,1)
+ aathet(l,nthetyp+1,i,j)=aathet(l,1,i,j)
+ enddo
+ aa0thet(i,j,nthetyp+1)=aa0thet(i,j,1)
+ aa0thet(nthetyp+1,i,j)=aa0thet(1,i,j)
+ enddo
+ do l=1,ntheterm
+ aathet(l,nthetyp+1,i,nthetyp+1)=aathet(l,1,i,1)
+ enddo
+ aa0thet(nthetyp+1,i,nthetyp+1)=aa0thet(1,i,1)
+ enddo
+C
+C Control printout of the coefficients of virtual-bond-angle potentials
+C
+ if (lprint) then
+ write (iout,'(//a)') 'Parameter of virtual-bond-angle potential'
+ do i=1,nthetyp+1
+ do j=1,nthetyp+1
+ do k=1,nthetyp+1
+ write (iout,'(//4a)')
+ & 'Type ',onelett(i),onelett(j),onelett(k)
+ write (iout,'(//a,10x,a)') " l","a[l]"
+ write (iout,'(i2,1pe15.5)') 0,aa0thet(i,j,k)
+ write (iout,'(i2,1pe15.5)')
+ & (l,aathet(l,i,j,k),l=1,ntheterm)
+ do l=1,ntheterm2
+ write (iout,'(//2h m,4(9x,a,3h[m,,i1,1h]))')
+ & "b",l,"c",l,"d",l,"e",l
+ do m=1,nsingle
+ write (iout,'(i2,4(1pe15.5))') m,
+ & bbthet(m,l,i,j,k),ccthet(m,l,i,j,k),
+ & ddthet(m,l,i,j,k),eethet(m,l,i,j,k)
+ enddo
+ enddo
+ do l=1,ntheterm3
+ write (iout,'(//3hm,n,4(6x,a,5h[m,n,,i1,1h]))')
+ & "f+",l,"f-",l,"g+",l,"g-",l
+ do m=2,ndouble
+ do n=1,m-1
+ write (iout,'(i1,1x,i1,4(1pe15.5))') n,m,
+ & ffthet(n,m,l,i,j,k),ffthet(m,n,l,i,j,k),
+ & ggthet(n,m,l,i,j,k),ggthet(m,n,l,i,j,k)
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ enddo
+ call flush(iout)
+ endif
+ write (2,*) "Start reading THETA_PDB"
+ do i=1,ntyp
+ read (ithep_pdb,*,err=111,end=111) a0thet(i),(athet(j,i),j=1,2),
+ & (bthet(j,i),j=1,2)
+ read (ithep_pdb,*,err=111,end=111) (polthet(j,i),j=0,3)
+ read (ithep_pdb,*,err=111,end=111) (gthet(j,i),j=1,3)
+ read (ithep_pdb,*,err=111,end=111) theta0(i),sig0(i),sigc0(i)
+ sigc0(i)=sigc0(i)**2
+ enddo
+ write (2,*) "End reading THETA_PDB"
+ close (ithep_pdb)
+#endif
+ close(ithep)
+#ifdef CRYST_SC
+C
+C Read the parameters of the probability distribution/energy expression
+C of the side chains.
+C
+ do i=1,ntyp
+ read (irotam,'(3x,i3,f8.3)',end=112,err=112) nlob(i),dsc(i)
+ if (i.eq.10) then
+ dsc_inv(i)=0.0D0
+ else
+ dsc_inv(i)=1.0D0/dsc(i)
+ endif
+ if (i.ne.10) then
+ do j=1,nlob(i)
+ do k=1,3
+ do l=1,3
+ blower(l,k,j)=0.0D0
+ enddo
+ enddo
+ enddo
+ bsc(1,i)=0.0D0
+ read(irotam,*,end=112,err=112)(censc(k,1,i),k=1,3),
+ & ((blower(k,l,1),l=1,k),k=1,3)
+ do j=2,nlob(i)
+ read (irotam,*,end=112,err=112) bsc(j,i)
+ read (irotam,*,end=112,err=112) (censc(k,j,i),k=1,3),
+ & ((blower(k,l,j),l=1,k),k=1,3)
+ enddo
+ do j=1,nlob(i)
+ do k=1,3
+ do l=1,k
+ akl=0.0D0
+ do m=1,3
+ akl=akl+blower(k,m,j)*blower(l,m,j)
+ enddo
+ gaussc(k,l,j,i)=akl
+ gaussc(l,k,j,i)=akl
+ enddo
+ enddo
+ enddo
+ endif
+ enddo
+ close (irotam)
+ if (lprint) then
+ write (iout,'(/a)') 'Parameters of side-chain local geometry'
+ do i=1,ntyp
+ nlobi=nlob(i)
+ if (nlobi.gt.0) then
+ if (LaTeX) then
+ write (iout,'(/3a,i2,a,f8.3)') 'Residue type: ',restyp(i),
+ & ' # of gaussian lobes:',nlobi,' dsc:',dsc(i)
+ 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)
+ 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
+ else
+ write (iout,'(/a,8x,i1,4(25x,i1))') 'Lobe:',(j,j=1,nlobi)
+ write (iout,'(a,f10.4,4(16x,f10.4))')
+ & 'Center ',(bsc(j,i),j=1,nlobi)
+ write (iout,'(5(2x,3f8.4))') ((censc(k,j,i),k=1,3),
+ & j=1,nlobi)
+ write (iout,'(a)')
+ endif
+ 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
+C
+C Read the parameters of the probability distribution/energy expression
+C of the side chains.
+C
+ do i=1,ntyp
+ read (irotam_pdb,'(3x,i3,f8.3)',end=112,err=112) nlob(i),dsc(i)
+ if (i.eq.10) then
+ dsc_inv(i)=0.0D0
+ else
+ dsc_inv(i)=1.0D0/dsc(i)
+ endif
+ if (i.ne.10) then
+ do j=1,nlob(i)
+ do k=1,3
+ do l=1,3
+ blower(l,k,j)=0.0D0
+ enddo
+ enddo
+ enddo
+ bsc(1,i)=0.0D0
+ read(irotam_pdb,*,end=112,err=112)(censc(k,1,i),k=1,3),
+ & ((blower(k,l,1),l=1,k),k=1,3)
+ do j=2,nlob(i)
+ read (irotam_pdb,*,end=112,err=112) bsc(j,i)
+ read (irotam_pdb,*,end=112,err=112) (censc(k,j,i),k=1,3),
+ & ((blower(k,l,j),l=1,k),k=1,3)
+ enddo
+ do j=1,nlob(i)
+ do k=1,3
+ do l=1,k
+ akl=0.0D0
+ do m=1,3
+ akl=akl+blower(k,m,j)*blower(l,m,j)
+ enddo
+ gaussc(k,l,j,i)=akl
+ gaussc(l,k,j,i)=akl
+ enddo
+ enddo
+ enddo
+ endif
+ enddo
+ close (irotam_pdb)
+#endif
+ close(irotam)
+
+#ifdef CRYST_TOR
+C
+C Read torsional parameters in old format
+C
+ read (itorp,*,end=113,err=113) ntortyp,nterm_old
+ if (lprint)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)')
+ do k=1,nterm_old
+ read (itorp,*,end=113,err=113) kk,v1(k,j,i),v2(k,j,i)
+ enddo
+ enddo
+ enddo
+ close (itorp)
+ if (lprint) then
+ write (iout,'(/a/)') 'Torsional constants:'
+ do i=1,ntortyp
+ do j=1,ntortyp
+ write (iout,'(2i3,6f10.5)') i,j,(v1(k,i,j),k=1,nterm_old)
+ write (iout,'(6x,6f10.5)') (v2(k,i,j),k=1,nterm_old)
+ enddo
+ enddo
+ endif
+#else
+C
+C Read torsional parameters
+C
+ read (itorp,*,end=113,err=113) ntortyp
+ read (itorp,*,end=113,err=113) (itortyp(i),i=1,ntyp)
+c write (iout,*) 'ntortyp',ntortyp
+ do i=1,ntortyp
+ do j=1,ntortyp
+ read (itorp,*,end=113,err=113) nterm(i,j),nlor(i,j)
+ v0ij=0.0d0
+ si=-1.0d0
+ do k=1,nterm(i,j)
+ read (itorp,*,end=113,err=113) kk,v1(k,i,j),v2(k,i,j)
+ v0ij=v0ij+si*v1(k,i,j)
+ si=-si
+ enddo
+ do k=1,nlor(i,j)
+ read (itorp,*,end=113,err=113) kk,vlor1(k,i,j),
+ & vlor2(k,i,j),vlor3(k,i,j)
+ v0ij=v0ij+vlor1(k,i,j)/(1+vlor3(k,i,j)**2)
+ enddo
+ v0(i,j)=v0ij
+ enddo
+ enddo
+ close (itorp)
+ if (lprint) then
+ write (iout,'(/a/)') 'Torsional constants:'
+ do i=1,ntortyp
+ do j=1,ntortyp
+ write (iout,*) 'ityp',i,' jtyp',j
+ write (iout,*) 'Fourier constants'
+ do k=1,nterm(i,j)
+ write (iout,'(2(1pe15.5))') v1(k,i,j),v2(k,i,j)
+ enddo
+ write (iout,*) 'Lorenz constants'
+ do k=1,nlor(i,j)
+ write (iout,'(3(1pe15.5))')
+ & vlor1(k,i,j),vlor2(k,i,j),vlor3(k,i,j)
+ enddo
+ enddo
+ enddo
+ endif
+C
+C 6/23/01 Read parameters for double torsionals
+C
+ do i=1,ntortyp
+ do j=1,ntortyp
+ do k=1,ntortyp
+ read (itordp,'(3a1)',end=114,err=114) t1,t2,t3
+ if (t1.ne.onelett(i) .or. t2.ne.onelett(j)
+ & .or. t3.ne.onelett(k)) then
+ write (iout,*) "Error in double torsional parameter file",
+ & i,j,k,t1,t2,t3
+#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),
+ & ntermd_2(i,j,k)
+ read (itordp,*,end=114,err=114) (v1c(1,l,i,j,k),l=1,
+ & ntermd_1(i,j,k))
+ read (itordp,*,end=114,err=114) (v1s(1,l,i,j,k),l=1,
+ & ntermd_1(i,j,k))
+ read (itordp,*,end=114,err=114) (v1c(2,l,i,j,k),l=1,
+ & ntermd_1(i,j,k))
+ read (itordp,*,end=114,err=114) (v1s(2,l,i,j,k),l=1,
+ & ntermd_1(i,j,k))
+ read (itordp,*,end=114,err=114) ((v2c(l,m,i,j,k),
+ & v2c(m,l,i,j,k),v2s(l,m,i,j,k),v2s(m,l,i,j,k),
+ & m=1,l-1),l=1,ntermd_2(i,j,k))
+ enddo
+ enddo
+ enddo
+ if (lprint) then
+ write (iout,*)
+ write (iout,*) 'Constants for double torsionals'
+ do i=1,ntortyp
+ do j=1,ntortyp
+ do k=1,ntortyp
+ write (iout,*) 'ityp',i,' jtyp',j,' ktyp',k,
+ & ' nsingle',ntermd_1(i,j,k),' ndouble',ntermd_2(i,j,k)
+ write (iout,*)
+ write (iout,*) 'Single angles:'
+ do l=1,ntermd_1(i,j,k)
+ write (iout,'(i5,2f10.5,5x,2f10.5)') l,
+ & v1c(1,l,i,j,k),v1s(1,l,i,j,k),
+ & v1c(2,l,i,j,k),v1s(2,l,i,j,k)
+ enddo
+ write (iout,*)
+ write (iout,*) 'Pairs of angles:'
+ write (iout,'(3x,20i10)') (l,l=1,ntermd_2(i,j,k))
+ do l=1,ntermd_2(i,j,k)
+ write (iout,'(i5,20f10.5)')
+ & l,(v2c(l,m,i,j,k),m=1,ntermd_2(i,j,k))
+ enddo
+ write (iout,*)
+ write (iout,'(3x,20i10)') (l,l=1,ntermd_2(i,j,k))
+ do l=1,ntermd_2(i,j,k)
+ write (iout,'(i5,20f10.5)')
+ & l,(v2s(l,m,i,j,k),m=1,ntermd_2(i,j,k))
+ enddo
+ write (iout,*)
+ enddo
+ enddo
+ enddo
+ endif
+#endif
+C Read of Side-chain backbone correlation parameters
+C Modified 11 May 2012 by Adasko
+CCC
+C
+ read (isccor,*,end=113,err=113) nsccortyp
+ read (isccor,*,end=113,err=113) (isccortyp(i),i=1,ntyp)
+c write (iout,*) 'ntortyp',ntortyp
+ maxinter=3
+cc maxinter is maximum interaction sites
+ do l=1,maxinter
+ do i=1,nsccortyp
+ do j=1,nsccortyp
+ read (isccor,*,end=113,err=113) nterm_sccor(i,j),nlor_sccor(i,j)
+ v0ijsccor=0.0d0
+ si=-1.0d0
+
+ do k=1,nterm_sccor(i,j)
+ read (isccor,*,end=113,err=113) kk,v1sccor(k,l,i,j)
+ & ,v2sccor(k,l,i,j)
+ v0ijsccor=v0ijsccor+si*v1sccor(k,l,i,j)
+ si=-si
+ enddo
+ do k=1,nlor_sccor(i,j)
+ read (isccor,*,end=113,err=113) kk,vlor1sccor(k,i,j),
+ & vlor2sccor(k,i,j),vlor3sccor(k,i,j)
+ v0ijsccor=v0ijsccor+vlor1sccor(k,i,j)/
+ &(1+vlor3sccor(k,i,j)**2)
+ enddo
+ v0sccor(i,j)=v0ijsccor
+ enddo
+ enddo
+ enddo
+ close (isccor)
+
+ if (lprint) then
+ write (iout,'(/a/)') 'Torsional constants:'
+ do i=1,nsccortyp
+ do j=1,nsccortyp
+ write (iout,*) 'ityp',i,' jtyp',j
+ write (iout,*) 'Fourier constants'
+ do k=1,nterm_sccor(i,j)
+ write (iout,'(2(1pe15.5))') v1sccor(k,l,i,j),v2sccor(k,l,i,j)
+ enddo
+ write (iout,*) 'Lorenz constants'
+ do k=1,nlor_sccor(i,j)
+ write (iout,'(3(1pe15.5))')
+ & vlor1sccor(k,i,j),vlor2sccor(k,i,j),vlor3sccor(k,i,j)
+ enddo
+ enddo
+ enddo
+ endif
+C
+C
+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
+ if (lprint) then
+ write (iout,*)
+ write (iout,*) "Coefficients of the cumulants"
+ endif
+ read (ifourier,*) nloctyp
+ do i=1,nloctyp
+ read (ifourier,*,end=115,err=115)
+ read (ifourier,*,end=115,err=115) (b(ii),ii=1,13)
+ if (lprint) then
+ write (iout,*) 'Type',i
+ write (iout,'(a,i2,a,f10.5)') ('b(',ii,')=',b(ii),ii=1,13)
+ endif
+ B1(1,i) = b(3)
+ B1(2,i) = b(5)
+c b1(1,i)=0.0d0
+c b1(2,i)=0.0d0
+ B1tilde(1,i) = b(3)
+ B1tilde(2,i) =-b(5)
+c b1tilde(1,i)=0.0d0
+c b1tilde(2,i)=0.0d0
+ B2(1,i) = b(2)
+ B2(2,i) = b(4)
+c b2(1,i)=0.0d0
+c b2(2,i)=0.0d0
+ CC(1,1,i)= b(7)
+ CC(2,2,i)=-b(7)
+ CC(2,1,i)= b(9)
+ CC(1,2,i)= b(9)
+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
+ Ctilde(1,1,i)=b(7)
+ Ctilde(1,2,i)=b(9)
+ Ctilde(2,1,i)=-b(9)
+ Ctilde(2,2,i)=b(7)
+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
+ DD(1,1,i)= b(6)
+ DD(2,2,i)=-b(6)
+ DD(2,1,i)= b(8)
+ DD(1,2,i)= b(8)
+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
+ Dtilde(1,1,i)=b(6)
+ Dtilde(1,2,i)=b(8)
+ Dtilde(2,1,i)=-b(8)
+ Dtilde(2,2,i)=b(6)
+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
+ EE(1,1,i)= b(10)+b(11)
+ EE(2,2,i)=-b(10)+b(11)
+ EE(2,1,i)= b(12)-b(13)
+ EE(1,2,i)= b(12)+b(13)
+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
+ do i=1,nloctyp
+ write (iout,*) 'Type',i
+ write (iout,*) 'B1'
+ write(iout,*) B1(1,i),B1(2,i)
+ write (iout,*) 'B2'
+ write(iout,*) B2(1,i),B2(2,i)
+ write (iout,*) 'CC'
+ do j=1,2
+ write (iout,'(2f10.5)') CC(j,1,i),CC(j,2,i)
+ enddo
+ write(iout,*) 'DD'
+ do j=1,2
+ write (iout,'(2f10.5)') DD(j,1,i),DD(j,2,i)
+ enddo
+ write(iout,*) 'EE'
+ do j=1,2
+ write (iout,'(2f10.5)') EE(j,1,i),EE(j,2,i)
+ enddo
+ enddo
+ endif
+C
+C Read electrostatic-interaction parameters
+C
+ if (lprint) then
+ write (iout,*)
+ 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.'
+#ifdef MPI
+ call MPI_Finalize(Ierror)
+#endif
+ stop
+ endif
+ expon2=expon/2
+ if(me.eq.king)
+ & 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=116,err=116)((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=116,err=116)((eps(i,j),j=i,ntyp),i=1,ntyp),
+ & (sigma0(i),i=1,ntyp),(rr0(i),i=1,ntyp)
+ if (lprint) then
+ write (iout,'(/a/)') 'Parameters of the LJK potential:'
+ write (iout,'(a/)') 'The epsilon array:'
+ call printmat(ntyp,ntyp,ntyp,iout,restyp,eps)
+ write (iout,'(/a)') 'One-body parameters:'
+ write (iout,'(a,4x,2a)') 'residue',' sigma ',' r0 '
+ write (iout,'(a3,6x,2f10.5)') (restyp(i),sigma0(i),rr0(i),
+ & i=1,ntyp)
+ endif
+ goto 50
+C---------------------- GB or BP potential -----------------------------
+ 30 read (isidep,*,end=116,err=116)((eps(i,j),j=i,ntyp),i=1,ntyp),
+ & (sigma0(i),i=1,ntyp),(sigii(i),i=1,ntyp),(chip(i),i=1,ntyp),
+ & (alp(i),i=1,ntyp)
+C For the GB potential convert sigma'**2 into chi'
+ if (ipot.eq.4) then
+ do i=1,ntyp
+ chip(i)=(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=116,err=116)((eps(i,j),j=i,ntyp),i=1,ntyp),
+ & (sigma0(i),i=1,ntyp),(rr0(i),i=1,ntyp),(sigii(i),i=1,ntyp),
+ & (chip(i),i=1,ntyp),(alp(i),i=1,ntyp)
+ if (lprint) then
+ write (iout,'(/a/)') 'Parameters of the GBV potential:'
+ write (iout,'(a/)') 'The epsilon array:'
+ call printmat(ntyp,ntyp,ntyp,iout,restyp,eps)
+ write (iout,'(/a)') 'One-body parameters:'
+ write (iout,'(a,4x,5a)') 'residue',' sigma ',' r0 ',
+ & 's||/s_|_^2',' chip ',' alph '
+ write (iout,'(a3,6x,5f10.5)') (restyp(i),sigma0(i),rr0(i),
+ & sigii(i),chip(i),alp(i),i=1,ntyp)
+ endif
+ 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)
+ 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)
+ 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(i,j)=epsij*rrij*rrij
+ bb(i,j)=-sigeps*epsij*rrij
+ aa(j,i)=aa(i,j)
+ bb(j,i)=bb(i,j)
+ if (ipot.gt.2) 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(i,j),bb(i,j),augm(i,j),
+ & sigma(i,j),r0(i,j),chi(i,j),chi(j,i)
+ endif
+ enddo
+ enddo
+#ifdef OLDSCP
+C
+C Define the SC-p interaction constants (hard-coded; old style)
+C
+ do i=1,20
+C "Soft" SC-p repulsion (causes helices to be too flat, but facilitates
+C helix formation)
+c aad(i,1)=0.3D0*4.0D0**12
+C Following line for constants currently implemented
+C "Hard" SC-p repulsion (gives correct turn spacing in helices)
+ aad(i,1)=1.5D0*4.0D0**12
+c aad(i,1)=0.17D0*5.6D0**12
+ aad(i,2)=aad(i,1)
+C "Soft" SC-p repulsion
+ bad(i,1)=0.0D0
+C Following line for constants currently implemented
+c aad(i,1)=0.3D0*4.0D0**6
+C "Hard" SC-p repulsion
+ bad(i,1)=3.0D0*4.0D0**6
+c bad(i,1)=-2.0D0*0.17D0*5.6D0**6
+ bad(i,2)=bad(i,1)
+c aad(i,1)=0.0D0
+c aad(i,2)=0.0D0
+c bad(i,1)=1228.8D0
+c bad(i,2)=1228.8D0
+ enddo
+#else
+C
+C 8/9/01 Read the SC-p interaction constants from file
+C
+ do i=1,ntyp
+ read (iscpp,*,end=118,err=118) (eps_scp(i,j),rscp(i,j),j=1,2)
+ enddo
+ do i=1,ntyp
+ aad(i,1)=dabs(eps_scp(i,1))*rscp(i,1)**12
+ aad(i,2)=dabs(eps_scp(i,2))*rscp(i,2)**12
+ bad(i,1)=-2*eps_scp(i,1)*rscp(i,1)**6
+ bad(i,2)=-2*eps_scp(i,2)*rscp(i,2)**6
+ enddo
+
+ if (lprint) then
+ write (iout,*) "Parameters of SC-p interactions:"
+ do i=1,20
+ write (iout,'(4f8.3,4e12.4)') eps_scp(i,1),rscp(i,1),
+ & eps_scp(i,2),rscp(i,2),aad(i,1),bad(i,1),aad(i,2),bad(i,2)
+ enddo
+ endif
+#endif
+C
+C Define the constants of the disulfide bridge
+C
+ ebr=-5.50D0
+c
+c Old arbitrary potential - commented out.
+c
+c dbr= 4.20D0
+c fbr= 3.30D0
+c
+c Constants of the disulfide-bond potential determined based on the RHF/6-31G**
+c energy surface of diethyl disulfide.
+c A. Liwo and U. Kozlowska, 11/24/03
+c
+ D0CM = 3.78d0
+ AKCM = 15.1d0
+ AKTH = 11.0d0
+ AKCT = 12.0d0
+ V1SS =-1.08d0
+ V2SS = 7.61d0
+ V3SS = 13.7d0
+c akcm=0.0d0
+c akth=0.0d0
+c akct=0.0d0
+c v1ss=0.0d0
+c v2ss=0.0d0
+c v3ss=0.0d0
+
+ if(me.eq.king) then
+ write (iout,'(/a)') "Disulfide bridge parameters:"
+ write (iout,'(a,f10.2)') 'S-S bridge energy: ',ebr
+ write (iout,'(2(a,f10.2))') 'd0cm:',d0cm,' akcm:',akcm
+ write (iout,'(2(a,f10.2))') 'akth:',akth,' akct:',akct
+ write (iout,'(3(a,f10.2))') 'v1ss:',v1ss,' v2ss:',v2ss,
+ & ' v3ss:',v3ss
+ endif
+ return
+ 111 write (iout,*) "Error reading bending energy parameters."
+ goto 999
+ 112 write (iout,*) "Error reading rotamer energy parameters."
+ goto 999
+ 113 write (iout,*) "Error reading torsional energy parameters."
+ goto 999
+ 114 write (iout,*) "Error reading double torsional energy parameters."
+ goto 999
+ 115 write (iout,*)
+ & "Error reading cumulant (multibody energy) parameters."
+ goto 999
+ 116 write (iout,*) "Error reading electrostatic energy parameters."
+ goto 999
+ 117 write (iout,*) "Error reading side chain interaction parameters."
+ goto 999
+ 118 write (iout,*) "Error reading SCp interaction parameters."
+ goto 999
+ 119 write (iout,*) "Error reading SCCOR parameters"
+ 999 continue
+#ifdef MPI
+ call MPI_Finalize(Ierror)
+#endif
+ stop
+ return
+ end
+
+
+ subroutine getenv_loc(var, val)
+ character(*) var, val
+
+#ifdef WINIFL
+ character(2000) line
+ external ilen
+
+ open (196,file='env',status='old',readonly,shared)
+ iread=0
+c write(*,*)'looking for ',var
+10 read(196,*,err=11,end=11)line
+ iread=index(line,var)
+c write(*,*)iread,' ',var,' ',line
+ if (iread.eq.0) go to 10
+c write(*,*)'---> ',line
+11 continue
+ if(iread.eq.0) then
+c write(*,*)'CHUJ'
+ val=''
+ else
+ iread=iread+ilen(var)+1
+ read (line(iread:),*,err=12,end=12) val
+c write(*,*)'OK: ',var,' = ',val
+ endif
+ close(196)
+ return
+12 val=''
+ close(196)
+#elif (defined CRAY)
+ integer lennam,lenval,ierror
+c
+c getenv using a POSIX call, useful on the T3D
+c Sept 1996, comment out error check on advice of H. Pritchard
+c
+ lennam = len(var)
+ if(lennam.le.0) stop '--error calling getenv--'
+ call pxfgetenv(var,lennam,val,lenval,ierror)
+c-HP- if(ierror.ne.0) stop '--error returned by pxfgetenv--'
+#else
+ call getenv(var,val)
+#endif
+
+ return
+ end
--- /dev/null
+ double precision function pinorm(x)
+ implicit real*8 (a-h,o-z)
+c
+c this function takes an angle (in radians) and puts it in the range of
+c -pi to +pi.
+c
+ integer n
+ include 'COMMON.GEO'
+ n = x / dwapi
+ pinorm = x - n * dwapi
+ if ( pinorm .gt. pi ) then
+ pinorm = pinorm - dwapi
+ else if ( pinorm .lt. - pi ) then
+ pinorm = pinorm + dwapi
+ end if
+ return
+ end
--- /dev/null
+ subroutine printmat(ldim,m,n,iout,key,a)
+ character*3 key(n)
+ double precision a(ldim,n)
+ do 1 i=1,n,8
+ nlim=min0(i+7,n)
+ write (iout,1000) (key(k),k=i,nlim)
+ write (iout,1020)
+ 1000 format (/5x,8(6x,a3))
+ 1020 format (/80(1h-)/)
+ do 2 j=1,n
+ write (iout,1010) key(j),(a(j,k),k=i,nlim)
+ 2 continue
+ 1 continue
+ 1010 format (a3,2x,8(f9.4))
+ return
+ end
--- /dev/null
+ real*8 function prng_next(me)
+ implicit none
+ integer me
+c
+c Calling sequence:
+c <new random number> = prng_next ( <ordinal of generator desired> )
+c <vector of random #s> = vprng ( <ordinal>, <vector>, <length> )
+c
+c This code is based on a sequential algorithm provided by Mal Kalos.
+c This version uses a single 64-bit word to store the initial seeds
+c and additive constants.
+c A 64-bit floating point number is returned.
+c
+c The array "iparam" is full-word aligned, being padded by zeros to
+c let each generator be on a subpage boundary.
+c That is, rows 1 and 2 in a given column of the array are for real,
+c rows 3-16 are bogus.
+c
+c July 12, 1993: double the number of sequences. We should have been
+c using two packets per seed, rather than four
+c October 31, 1993: merge the two arrays of seeds and constants,
+c and switch to 64-bit arithmetic.
+c June 1994: port to RS6K. Internal state is kept as 2 64-bit integers
+c The ishft function is defined only on 32-bit integers, so we will
+c shift numbers by dividing by 2**11 and then adding on 2**53-1.
+c
+c November 1994: ishift now works on 64-bit numbers (though it gives a
+c warning). Thus we go back to using it. John Zollweg also added the
+c vprng() routine to return vectors of real*8 random numbers.
+c
+ real*8 recip53
+ parameter ( recip53 = 2.0D0**(-53) )
+ integer*8 two
+ parameter ( two = 2**11)
+ integer*8 m,ishift
+c parameter ( m = 34522712143931 ) ! 11**13
+c parameter ( ishift = 9007199254740991 ) ! 2**53-1
+
+ integer nmax
+ integer*8 iparam
+ parameter(nmax=1021)
+ common/ksrprng/iparam(2,0:nmax)
+
+ integer*8 next
+
+crc g77 doesn't support integer*8 constants
+ m = dint(34522712143931.0d0)
+ ishift = dint(9007199254740991.0d0)
+
+c RS6K porting note: ishift now takes 64-bit integers , with a warning
+ if ( 0.le.me .and. me.le.nmax ) then
+ next = iparam(1,me)*m + iparam(2,me)
+ iparam(1,me) = next
+ prng_next = recip53 * ishft( next, -11 )
+ else
+ prng_next=-1.0D0
+ endif
+
+ end
+c
+c vprng(me, rn, num) Get a vector of random numbers
+c
+ subroutine vprng(me,rn,num)
+ real*8 recip53, rn(1)
+ parameter ( recip53 = 2.0D0**(-53) )
+ integer*8 m,iparam
+c parameter ( m = 34522712143931 ) ! 11**13
+ integer nmax, num, me
+ parameter(nmax=1021)
+ common/ksrprng/iparam(2,0:nmax)
+
+ integer*8 next
+
+crc g77 doesn't support integer*8 constants
+ m = dint(34522712143931.0d0)
+
+ if ( 0.le.me .and. me.le.nmax ) then
+ do 1 i=1,num
+ next = iparam(1,me)*m + iparam(2,me)
+ iparam(1,me) = next
+ rn(i) = recip53 * ishft( next, -11 )
+ 1 continue
+ else
+ rn(1)=-1.0D0
+ endif
+ return
+ end
+
+c
+c prng_chkpnt Get the current state of a generator
+c
+c Calling sequence:
+c logical prng_chkpnt, status
+c status = prng_chkpnt (me, iseed) where
+c
+c me is the particular generator whose state is being gotten
+c seed is an 4-element integer array where the "l"-values will be saved
+c
+ logical function prng_chkpnt (me, iseed)
+ implicit none
+ integer me
+ integer*8 iseed
+
+ integer nmax
+ integer*8 iparam
+ parameter(nmax=1021)
+ common/ksrprng/iparam(2,0:nmax)
+
+ if (me .lt. 0 .or. me .gt. nmax) then
+ prng_chkpnt=.false.
+ else
+ prng_chkpnt=.true.
+ iseed=iparam(1,me)
+ endif
+ end
+c
+c prng_restart Restart generator from a saved state
+c
+c Calling sequence:
+c logical prng_restart, status
+c status = prng_restart (me, iseed) where
+c
+c me is the particular generator being restarted
+c iseed is a 8-byte integer containing the "l"-values
+c
+ logical function prng_restart (me, iseed)
+ implicit none
+ integer me
+ integer*8 iseed
+
+ integer nmax
+ integer*8 iparam
+ parameter(nmax=1021)
+ common/ksrprng/iparam(2,0:nmax)
+
+ if (me .lt. 0 .or. me .gt. nmax) then
+ prng_restart=.false.
+ return
+ else
+ prng_restart=.true.
+ iparam(1,me)=iseed
+ endif
+ end
+
+ block data prngblk
+ parameter(nmax=1021)
+ integer*8 iparam
+ common/ksrprng/iparam(2,0:nmax)
+ data (iparam(1,i),iparam(2,i),i= 0, 29) /
+ + 11848219, 11848219, 11848237, 11848237, 11848241, 11848241,
+ + 11848247, 11848247, 11848253, 11848253, 11848271, 11848271,
+ + 11848297, 11848297, 11848313, 11848313, 11848339, 11848339,
+ + 11848351, 11848351, 11848357, 11848357, 11848363, 11848363,
+ + 11848367, 11848367, 11848373, 11848373, 11848379, 11848379,
+ + 11848393, 11848393, 11848433, 11848433, 11848451, 11848451,
+ + 11848469, 11848469, 11848477, 11848477, 11848489, 11848489,
+ + 11848493, 11848493, 11848513, 11848513, 11848523, 11848523,
+ + 11848531, 11848531, 11848537, 11848537, 11848553, 11848553,
+ + 11848589, 11848589, 11848591, 11848591, 11848601, 11848601 /
+ data (iparam(1,i),iparam(2,i),i= 30, 59) /
+ + 11848619, 11848619, 11848637, 11848637, 11848663, 11848663,
+ + 11848673, 11848673, 11848679, 11848679, 11848691, 11848691,
+ + 11848699, 11848699, 11848709, 11848709, 11848717, 11848717,
+ + 11848721, 11848721, 11848729, 11848729, 11848741, 11848741,
+ + 11848751, 11848751, 11848757, 11848757, 11848787, 11848787,
+ + 11848801, 11848801, 11848829, 11848829, 11848853, 11848853,
+ + 11848861, 11848861, 11848867, 11848867, 11848873, 11848873,
+ + 11848891, 11848891, 11848909, 11848909, 11848919, 11848919,
+ + 11848931, 11848931, 11848937, 11848937, 11848961, 11848961,
+ + 11848981, 11848981, 11849021, 11849021, 11849039, 11849039 /
+ data (iparam(1,i),iparam(2,i),i= 60, 89) /
+ + 11849053, 11849053, 11849059, 11849059, 11849069, 11849069,
+ + 11849077, 11849077, 11849087, 11849087, 11849093, 11849093,
+ + 11849107, 11849107, 11849111, 11849111, 11849129, 11849129,
+ + 11849137, 11849137, 11849177, 11849177, 11849183, 11849183,
+ + 11849203, 11849203, 11849231, 11849231, 11849237, 11849237,
+ + 11849239, 11849239, 11849249, 11849249, 11849251, 11849251,
+ + 11849269, 11849269, 11849273, 11849273, 11849291, 11849291,
+ + 11849297, 11849297, 11849309, 11849309, 11849339, 11849339,
+ + 11849359, 11849359, 11849363, 11849363, 11849399, 11849399,
+ + 11849401, 11849401, 11849413, 11849413, 11849417, 11849417 /
+ data (iparam(1,i),iparam(2,i),i= 90, 119) /
+ + 11849437, 11849437, 11849443, 11849443, 11849473, 11849473,
+ + 11849491, 11849491, 11849503, 11849503, 11849507, 11849507,
+ + 11849557, 11849557, 11849567, 11849567, 11849569, 11849569,
+ + 11849573, 11849573, 11849587, 11849587, 11849599, 11849599,
+ + 11849633, 11849633, 11849641, 11849641, 11849653, 11849653,
+ + 11849659, 11849659, 11849671, 11849671, 11849683, 11849683,
+ + 11849689, 11849689, 11849693, 11849693, 11849699, 11849699,
+ + 11849701, 11849701, 11849707, 11849707, 11849713, 11849713,
+ + 11849723, 11849723, 11849741, 11849741, 11849743, 11849743,
+ + 11849759, 11849759, 11849767, 11849767, 11849771, 11849771 /
+ data (iparam(1,i),iparam(2,i),i= 120, 149) /
+ + 11849791, 11849791, 11849801, 11849801, 11849809, 11849809,
+ + 11849813, 11849813, 11849869, 11849869, 11849881, 11849881,
+ + 11849891, 11849891, 11849909, 11849909, 11849923, 11849923,
+ + 11849933, 11849933, 11849947, 11849947, 11849987, 11849987,
+ + 11850001, 11850001, 11850011, 11850011, 11850019, 11850019,
+ + 11850023, 11850023, 11850031, 11850031, 11850049, 11850049,
+ + 11850061, 11850061, 11850073, 11850073, 11850077, 11850077,
+ + 11850103, 11850103, 11850109, 11850109, 11850121, 11850121,
+ + 11850127, 11850127, 11850133, 11850133, 11850149, 11850149,
+ + 11850161, 11850161, 11850169, 11850169, 11850191, 11850191 /
+ data (iparam(1,i),iparam(2,i),i= 150, 179) /
+ + 11850233, 11850233, 11850247, 11850247, 11850259, 11850259,
+ + 11850269, 11850269, 11850283, 11850283, 11850301, 11850301,
+ + 11850341, 11850341, 11850347, 11850347, 11850367, 11850367,
+ + 11850373, 11850373, 11850379, 11850379, 11850389, 11850389,
+ + 11850407, 11850407, 11850427, 11850427, 11850437, 11850437,
+ + 11850469, 11850469, 11850481, 11850481, 11850511, 11850511,
+ + 11850529, 11850529, 11850541, 11850541, 11850557, 11850557,
+ + 11850607, 11850607, 11850611, 11850611, 11850667, 11850667,
+ + 11850677, 11850677, 11850679, 11850679, 11850701, 11850701,
+ + 11850731, 11850731, 11850739, 11850739, 11850749, 11850749 /
+ data (iparam(1,i),iparam(2,i),i= 180, 209) /
+ + 11850791, 11850791, 11850803, 11850803, 11850829, 11850829,
+ + 11850833, 11850833, 11850859, 11850859, 11850877, 11850877,
+ + 11850899, 11850899, 11850907, 11850907, 11850913, 11850913,
+ + 11850919, 11850919, 11850931, 11850931, 11850941, 11850941,
+ + 11850947, 11850947, 11850953, 11850953, 11850961, 11850961,
+ + 11850983, 11850983, 11850991, 11850991, 11850997, 11850997,
+ + 11851031, 11851031, 11851033, 11851033, 11851051, 11851051,
+ + 11851061, 11851061, 11851067, 11851067, 11851093, 11851093,
+ + 11851109, 11851109, 11851123, 11851123, 11851127, 11851127,
+ + 11851139, 11851139, 11851157, 11851157, 11851163, 11851163 /
+ data (iparam(1,i),iparam(2,i),i= 210, 239) /
+ + 11851181, 11851181, 11851201, 11851201, 11851219, 11851219,
+ + 11851291, 11851291, 11851303, 11851303, 11851309, 11851309,
+ + 11851313, 11851313, 11851319, 11851319, 11851349, 11851349,
+ + 11851351, 11851351, 11851361, 11851361, 11851373, 11851373,
+ + 11851403, 11851403, 11851409, 11851409, 11851423, 11851423,
+ + 11851447, 11851447, 11851451, 11851451, 11851481, 11851481,
+ + 11851493, 11851493, 11851519, 11851519, 11851523, 11851523,
+ + 11851529, 11851529, 11851547, 11851547, 11851549, 11851549,
+ + 11851559, 11851559, 11851577, 11851577, 11851589, 11851589,
+ + 11851591, 11851591, 11851597, 11851597, 11851603, 11851603 /
+ data (iparam(1,i),iparam(2,i),i= 240, 269) /
+ + 11851607, 11851607, 11851613, 11851613, 11851621, 11851621,
+ + 11851627, 11851627, 11851639, 11851639, 11851673, 11851673,
+ + 11851681, 11851681, 11851727, 11851727, 11851753, 11851753,
+ + 11851759, 11851759, 11851787, 11851787, 11851793, 11851793,
+ + 11851799, 11851799, 11851813, 11851813, 11851841, 11851841,
+ + 11851859, 11851859, 11851867, 11851867, 11851891, 11851891,
+ + 11851909, 11851909, 11851919, 11851919, 11851927, 11851927,
+ + 11851933, 11851933, 11851949, 11851949, 11851967, 11851967,
+ + 11851997, 11851997, 11852017, 11852017, 11852051, 11852051,
+ + 11852053, 11852053, 11852059, 11852059, 11852083, 11852083 /
+ data (iparam(1,i),iparam(2,i),i= 270, 299) /
+ + 11852089, 11852089, 11852129, 11852129, 11852147, 11852147,
+ + 11852149, 11852149, 11852161, 11852161, 11852171, 11852171,
+ + 11852177, 11852177, 11852209, 11852209, 11852221, 11852221,
+ + 11852237, 11852237, 11852251, 11852251, 11852263, 11852263,
+ + 11852273, 11852273, 11852279, 11852279, 11852287, 11852287,
+ + 11852293, 11852293, 11852297, 11852297, 11852303, 11852303,
+ + 11852311, 11852311, 11852327, 11852327, 11852339, 11852339,
+ + 11852341, 11852341, 11852359, 11852359, 11852369, 11852369,
+ + 11852437, 11852437, 11852453, 11852453, 11852459, 11852459,
+ + 11852473, 11852473, 11852513, 11852513, 11852531, 11852531 /
+ data (iparam(1,i),iparam(2,i),i= 300, 329) /
+ + 11852537, 11852537, 11852539, 11852539, 11852557, 11852557,
+ + 11852573, 11852573, 11852579, 11852579, 11852591, 11852591,
+ + 11852609, 11852609, 11852611, 11852611, 11852623, 11852623,
+ + 11852641, 11852641, 11852647, 11852647, 11852657, 11852657,
+ + 11852663, 11852663, 11852717, 11852717, 11852719, 11852719,
+ + 11852741, 11852741, 11852759, 11852759, 11852767, 11852767,
+ + 11852773, 11852773, 11852803, 11852803, 11852807, 11852807,
+ + 11852809, 11852809, 11852831, 11852831, 11852833, 11852833,
+ + 11852837, 11852837, 11852857, 11852857, 11852873, 11852873,
+ + 11852879, 11852879, 11852891, 11852891, 11852917, 11852917 /
+ data (iparam(1,i),iparam(2,i),i= 330, 359) /
+ + 11852921, 11852921, 11852957, 11852957, 11852959, 11852959,
+ + 11852969, 11852969, 11852983, 11852983, 11852989, 11852989,
+ + 11853001, 11853001, 11853013, 11853013, 11853019, 11853019,
+ + 11853031, 11853031, 11853089, 11853089, 11853133, 11853133,
+ + 11853157, 11853157, 11853161, 11853161, 11853181, 11853181,
+ + 11853203, 11853203, 11853217, 11853217, 11853221, 11853221,
+ + 11853227, 11853227, 11853241, 11853241, 11853307, 11853307,
+ + 11853319, 11853319, 11853323, 11853323, 11853329, 11853329,
+ + 11853367, 11853367, 11853383, 11853383, 11853419, 11853419,
+ + 11853421, 11853421, 11853427, 11853427, 11853449, 11853449 /
+ data (iparam(1,i),iparam(2,i),i= 360, 389) /
+ + 11853451, 11853451, 11853463, 11853463, 11853529, 11853529,
+ + 11853557, 11853557, 11853571, 11853571, 11853601, 11853601,
+ + 11853613, 11853613, 11853617, 11853617, 11853629, 11853629,
+ + 11853649, 11853649, 11853659, 11853659, 11853679, 11853679,
+ + 11853689, 11853689, 11853719, 11853719, 11853731, 11853731,
+ + 11853757, 11853757, 11853761, 11853761, 11853773, 11853773,
+ + 11853791, 11853791, 11853817, 11853817, 11853839, 11853839,
+ + 11853847, 11853847, 11853857, 11853857, 11853869, 11853869,
+ + 11853883, 11853883, 11853887, 11853887, 11853889, 11853889,
+ + 11853893, 11853893, 11853899, 11853899, 11853911, 11853911 /
+ data (iparam(1,i),iparam(2,i),i= 390, 419) /
+ + 11853931, 11853931, 11853943, 11853943, 11853979, 11853979,
+ + 11853991, 11853991, 11854001, 11854001, 11854009, 11854009,
+ + 11854019, 11854019, 11854057, 11854057, 11854061, 11854061,
+ + 11854147, 11854147, 11854159, 11854159, 11854163, 11854163,
+ + 11854169, 11854169, 11854211, 11854211, 11854247, 11854247,
+ + 11854261, 11854261, 11854267, 11854267, 11854279, 11854279,
+ + 11854303, 11854303, 11854327, 11854327, 11854331, 11854331,
+ + 11854333, 11854333, 11854363, 11854363, 11854379, 11854379,
+ + 11854399, 11854399, 11854411, 11854411, 11854429, 11854429,
+ + 11854433, 11854433, 11854439, 11854439, 11854441, 11854441 /
+ data (iparam(1,i),iparam(2,i),i= 420, 449) /
+ + 11854463, 11854463, 11854477, 11854477, 11854489, 11854489,
+ + 11854517, 11854517, 11854519, 11854519, 11854523, 11854523,
+ + 11854529, 11854529, 11854567, 11854567, 11854571, 11854571,
+ + 11854573, 11854573, 11854603, 11854603, 11854607, 11854607,
+ + 11854681, 11854681, 11854691, 11854691, 11854709, 11854709,
+ + 11854723, 11854723, 11854757, 11854757, 11854783, 11854783,
+ + 11854793, 11854793, 11854813, 11854813, 11854847, 11854847,
+ + 11854853, 11854853, 11854873, 11854873, 11854877, 11854877,
+ + 11854883, 11854883, 11854891, 11854891, 11854897, 11854897,
+ + 11854901, 11854901, 11854919, 11854919, 11854937, 11854937 /
+ data (iparam(1,i),iparam(2,i),i= 450, 479) /
+ + 11854961, 11854961, 11854963, 11854963, 11854979, 11854979,
+ + 11855003, 11855003, 11855017, 11855017, 11855023, 11855023,
+ + 11855029, 11855029, 11855033, 11855033, 11855111, 11855111,
+ + 11855141, 11855141, 11855147, 11855147, 11855149, 11855149,
+ + 11855159, 11855159, 11855177, 11855177, 11855203, 11855203,
+ + 11855213, 11855213, 11855219, 11855219, 11855231, 11855231,
+ + 11855267, 11855267, 11855269, 11855269, 11855303, 11855303,
+ + 11855309, 11855309, 11855321, 11855321, 11855329, 11855329,
+ + 11855339, 11855339, 11855351, 11855351, 11855353, 11855353,
+ + 11855357, 11855357, 11855359, 11855359, 11855381, 11855381 /
+ data (iparam(1,i),iparam(2,i),i= 480, 509) /
+ + 11855383, 11855383, 11855387, 11855387, 11855399, 11855399,
+ + 11855407, 11855407, 11855413, 11855413, 11855489, 11855489,
+ + 11855491, 11855491, 11855507, 11855507, 11855521, 11855521,
+ + 11855531, 11855531, 11855549, 11855549, 11855551, 11855551,
+ + 11855567, 11855567, 11855581, 11855581, 11855587, 11855587,
+ + 11855593, 11855593, 11855633, 11855633, 11855653, 11855653,
+ + 11855663, 11855663, 11855687, 11855687, 11855689, 11855689,
+ + 11855699, 11855699, 11855713, 11855713, 11855731, 11855731,
+ + 11855737, 11855737, 11855743, 11855743, 11855747, 11855747,
+ + 11855759, 11855759, 11855773, 11855773, 11855801, 11855801 /
+ data (iparam(1,i),iparam(2,i),i= 510, 539) /
+ + 11855807, 11855807, 11855813, 11855813, 11855827, 11855827,
+ + 11855839, 11855839, 11855869, 11855869, 11855881, 11855881,
+ + 11855903, 11855903, 11855911, 11855911, 11855933, 11855933,
+ + 11855959, 11855959, 11855989, 11855989, 11855993, 11855993,
+ + 11855999, 11855999, 11856001, 11856001, 11856023, 11856023,
+ + 11856049, 11856049, 11856071, 11856071, 11856101, 11856101,
+ + 11856107, 11856107, 11856113, 11856113, 11856139, 11856139,
+ + 11856151, 11856151, 11856161, 11856161, 11856179, 11856179,
+ + 11856193, 11856193, 11856199, 11856199, 11856223, 11856223,
+ + 11856239, 11856239, 11856263, 11856263, 11856269, 11856269 /
+ data (iparam(1,i),iparam(2,i),i= 540, 569) /
+ + 11856281, 11856281, 11856287, 11856287, 11856307, 11856307,
+ + 11856311, 11856311, 11856329, 11856329, 11856343, 11856343,
+ + 11856359, 11856359, 11856371, 11856371, 11856373, 11856373,
+ + 11856409, 11856409, 11856419, 11856419, 11856461, 11856461,
+ + 11856469, 11856469, 11856473, 11856473, 11856479, 11856479,
+ + 11856511, 11856511, 11856517, 11856517, 11856541, 11856541,
+ + 11856547, 11856547, 11856553, 11856553, 11856583, 11856583,
+ + 11856629, 11856629, 11856641, 11856641, 11856653, 11856653,
+ + 11856659, 11856659, 11856673, 11856673, 11856697, 11856697,
+ + 11856709, 11856709, 11856727, 11856727, 11856731, 11856731 /
+ data (iparam(1,i),iparam(2,i),i= 570, 599) /
+ + 11856763, 11856763, 11856809, 11856809, 11856811, 11856811,
+ + 11856821, 11856821, 11856841, 11856841, 11856857, 11856857,
+ + 11856877, 11856877, 11856883, 11856883, 11856899, 11856899,
+ + 11856919, 11856919, 11856947, 11856947, 11856953, 11856953,
+ + 11856979, 11856979, 11857003, 11857003, 11857033, 11857033,
+ + 11857037, 11857037, 11857039, 11857039, 11857049, 11857049,
+ + 11857061, 11857061, 11857067, 11857067, 11857073, 11857073,
+ + 11857081, 11857081, 11857091, 11857091, 11857093, 11857093,
+ + 11857099, 11857099, 11857123, 11857123, 11857127, 11857127,
+ + 11857147, 11857147, 11857151, 11857151, 11857193, 11857193 /
+ data (iparam(1,i),iparam(2,i),i= 600, 629) /
+ + 11857217, 11857217, 11857229, 11857229, 11857243, 11857243,
+ + 11857249, 11857249, 11857267, 11857267, 11857277, 11857277,
+ + 11857291, 11857291, 11857303, 11857303, 11857309, 11857309,
+ + 11857327, 11857327, 11857331, 11857331, 11857333, 11857333,
+ + 11857361, 11857361, 11857367, 11857367, 11857369, 11857369,
+ + 11857393, 11857393, 11857399, 11857399, 11857409, 11857409,
+ + 11857421, 11857421, 11857423, 11857423, 11857451, 11857451,
+ + 11857453, 11857453, 11857457, 11857457, 11857477, 11857477,
+ + 11857481, 11857481, 11857493, 11857493, 11857499, 11857499,
+ + 11857519, 11857519, 11857523, 11857523, 11857529, 11857529 /
+ data (iparam(1,i),iparam(2,i),i= 630, 659) /
+ + 11857543, 11857543, 11857561, 11857561, 11857589, 11857589,
+ + 11857591, 11857591, 11857613, 11857613, 11857621, 11857621,
+ + 11857661, 11857661, 11857667, 11857667, 11857693, 11857693,
+ + 11857697, 11857697, 11857709, 11857709, 11857711, 11857711,
+ + 11857751, 11857751, 11857753, 11857753, 11857759, 11857759,
+ + 11857763, 11857763, 11857777, 11857777, 11857787, 11857787,
+ + 11857793, 11857793, 11857801, 11857801, 11857817, 11857817,
+ + 11857819, 11857819, 11857831, 11857831, 11857837, 11857837,
+ + 11857873, 11857873, 11857877, 11857877, 11857883, 11857883,
+ + 11857889, 11857889, 11857907, 11857907, 11857913, 11857913 /
+ data (iparam(1,i),iparam(2,i),i= 660, 689) /
+ + 11857931, 11857931, 11857969, 11857969, 11857991, 11857991,
+ + 11857999, 11857999, 11858009, 11858009, 11858017, 11858017,
+ + 11858023, 11858023, 11858029, 11858029, 11858039, 11858039,
+ + 11858051, 11858051, 11858057, 11858057, 11858059, 11858059,
+ + 11858101, 11858101, 11858111, 11858111, 11858131, 11858131,
+ + 11858149, 11858149, 11858159, 11858159, 11858177, 11858177,
+ + 11858191, 11858191, 11858201, 11858201, 11858227, 11858227,
+ + 11858243, 11858243, 11858267, 11858267, 11858269, 11858269,
+ + 11858279, 11858279, 11858281, 11858281, 11858291, 11858291,
+ + 11858311, 11858311, 11858323, 11858323, 11858359, 11858359 /
+ data (iparam(1,i),iparam(2,i),i= 690, 719) /
+ + 11858377, 11858377, 11858381, 11858381, 11858387, 11858387,
+ + 11858423, 11858423, 11858443, 11858443, 11858447, 11858447,
+ + 11858479, 11858479, 11858533, 11858533, 11858543, 11858543,
+ + 11858551, 11858551, 11858557, 11858557, 11858569, 11858569,
+ + 11858573, 11858573, 11858579, 11858579, 11858597, 11858597,
+ + 11858599, 11858599, 11858629, 11858629, 11858657, 11858657,
+ + 11858659, 11858659, 11858683, 11858683, 11858701, 11858701,
+ + 11858719, 11858719, 11858723, 11858723, 11858729, 11858729,
+ + 11858747, 11858747, 11858779, 11858779, 11858783, 11858783,
+ + 11858801, 11858801, 11858807, 11858807, 11858813, 11858813 /
+ data (iparam(1,i),iparam(2,i),i= 720, 749) /
+ + 11858839, 11858839, 11858851, 11858851, 11858893, 11858893,
+ + 11858897, 11858897, 11858921, 11858921, 11858947, 11858947,
+ + 11858953, 11858953, 11858969, 11858969, 11858971, 11858971,
+ + 11858989, 11858989, 11859017, 11859017, 11859031, 11859031,
+ + 11859049, 11859049, 11859061, 11859061, 11859073, 11859073,
+ + 11859077, 11859077, 11859079, 11859079, 11859083, 11859083,
+ + 11859101, 11859101, 11859109, 11859109, 11859137, 11859137,
+ + 11859139, 11859139, 11859151, 11859151, 11859157, 11859157,
+ + 11859163, 11859163, 11859167, 11859167, 11859179, 11859179,
+ + 11859187, 11859187, 11859229, 11859229, 11859233, 11859233 /
+ data (iparam(1,i),iparam(2,i),i= 750, 779) /
+ + 11859241, 11859241, 11859247, 11859247, 11859269, 11859269,
+ + 11859293, 11859293, 11859307, 11859307, 11859311, 11859311,
+ + 11859349, 11859349, 11859359, 11859359, 11859371, 11859371,
+ + 11859377, 11859377, 11859383, 11859383, 11859427, 11859427,
+ + 11859433, 11859433, 11859451, 11859451, 11859457, 11859457,
+ + 11859461, 11859461, 11859473, 11859473, 11859481, 11859481,
+ + 11859487, 11859487, 11859493, 11859493, 11859503, 11859503,
+ + 11859509, 11859509, 11859539, 11859539, 11859541, 11859541,
+ + 11859563, 11859563, 11859569, 11859569, 11859571, 11859571,
+ + 11859583, 11859583, 11859599, 11859599, 11859611, 11859611 /
+ data (iparam(1,i),iparam(2,i),i= 780, 809) /
+ + 11859643, 11859643, 11859707, 11859707, 11859713, 11859713,
+ + 11859719, 11859719, 11859739, 11859739, 11859751, 11859751,
+ + 11859791, 11859791, 11859817, 11859817, 11859821, 11859821,
+ + 11859833, 11859833, 11859847, 11859847, 11859853, 11859853,
+ + 11859877, 11859877, 11859889, 11859889, 11859893, 11859893,
+ + 11859901, 11859901, 11859907, 11859907, 11859917, 11859917,
+ + 11859923, 11859923, 11859929, 11859929, 11859961, 11859961,
+ + 11859979, 11859979, 11859989, 11859989, 11859997, 11859997,
+ + 11860021, 11860021, 11860031, 11860031, 11860039, 11860039,
+ + 11860049, 11860049, 11860081, 11860081, 11860087, 11860087 /
+ data (iparam(1,i),iparam(2,i),i= 810, 839) /
+ + 11860097, 11860097, 11860103, 11860103, 11860109, 11860109,
+ + 11860117, 11860117, 11860133, 11860133, 11860151, 11860151,
+ + 11860171, 11860171, 11860207, 11860207, 11860223, 11860223,
+ + 11860231, 11860231, 11860243, 11860243, 11860267, 11860267,
+ + 11860301, 11860301, 11860307, 11860307, 11860327, 11860327,
+ + 11860379, 11860379, 11860397, 11860397, 11860411, 11860411,
+ + 11860469, 11860469, 11860477, 11860477, 11860483, 11860483,
+ + 11860487, 11860487, 11860489, 11860489, 11860493, 11860493,
+ + 11860517, 11860517, 11860547, 11860547, 11860567, 11860567,
+ + 11860573, 11860573, 11860613, 11860613, 11860619, 11860619 /
+ data (iparam(1,i),iparam(2,i),i= 840, 869) /
+ + 11860627, 11860627, 11860637, 11860637, 11860643, 11860643,
+ + 11860649, 11860649, 11860661, 11860661, 11860669, 11860669,
+ + 11860687, 11860687, 11860691, 11860691, 11860697, 11860697,
+ + 11860699, 11860699, 11860703, 11860703, 11860727, 11860727,
+ + 11860741, 11860741, 11860753, 11860753, 11860777, 11860777,
+ + 11860787, 11860787, 11860789, 11860789, 11860811, 11860811,
+ + 11860837, 11860837, 11860859, 11860859, 11860867, 11860867,
+ + 11860889, 11860889, 11860897, 11860897, 11860963, 11860963,
+ + 11860969, 11860969, 11860973, 11860973, 11860993, 11860993,
+ + 11861011, 11861011, 11861033, 11861033, 11861071, 11861071 /
+ data (iparam(1,i),iparam(2,i),i= 870, 899) /
+ + 11861081, 11861081, 11861089, 11861089, 11861093, 11861093,
+ + 11861099, 11861099, 11861107, 11861107, 11861131, 11861131,
+ + 11861141, 11861141, 11861159, 11861159, 11861167, 11861167,
+ + 11861191, 11861191, 11861197, 11861197, 11861207, 11861207,
+ + 11861219, 11861219, 11861221, 11861221, 11861231, 11861231,
+ + 11861237, 11861237, 11861273, 11861273, 11861293, 11861293,
+ + 11861299, 11861299, 11861303, 11861303, 11861327, 11861327,
+ + 11861351, 11861351, 11861357, 11861357, 11861363, 11861363,
+ + 11861371, 11861371, 11861401, 11861401, 11861407, 11861407,
+ + 11861411, 11861411, 11861413, 11861413, 11861429, 11861429 /
+ data (iparam(1,i),iparam(2,i),i= 900, 929) /
+ + 11861441, 11861441, 11861467, 11861467, 11861527, 11861527,
+ + 11861539, 11861539, 11861543, 11861543, 11861557, 11861557,
+ + 11861569, 11861569, 11861573, 11861573, 11861579, 11861579,
+ + 11861581, 11861581, 11861599, 11861599, 11861611, 11861611,
+ + 11861617, 11861617, 11861627, 11861627, 11861639, 11861639,
+ + 11861651, 11861651, 11861659, 11861659, 11861671, 11861671,
+ + 11861683, 11861683, 11861687, 11861687, 11861693, 11861693,
+ + 11861701, 11861701, 11861711, 11861711, 11861713, 11861713,
+ + 11861749, 11861749, 11861791, 11861791, 11861803, 11861803,
+ + 11861819, 11861819, 11861827, 11861827, 11861849, 11861849 /
+ data (iparam(1,i),iparam(2,i),i= 930, 959) /
+ + 11861873, 11861873, 11861879, 11861879, 11861887, 11861887,
+ + 11861911, 11861911, 11861917, 11861917, 11861921, 11861921,
+ + 11861923, 11861923, 11861953, 11861953, 11861959, 11861959,
+ + 11861987, 11861987, 11862007, 11862007, 11862013, 11862013,
+ + 11862029, 11862029, 11862031, 11862031, 11862049, 11862049,
+ + 11862077, 11862077, 11862083, 11862083, 11862157, 11862157,
+ + 11862167, 11862167, 11862199, 11862199, 11862203, 11862203,
+ + 11862217, 11862217, 11862223, 11862223, 11862229, 11862229,
+ + 11862233, 11862233, 11862239, 11862239, 11862241, 11862241,
+ + 11862259, 11862259, 11862269, 11862269, 11862271, 11862271 /
+ data (iparam(1,i),iparam(2,i),i= 960, 989) /
+ + 11862293, 11862293, 11862307, 11862307, 11862313, 11862313,
+ + 11862317, 11862317, 11862343, 11862343, 11862353, 11862353,
+ + 11862373, 11862373, 11862391, 11862391, 11862439, 11862439,
+ + 11862469, 11862469, 11862493, 11862493, 11862527, 11862527,
+ + 11862547, 11862547, 11862563, 11862563, 11862569, 11862569,
+ + 11862577, 11862577, 11862581, 11862581, 11862611, 11862611,
+ + 11862623, 11862623, 11862661, 11862661, 11862673, 11862673,
+ + 11862679, 11862679, 11862701, 11862701, 11862703, 11862703,
+ + 11862713, 11862713, 11862761, 11862761, 11862791, 11862791,
+ + 11862803, 11862803, 11862839, 11862839, 11862841, 11862841 /
+ data (iparam(1,i),iparam(2,i),i= 990,1019) /
+ + 11862857, 11862857, 11862869, 11862869, 11862881, 11862881,
+ + 11862911, 11862911, 11862919, 11862919, 11862959, 11862959,
+ + 11862979, 11862979, 11862989, 11862989, 11862997, 11862997,
+ + 11863021, 11863021, 11863031, 11863031, 11863037, 11863037,
+ + 11863039, 11863039, 11863057, 11863057, 11863067, 11863067,
+ + 11863073, 11863073, 11863099, 11863099, 11863109, 11863109,
+ + 11863121, 11863121, 11863123, 11863123, 11863133, 11863133,
+ + 11863151, 11863151, 11863153, 11863153, 11863171, 11863171,
+ + 11863183, 11863183, 11863207, 11863207, 11863213, 11863213,
+ + 11863237, 11863237, 11863249, 11863249, 11863253, 11863253 /
+ data (iparam(1,i),iparam(2,i),i=1020,1021) /
+ + 11863259, 11863259, 11863279, 11863279 /
+ end
--- /dev/null
+#if defined(AIX) || defined(AMD64)
+ real*8 function prng_next(mel)
+ implicit none
+ integer me,mel
+c
+c Calling sequence:
+c <new random number> = prng_next ( <ordinal of generator desired> )
+c <vector of random #s> = vprng ( <ordinal>, <vector>, <length> )
+c
+c This code is based on a sequential algorithm provided by Mal Kalos.
+c This version uses a single 64-bit word to store the initial seeds
+c and additive constants.
+c A 64-bit floating point number is returned.
+c
+c The array "iparam" is full-word aligned, being padded by zeros to
+c let each generator be on a subpage boundary.
+c That is, rows 1 and 2 in a given column of the array are for real,
+c rows 3-16 are bogus.
+c
+c July 12, 1993: double the number of sequences. We should have been
+c using two packets per seed, rather than four
+c October 31, 1993: merge the two arrays of seeds and constants,
+c and switch to 64-bit arithmetic.
+c June 1994: port to RS6K. Internal state is kept as 2 64-bit integers
+c The ishft function is defined only on 32-bit integers, so we will
+c shift numbers by dividing by 2**11 and then adding on 2**53-1.
+c
+c November 1994: ishift now works on 64-bit numbers (though it gives a
+c warning). Thus we go back to using it. John Zollweg also added the
+c vprng() routine to return vectors of real*8 random numbers.
+c
+ real*8 recip53
+ parameter ( recip53 = 2.0D0**(-53) )
+ integer*8 two
+ parameter ( two = 2**11)
+ integer*8 m,ishift
+c parameter ( m = 34522712143931 ) ! 11**13
+c parameter ( ishift = 9007199254740991 ) ! 2**53-1
+
+ integer nmax
+ integer*8 iparam
+ parameter(nmax=1021)
+ common/ksrprng/iparam(2,0:nmax)
+
+ integer*8 next
+
+crc g77 doesn't support integer*8 constants
+ m = dint(34522712143931.0d0)
+ ishift = dint(9007199254740991.0d0)
+ if(mel.gt.nmax) then
+ me=mod(mel,nmax)
+ else
+ me=mel
+ endif
+c RS6K porting note: ishift now takes 64-bit integers , with a warning
+ if ( 0.le.me .and. me.le.nmax ) then
+ next = iparam(1,me)*m + iparam(2,me)
+ iparam(1,me) = next
+ prng_next = recip53 * ishft( next, -11 )
+ else
+ prng_next=-1.0D0
+ endif
+
+ end
+c
+c vprng(me, rn, num) Get a vector of random numbers
+c
+ subroutine vprng(me,rn,num)
+ real*8 recip53, rn(1)
+ parameter ( recip53 = 2.0D0**(-53) )
+ integer*8 m,iparam
+c parameter ( m = 34522712143931 ) ! 11**13
+ integer nmax, num, me
+ parameter(nmax=1021)
+ common/ksrprng/iparam(2,0:nmax)
+
+ integer*8 next
+
+crc g77 doesn't support integer*8 constants
+ m = dint(34522712143931.0d0)
+
+ if ( 0.le.me .and. me.le.nmax ) then
+ do 1 i=1,num
+ next = iparam(1,me)*m + iparam(2,me)
+ iparam(1,me) = next
+ rn(i) = recip53 * ishft( next, -11 )
+ 1 continue
+ else
+ rn(1)=-1.0D0
+ endif
+ return
+ end
+
+c
+c prng_chkpnt Get the current state of a generator
+c
+c Calling sequence:
+c logical prng_chkpnt, status
+c status = prng_chkpnt (me, iseed) where
+c
+c me is the particular generator whose state is being gotten
+c seed is an 4-element integer array where the "l"-values will be saved
+c
+ logical function prng_chkpnt (me, iseed)
+ implicit none
+ integer me
+ integer*8 iseed
+
+ integer nmax
+ integer*8 iparam
+ parameter(nmax=1021)
+ common/ksrprng/iparam(2,0:nmax)
+
+ if (me .lt. 0 .or. me .gt. nmax) then
+ prng_chkpnt=.false.
+ else
+ prng_chkpnt=.true.
+ iseed=iparam(1,me)
+ endif
+ end
+c
+c prng_restart Restart generator from a saved state
+c
+c Calling sequence:
+c logical prng_restart, status
+c status = prng_restart (me, iseed) where
+c
+c me is the particular generator being restarted
+c iseed is a 8-byte integer containing the "l"-values
+c
+ logical function prng_restart (mel, iseed)
+ implicit none
+ integer me,mel
+ integer*8 iseed
+
+ integer nmax
+ integer*8 iparam
+ parameter(nmax=1021)
+ common/ksrprng/iparam(2,0:nmax)
+
+ if(mel.gt.nmax) then
+ me=mod(mel,nmax)
+ else
+ me=mel
+ endif
+ if (me .lt. 0 .or. me .gt. nmax) then
+ prng_restart=.false.
+ return
+ else
+ prng_restart=.true.
+ iparam(1,me)=iseed
+ endif
+ end
+
+ block data prngblk
+ parameter(nmax=1021)
+ integer*8 iparam
+ common/ksrprng/iparam(2,0:nmax)
+ data (iparam(1,i),iparam(2,i),i= 0, 29) /
+ + 11848219, 11848219, 11848237, 11848237, 11848241, 11848241,
+ + 11848247, 11848247, 11848253, 11848253, 11848271, 11848271,
+ + 11848297, 11848297, 11848313, 11848313, 11848339, 11848339,
+ + 11848351, 11848351, 11848357, 11848357, 11848363, 11848363,
+ + 11848367, 11848367, 11848373, 11848373, 11848379, 11848379,
+ + 11848393, 11848393, 11848433, 11848433, 11848451, 11848451,
+ + 11848469, 11848469, 11848477, 11848477, 11848489, 11848489,
+ + 11848493, 11848493, 11848513, 11848513, 11848523, 11848523,
+ + 11848531, 11848531, 11848537, 11848537, 11848553, 11848553,
+ + 11848589, 11848589, 11848591, 11848591, 11848601, 11848601 /
+ data (iparam(1,i),iparam(2,i),i= 30, 59) /
+ + 11848619, 11848619, 11848637, 11848637, 11848663, 11848663,
+ + 11848673, 11848673, 11848679, 11848679, 11848691, 11848691,
+ + 11848699, 11848699, 11848709, 11848709, 11848717, 11848717,
+ + 11848721, 11848721, 11848729, 11848729, 11848741, 11848741,
+ + 11848751, 11848751, 11848757, 11848757, 11848787, 11848787,
+ + 11848801, 11848801, 11848829, 11848829, 11848853, 11848853,
+ + 11848861, 11848861, 11848867, 11848867, 11848873, 11848873,
+ + 11848891, 11848891, 11848909, 11848909, 11848919, 11848919,
+ + 11848931, 11848931, 11848937, 11848937, 11848961, 11848961,
+ + 11848981, 11848981, 11849021, 11849021, 11849039, 11849039 /
+ data (iparam(1,i),iparam(2,i),i= 60, 89) /
+ + 11849053, 11849053, 11849059, 11849059, 11849069, 11849069,
+ + 11849077, 11849077, 11849087, 11849087, 11849093, 11849093,
+ + 11849107, 11849107, 11849111, 11849111, 11849129, 11849129,
+ + 11849137, 11849137, 11849177, 11849177, 11849183, 11849183,
+ + 11849203, 11849203, 11849231, 11849231, 11849237, 11849237,
+ + 11849239, 11849239, 11849249, 11849249, 11849251, 11849251,
+ + 11849269, 11849269, 11849273, 11849273, 11849291, 11849291,
+ + 11849297, 11849297, 11849309, 11849309, 11849339, 11849339,
+ + 11849359, 11849359, 11849363, 11849363, 11849399, 11849399,
+ + 11849401, 11849401, 11849413, 11849413, 11849417, 11849417 /
+ data (iparam(1,i),iparam(2,i),i= 90, 119) /
+ + 11849437, 11849437, 11849443, 11849443, 11849473, 11849473,
+ + 11849491, 11849491, 11849503, 11849503, 11849507, 11849507,
+ + 11849557, 11849557, 11849567, 11849567, 11849569, 11849569,
+ + 11849573, 11849573, 11849587, 11849587, 11849599, 11849599,
+ + 11849633, 11849633, 11849641, 11849641, 11849653, 11849653,
+ + 11849659, 11849659, 11849671, 11849671, 11849683, 11849683,
+ + 11849689, 11849689, 11849693, 11849693, 11849699, 11849699,
+ + 11849701, 11849701, 11849707, 11849707, 11849713, 11849713,
+ + 11849723, 11849723, 11849741, 11849741, 11849743, 11849743,
+ + 11849759, 11849759, 11849767, 11849767, 11849771, 11849771 /
+ data (iparam(1,i),iparam(2,i),i= 120, 149) /
+ + 11849791, 11849791, 11849801, 11849801, 11849809, 11849809,
+ + 11849813, 11849813, 11849869, 11849869, 11849881, 11849881,
+ + 11849891, 11849891, 11849909, 11849909, 11849923, 11849923,
+ + 11849933, 11849933, 11849947, 11849947, 11849987, 11849987,
+ + 11850001, 11850001, 11850011, 11850011, 11850019, 11850019,
+ + 11850023, 11850023, 11850031, 11850031, 11850049, 11850049,
+ + 11850061, 11850061, 11850073, 11850073, 11850077, 11850077,
+ + 11850103, 11850103, 11850109, 11850109, 11850121, 11850121,
+ + 11850127, 11850127, 11850133, 11850133, 11850149, 11850149,
+ + 11850161, 11850161, 11850169, 11850169, 11850191, 11850191 /
+ data (iparam(1,i),iparam(2,i),i= 150, 179) /
+ + 11850233, 11850233, 11850247, 11850247, 11850259, 11850259,
+ + 11850269, 11850269, 11850283, 11850283, 11850301, 11850301,
+ + 11850341, 11850341, 11850347, 11850347, 11850367, 11850367,
+ + 11850373, 11850373, 11850379, 11850379, 11850389, 11850389,
+ + 11850407, 11850407, 11850427, 11850427, 11850437, 11850437,
+ + 11850469, 11850469, 11850481, 11850481, 11850511, 11850511,
+ + 11850529, 11850529, 11850541, 11850541, 11850557, 11850557,
+ + 11850607, 11850607, 11850611, 11850611, 11850667, 11850667,
+ + 11850677, 11850677, 11850679, 11850679, 11850701, 11850701,
+ + 11850731, 11850731, 11850739, 11850739, 11850749, 11850749 /
+ data (iparam(1,i),iparam(2,i),i= 180, 209) /
+ + 11850791, 11850791, 11850803, 11850803, 11850829, 11850829,
+ + 11850833, 11850833, 11850859, 11850859, 11850877, 11850877,
+ + 11850899, 11850899, 11850907, 11850907, 11850913, 11850913,
+ + 11850919, 11850919, 11850931, 11850931, 11850941, 11850941,
+ + 11850947, 11850947, 11850953, 11850953, 11850961, 11850961,
+ + 11850983, 11850983, 11850991, 11850991, 11850997, 11850997,
+ + 11851031, 11851031, 11851033, 11851033, 11851051, 11851051,
+ + 11851061, 11851061, 11851067, 11851067, 11851093, 11851093,
+ + 11851109, 11851109, 11851123, 11851123, 11851127, 11851127,
+ + 11851139, 11851139, 11851157, 11851157, 11851163, 11851163 /
+ data (iparam(1,i),iparam(2,i),i= 210, 239) /
+ + 11851181, 11851181, 11851201, 11851201, 11851219, 11851219,
+ + 11851291, 11851291, 11851303, 11851303, 11851309, 11851309,
+ + 11851313, 11851313, 11851319, 11851319, 11851349, 11851349,
+ + 11851351, 11851351, 11851361, 11851361, 11851373, 11851373,
+ + 11851403, 11851403, 11851409, 11851409, 11851423, 11851423,
+ + 11851447, 11851447, 11851451, 11851451, 11851481, 11851481,
+ + 11851493, 11851493, 11851519, 11851519, 11851523, 11851523,
+ + 11851529, 11851529, 11851547, 11851547, 11851549, 11851549,
+ + 11851559, 11851559, 11851577, 11851577, 11851589, 11851589,
+ + 11851591, 11851591, 11851597, 11851597, 11851603, 11851603 /
+ data (iparam(1,i),iparam(2,i),i= 240, 269) /
+ + 11851607, 11851607, 11851613, 11851613, 11851621, 11851621,
+ + 11851627, 11851627, 11851639, 11851639, 11851673, 11851673,
+ + 11851681, 11851681, 11851727, 11851727, 11851753, 11851753,
+ + 11851759, 11851759, 11851787, 11851787, 11851793, 11851793,
+ + 11851799, 11851799, 11851813, 11851813, 11851841, 11851841,
+ + 11851859, 11851859, 11851867, 11851867, 11851891, 11851891,
+ + 11851909, 11851909, 11851919, 11851919, 11851927, 11851927,
+ + 11851933, 11851933, 11851949, 11851949, 11851967, 11851967,
+ + 11851997, 11851997, 11852017, 11852017, 11852051, 11852051,
+ + 11852053, 11852053, 11852059, 11852059, 11852083, 11852083 /
+ data (iparam(1,i),iparam(2,i),i= 270, 299) /
+ + 11852089, 11852089, 11852129, 11852129, 11852147, 11852147,
+ + 11852149, 11852149, 11852161, 11852161, 11852171, 11852171,
+ + 11852177, 11852177, 11852209, 11852209, 11852221, 11852221,
+ + 11852237, 11852237, 11852251, 11852251, 11852263, 11852263,
+ + 11852273, 11852273, 11852279, 11852279, 11852287, 11852287,
+ + 11852293, 11852293, 11852297, 11852297, 11852303, 11852303,
+ + 11852311, 11852311, 11852327, 11852327, 11852339, 11852339,
+ + 11852341, 11852341, 11852359, 11852359, 11852369, 11852369,
+ + 11852437, 11852437, 11852453, 11852453, 11852459, 11852459,
+ + 11852473, 11852473, 11852513, 11852513, 11852531, 11852531 /
+ data (iparam(1,i),iparam(2,i),i= 300, 329) /
+ + 11852537, 11852537, 11852539, 11852539, 11852557, 11852557,
+ + 11852573, 11852573, 11852579, 11852579, 11852591, 11852591,
+ + 11852609, 11852609, 11852611, 11852611, 11852623, 11852623,
+ + 11852641, 11852641, 11852647, 11852647, 11852657, 11852657,
+ + 11852663, 11852663, 11852717, 11852717, 11852719, 11852719,
+ + 11852741, 11852741, 11852759, 11852759, 11852767, 11852767,
+ + 11852773, 11852773, 11852803, 11852803, 11852807, 11852807,
+ + 11852809, 11852809, 11852831, 11852831, 11852833, 11852833,
+ + 11852837, 11852837, 11852857, 11852857, 11852873, 11852873,
+ + 11852879, 11852879, 11852891, 11852891, 11852917, 11852917 /
+ data (iparam(1,i),iparam(2,i),i= 330, 359) /
+ + 11852921, 11852921, 11852957, 11852957, 11852959, 11852959,
+ + 11852969, 11852969, 11852983, 11852983, 11852989, 11852989,
+ + 11853001, 11853001, 11853013, 11853013, 11853019, 11853019,
+ + 11853031, 11853031, 11853089, 11853089, 11853133, 11853133,
+ + 11853157, 11853157, 11853161, 11853161, 11853181, 11853181,
+ + 11853203, 11853203, 11853217, 11853217, 11853221, 11853221,
+ + 11853227, 11853227, 11853241, 11853241, 11853307, 11853307,
+ + 11853319, 11853319, 11853323, 11853323, 11853329, 11853329,
+ + 11853367, 11853367, 11853383, 11853383, 11853419, 11853419,
+ + 11853421, 11853421, 11853427, 11853427, 11853449, 11853449 /
+ data (iparam(1,i),iparam(2,i),i= 360, 389) /
+ + 11853451, 11853451, 11853463, 11853463, 11853529, 11853529,
+ + 11853557, 11853557, 11853571, 11853571, 11853601, 11853601,
+ + 11853613, 11853613, 11853617, 11853617, 11853629, 11853629,
+ + 11853649, 11853649, 11853659, 11853659, 11853679, 11853679,
+ + 11853689, 11853689, 11853719, 11853719, 11853731, 11853731,
+ + 11853757, 11853757, 11853761, 11853761, 11853773, 11853773,
+ + 11853791, 11853791, 11853817, 11853817, 11853839, 11853839,
+ + 11853847, 11853847, 11853857, 11853857, 11853869, 11853869,
+ + 11853883, 11853883, 11853887, 11853887, 11853889, 11853889,
+ + 11853893, 11853893, 11853899, 11853899, 11853911, 11853911 /
+ data (iparam(1,i),iparam(2,i),i= 390, 419) /
+ + 11853931, 11853931, 11853943, 11853943, 11853979, 11853979,
+ + 11853991, 11853991, 11854001, 11854001, 11854009, 11854009,
+ + 11854019, 11854019, 11854057, 11854057, 11854061, 11854061,
+ + 11854147, 11854147, 11854159, 11854159, 11854163, 11854163,
+ + 11854169, 11854169, 11854211, 11854211, 11854247, 11854247,
+ + 11854261, 11854261, 11854267, 11854267, 11854279, 11854279,
+ + 11854303, 11854303, 11854327, 11854327, 11854331, 11854331,
+ + 11854333, 11854333, 11854363, 11854363, 11854379, 11854379,
+ + 11854399, 11854399, 11854411, 11854411, 11854429, 11854429,
+ + 11854433, 11854433, 11854439, 11854439, 11854441, 11854441 /
+ data (iparam(1,i),iparam(2,i),i= 420, 449) /
+ + 11854463, 11854463, 11854477, 11854477, 11854489, 11854489,
+ + 11854517, 11854517, 11854519, 11854519, 11854523, 11854523,
+ + 11854529, 11854529, 11854567, 11854567, 11854571, 11854571,
+ + 11854573, 11854573, 11854603, 11854603, 11854607, 11854607,
+ + 11854681, 11854681, 11854691, 11854691, 11854709, 11854709,
+ + 11854723, 11854723, 11854757, 11854757, 11854783, 11854783,
+ + 11854793, 11854793, 11854813, 11854813, 11854847, 11854847,
+ + 11854853, 11854853, 11854873, 11854873, 11854877, 11854877,
+ + 11854883, 11854883, 11854891, 11854891, 11854897, 11854897,
+ + 11854901, 11854901, 11854919, 11854919, 11854937, 11854937 /
+ data (iparam(1,i),iparam(2,i),i= 450, 479) /
+ + 11854961, 11854961, 11854963, 11854963, 11854979, 11854979,
+ + 11855003, 11855003, 11855017, 11855017, 11855023, 11855023,
+ + 11855029, 11855029, 11855033, 11855033, 11855111, 11855111,
+ + 11855141, 11855141, 11855147, 11855147, 11855149, 11855149,
+ + 11855159, 11855159, 11855177, 11855177, 11855203, 11855203,
+ + 11855213, 11855213, 11855219, 11855219, 11855231, 11855231,
+ + 11855267, 11855267, 11855269, 11855269, 11855303, 11855303,
+ + 11855309, 11855309, 11855321, 11855321, 11855329, 11855329,
+ + 11855339, 11855339, 11855351, 11855351, 11855353, 11855353,
+ + 11855357, 11855357, 11855359, 11855359, 11855381, 11855381 /
+ data (iparam(1,i),iparam(2,i),i= 480, 509) /
+ + 11855383, 11855383, 11855387, 11855387, 11855399, 11855399,
+ + 11855407, 11855407, 11855413, 11855413, 11855489, 11855489,
+ + 11855491, 11855491, 11855507, 11855507, 11855521, 11855521,
+ + 11855531, 11855531, 11855549, 11855549, 11855551, 11855551,
+ + 11855567, 11855567, 11855581, 11855581, 11855587, 11855587,
+ + 11855593, 11855593, 11855633, 11855633, 11855653, 11855653,
+ + 11855663, 11855663, 11855687, 11855687, 11855689, 11855689,
+ + 11855699, 11855699, 11855713, 11855713, 11855731, 11855731,
+ + 11855737, 11855737, 11855743, 11855743, 11855747, 11855747,
+ + 11855759, 11855759, 11855773, 11855773, 11855801, 11855801 /
+ data (iparam(1,i),iparam(2,i),i= 510, 539) /
+ + 11855807, 11855807, 11855813, 11855813, 11855827, 11855827,
+ + 11855839, 11855839, 11855869, 11855869, 11855881, 11855881,
+ + 11855903, 11855903, 11855911, 11855911, 11855933, 11855933,
+ + 11855959, 11855959, 11855989, 11855989, 11855993, 11855993,
+ + 11855999, 11855999, 11856001, 11856001, 11856023, 11856023,
+ + 11856049, 11856049, 11856071, 11856071, 11856101, 11856101,
+ + 11856107, 11856107, 11856113, 11856113, 11856139, 11856139,
+ + 11856151, 11856151, 11856161, 11856161, 11856179, 11856179,
+ + 11856193, 11856193, 11856199, 11856199, 11856223, 11856223,
+ + 11856239, 11856239, 11856263, 11856263, 11856269, 11856269 /
+ data (iparam(1,i),iparam(2,i),i= 540, 569) /
+ + 11856281, 11856281, 11856287, 11856287, 11856307, 11856307,
+ + 11856311, 11856311, 11856329, 11856329, 11856343, 11856343,
+ + 11856359, 11856359, 11856371, 11856371, 11856373, 11856373,
+ + 11856409, 11856409, 11856419, 11856419, 11856461, 11856461,
+ + 11856469, 11856469, 11856473, 11856473, 11856479, 11856479,
+ + 11856511, 11856511, 11856517, 11856517, 11856541, 11856541,
+ + 11856547, 11856547, 11856553, 11856553, 11856583, 11856583,
+ + 11856629, 11856629, 11856641, 11856641, 11856653, 11856653,
+ + 11856659, 11856659, 11856673, 11856673, 11856697, 11856697,
+ + 11856709, 11856709, 11856727, 11856727, 11856731, 11856731 /
+ data (iparam(1,i),iparam(2,i),i= 570, 599) /
+ + 11856763, 11856763, 11856809, 11856809, 11856811, 11856811,
+ + 11856821, 11856821, 11856841, 11856841, 11856857, 11856857,
+ + 11856877, 11856877, 11856883, 11856883, 11856899, 11856899,
+ + 11856919, 11856919, 11856947, 11856947, 11856953, 11856953,
+ + 11856979, 11856979, 11857003, 11857003, 11857033, 11857033,
+ + 11857037, 11857037, 11857039, 11857039, 11857049, 11857049,
+ + 11857061, 11857061, 11857067, 11857067, 11857073, 11857073,
+ + 11857081, 11857081, 11857091, 11857091, 11857093, 11857093,
+ + 11857099, 11857099, 11857123, 11857123, 11857127, 11857127,
+ + 11857147, 11857147, 11857151, 11857151, 11857193, 11857193 /
+ data (iparam(1,i),iparam(2,i),i= 600, 629) /
+ + 11857217, 11857217, 11857229, 11857229, 11857243, 11857243,
+ + 11857249, 11857249, 11857267, 11857267, 11857277, 11857277,
+ + 11857291, 11857291, 11857303, 11857303, 11857309, 11857309,
+ + 11857327, 11857327, 11857331, 11857331, 11857333, 11857333,
+ + 11857361, 11857361, 11857367, 11857367, 11857369, 11857369,
+ + 11857393, 11857393, 11857399, 11857399, 11857409, 11857409,
+ + 11857421, 11857421, 11857423, 11857423, 11857451, 11857451,
+ + 11857453, 11857453, 11857457, 11857457, 11857477, 11857477,
+ + 11857481, 11857481, 11857493, 11857493, 11857499, 11857499,
+ + 11857519, 11857519, 11857523, 11857523, 11857529, 11857529 /
+ data (iparam(1,i),iparam(2,i),i= 630, 659) /
+ + 11857543, 11857543, 11857561, 11857561, 11857589, 11857589,
+ + 11857591, 11857591, 11857613, 11857613, 11857621, 11857621,
+ + 11857661, 11857661, 11857667, 11857667, 11857693, 11857693,
+ + 11857697, 11857697, 11857709, 11857709, 11857711, 11857711,
+ + 11857751, 11857751, 11857753, 11857753, 11857759, 11857759,
+ + 11857763, 11857763, 11857777, 11857777, 11857787, 11857787,
+ + 11857793, 11857793, 11857801, 11857801, 11857817, 11857817,
+ + 11857819, 11857819, 11857831, 11857831, 11857837, 11857837,
+ + 11857873, 11857873, 11857877, 11857877, 11857883, 11857883,
+ + 11857889, 11857889, 11857907, 11857907, 11857913, 11857913 /
+ data (iparam(1,i),iparam(2,i),i= 660, 689) /
+ + 11857931, 11857931, 11857969, 11857969, 11857991, 11857991,
+ + 11857999, 11857999, 11858009, 11858009, 11858017, 11858017,
+ + 11858023, 11858023, 11858029, 11858029, 11858039, 11858039,
+ + 11858051, 11858051, 11858057, 11858057, 11858059, 11858059,
+ + 11858101, 11858101, 11858111, 11858111, 11858131, 11858131,
+ + 11858149, 11858149, 11858159, 11858159, 11858177, 11858177,
+ + 11858191, 11858191, 11858201, 11858201, 11858227, 11858227,
+ + 11858243, 11858243, 11858267, 11858267, 11858269, 11858269,
+ + 11858279, 11858279, 11858281, 11858281, 11858291, 11858291,
+ + 11858311, 11858311, 11858323, 11858323, 11858359, 11858359 /
+ data (iparam(1,i),iparam(2,i),i= 690, 719) /
+ + 11858377, 11858377, 11858381, 11858381, 11858387, 11858387,
+ + 11858423, 11858423, 11858443, 11858443, 11858447, 11858447,
+ + 11858479, 11858479, 11858533, 11858533, 11858543, 11858543,
+ + 11858551, 11858551, 11858557, 11858557, 11858569, 11858569,
+ + 11858573, 11858573, 11858579, 11858579, 11858597, 11858597,
+ + 11858599, 11858599, 11858629, 11858629, 11858657, 11858657,
+ + 11858659, 11858659, 11858683, 11858683, 11858701, 11858701,
+ + 11858719, 11858719, 11858723, 11858723, 11858729, 11858729,
+ + 11858747, 11858747, 11858779, 11858779, 11858783, 11858783,
+ + 11858801, 11858801, 11858807, 11858807, 11858813, 11858813 /
+ data (iparam(1,i),iparam(2,i),i= 720, 749) /
+ + 11858839, 11858839, 11858851, 11858851, 11858893, 11858893,
+ + 11858897, 11858897, 11858921, 11858921, 11858947, 11858947,
+ + 11858953, 11858953, 11858969, 11858969, 11858971, 11858971,
+ + 11858989, 11858989, 11859017, 11859017, 11859031, 11859031,
+ + 11859049, 11859049, 11859061, 11859061, 11859073, 11859073,
+ + 11859077, 11859077, 11859079, 11859079, 11859083, 11859083,
+ + 11859101, 11859101, 11859109, 11859109, 11859137, 11859137,
+ + 11859139, 11859139, 11859151, 11859151, 11859157, 11859157,
+ + 11859163, 11859163, 11859167, 11859167, 11859179, 11859179,
+ + 11859187, 11859187, 11859229, 11859229, 11859233, 11859233 /
+ data (iparam(1,i),iparam(2,i),i= 750, 779) /
+ + 11859241, 11859241, 11859247, 11859247, 11859269, 11859269,
+ + 11859293, 11859293, 11859307, 11859307, 11859311, 11859311,
+ + 11859349, 11859349, 11859359, 11859359, 11859371, 11859371,
+ + 11859377, 11859377, 11859383, 11859383, 11859427, 11859427,
+ + 11859433, 11859433, 11859451, 11859451, 11859457, 11859457,
+ + 11859461, 11859461, 11859473, 11859473, 11859481, 11859481,
+ + 11859487, 11859487, 11859493, 11859493, 11859503, 11859503,
+ + 11859509, 11859509, 11859539, 11859539, 11859541, 11859541,
+ + 11859563, 11859563, 11859569, 11859569, 11859571, 11859571,
+ + 11859583, 11859583, 11859599, 11859599, 11859611, 11859611 /
+ data (iparam(1,i),iparam(2,i),i= 780, 809) /
+ + 11859643, 11859643, 11859707, 11859707, 11859713, 11859713,
+ + 11859719, 11859719, 11859739, 11859739, 11859751, 11859751,
+ + 11859791, 11859791, 11859817, 11859817, 11859821, 11859821,
+ + 11859833, 11859833, 11859847, 11859847, 11859853, 11859853,
+ + 11859877, 11859877, 11859889, 11859889, 11859893, 11859893,
+ + 11859901, 11859901, 11859907, 11859907, 11859917, 11859917,
+ + 11859923, 11859923, 11859929, 11859929, 11859961, 11859961,
+ + 11859979, 11859979, 11859989, 11859989, 11859997, 11859997,
+ + 11860021, 11860021, 11860031, 11860031, 11860039, 11860039,
+ + 11860049, 11860049, 11860081, 11860081, 11860087, 11860087 /
+ data (iparam(1,i),iparam(2,i),i= 810, 839) /
+ + 11860097, 11860097, 11860103, 11860103, 11860109, 11860109,
+ + 11860117, 11860117, 11860133, 11860133, 11860151, 11860151,
+ + 11860171, 11860171, 11860207, 11860207, 11860223, 11860223,
+ + 11860231, 11860231, 11860243, 11860243, 11860267, 11860267,
+ + 11860301, 11860301, 11860307, 11860307, 11860327, 11860327,
+ + 11860379, 11860379, 11860397, 11860397, 11860411, 11860411,
+ + 11860469, 11860469, 11860477, 11860477, 11860483, 11860483,
+ + 11860487, 11860487, 11860489, 11860489, 11860493, 11860493,
+ + 11860517, 11860517, 11860547, 11860547, 11860567, 11860567,
+ + 11860573, 11860573, 11860613, 11860613, 11860619, 11860619 /
+ data (iparam(1,i),iparam(2,i),i= 840, 869) /
+ + 11860627, 11860627, 11860637, 11860637, 11860643, 11860643,
+ + 11860649, 11860649, 11860661, 11860661, 11860669, 11860669,
+ + 11860687, 11860687, 11860691, 11860691, 11860697, 11860697,
+ + 11860699, 11860699, 11860703, 11860703, 11860727, 11860727,
+ + 11860741, 11860741, 11860753, 11860753, 11860777, 11860777,
+ + 11860787, 11860787, 11860789, 11860789, 11860811, 11860811,
+ + 11860837, 11860837, 11860859, 11860859, 11860867, 11860867,
+ + 11860889, 11860889, 11860897, 11860897, 11860963, 11860963,
+ + 11860969, 11860969, 11860973, 11860973, 11860993, 11860993,
+ + 11861011, 11861011, 11861033, 11861033, 11861071, 11861071 /
+ data (iparam(1,i),iparam(2,i),i= 870, 899) /
+ + 11861081, 11861081, 11861089, 11861089, 11861093, 11861093,
+ + 11861099, 11861099, 11861107, 11861107, 11861131, 11861131,
+ + 11861141, 11861141, 11861159, 11861159, 11861167, 11861167,
+ + 11861191, 11861191, 11861197, 11861197, 11861207, 11861207,
+ + 11861219, 11861219, 11861221, 11861221, 11861231, 11861231,
+ + 11861237, 11861237, 11861273, 11861273, 11861293, 11861293,
+ + 11861299, 11861299, 11861303, 11861303, 11861327, 11861327,
+ + 11861351, 11861351, 11861357, 11861357, 11861363, 11861363,
+ + 11861371, 11861371, 11861401, 11861401, 11861407, 11861407,
+ + 11861411, 11861411, 11861413, 11861413, 11861429, 11861429 /
+ data (iparam(1,i),iparam(2,i),i= 900, 929) /
+ + 11861441, 11861441, 11861467, 11861467, 11861527, 11861527,
+ + 11861539, 11861539, 11861543, 11861543, 11861557, 11861557,
+ + 11861569, 11861569, 11861573, 11861573, 11861579, 11861579,
+ + 11861581, 11861581, 11861599, 11861599, 11861611, 11861611,
+ + 11861617, 11861617, 11861627, 11861627, 11861639, 11861639,
+ + 11861651, 11861651, 11861659, 11861659, 11861671, 11861671,
+ + 11861683, 11861683, 11861687, 11861687, 11861693, 11861693,
+ + 11861701, 11861701, 11861711, 11861711, 11861713, 11861713,
+ + 11861749, 11861749, 11861791, 11861791, 11861803, 11861803,
+ + 11861819, 11861819, 11861827, 11861827, 11861849, 11861849 /
+ data (iparam(1,i),iparam(2,i),i= 930, 959) /
+ + 11861873, 11861873, 11861879, 11861879, 11861887, 11861887,
+ + 11861911, 11861911, 11861917, 11861917, 11861921, 11861921,
+ + 11861923, 11861923, 11861953, 11861953, 11861959, 11861959,
+ + 11861987, 11861987, 11862007, 11862007, 11862013, 11862013,
+ + 11862029, 11862029, 11862031, 11862031, 11862049, 11862049,
+ + 11862077, 11862077, 11862083, 11862083, 11862157, 11862157,
+ + 11862167, 11862167, 11862199, 11862199, 11862203, 11862203,
+ + 11862217, 11862217, 11862223, 11862223, 11862229, 11862229,
+ + 11862233, 11862233, 11862239, 11862239, 11862241, 11862241,
+ + 11862259, 11862259, 11862269, 11862269, 11862271, 11862271 /
+ data (iparam(1,i),iparam(2,i),i= 960, 989) /
+ + 11862293, 11862293, 11862307, 11862307, 11862313, 11862313,
+ + 11862317, 11862317, 11862343, 11862343, 11862353, 11862353,
+ + 11862373, 11862373, 11862391, 11862391, 11862439, 11862439,
+ + 11862469, 11862469, 11862493, 11862493, 11862527, 11862527,
+ + 11862547, 11862547, 11862563, 11862563, 11862569, 11862569,
+ + 11862577, 11862577, 11862581, 11862581, 11862611, 11862611,
+ + 11862623, 11862623, 11862661, 11862661, 11862673, 11862673,
+ + 11862679, 11862679, 11862701, 11862701, 11862703, 11862703,
+ + 11862713, 11862713, 11862761, 11862761, 11862791, 11862791,
+ + 11862803, 11862803, 11862839, 11862839, 11862841, 11862841 /
+ data (iparam(1,i),iparam(2,i),i= 990,1019) /
+ + 11862857, 11862857, 11862869, 11862869, 11862881, 11862881,
+ + 11862911, 11862911, 11862919, 11862919, 11862959, 11862959,
+ + 11862979, 11862979, 11862989, 11862989, 11862997, 11862997,
+ + 11863021, 11863021, 11863031, 11863031, 11863037, 11863037,
+ + 11863039, 11863039, 11863057, 11863057, 11863067, 11863067,
+ + 11863073, 11863073, 11863099, 11863099, 11863109, 11863109,
+ + 11863121, 11863121, 11863123, 11863123, 11863133, 11863133,
+ + 11863151, 11863151, 11863153, 11863153, 11863171, 11863171,
+ + 11863183, 11863183, 11863207, 11863207, 11863213, 11863213,
+ + 11863237, 11863237, 11863249, 11863249, 11863253, 11863253 /
+ data (iparam(1,i),iparam(2,i),i=1020,1021) /
+ + 11863259, 11863259, 11863279, 11863279 /
+ end
+#else
+ real function prng_next(me)
+crc logical prng_restart, prng_chkpnt
+c
+c Calling sequence:
+c <new random number> = prng_next ( <ordinal of generator desired> )
+c
+c This code is based on a sequential algorithm provided by Mal Kalos.
+c This version uses 4 16-bit packets, and uses a block data common
+c area for the initial seeds and constants. A 64-bit floating point
+c number is returned.
+c
+c The arrays "l" and "n" are full-word aligned, being padded by zeros
+c That is, rows 1-4 in a given column are for real, rows 5-16 are bogus
+c
+c July 12, 1993: double the number of sequences. We should have been
+c using two packets per seed, rather than four
+c
+ real tpm12
+ integer iseed(4)
+ parameter(tpm12 = 1.d0/65536.d0)
+ parameter(nmax=1021)
+c external prngblk
+ common/ksrprng/l(16,0:nmax),n(16,0:nmax)
+c*ksr*subpage /ksrprng/
+ data m1,m2,m3,m4 / 0, 8037, 61950, 30779/
+ if (me .lt. 0 .or. me .gt. nmax) then
+ prng_next=-1.0
+ return
+ endif
+ l1=l(1,me)
+ l2=l(2,me)
+ l3=l(3,me)
+ l4=l(4,me)
+ i1=l1*m4+l2*m3+l3*m2+l4*m1 + n(1,me)
+ i2=l2*m4+l3*m3+l4*m2 + n(2,me)
+ i3=l3*m4+l4*m3 + n(3,me)
+ i4=l4*m4 + n(4,me)
+ l4=and(i4,65535)
+ i3=i3+ishft(i4,-16)
+ l3=and(i3,65535)
+ i2=i2+ishft(i3,-16)
+ l2=and(i2,65535)
+ l1=and(i1+ishft(i2,-16),65535)
+ prng_next=tpm12*(l1+tpm12*(l2+tpm12*(l3+tpm12*l4)))
+ l(1,me)=l1
+ l(2,me)=l2
+ l(3,me)=l3
+ l(4,me)=l4
+ return
+ end
+c
+c prng_chkpnt Get the current state of a generator
+c
+c Calling sequence:
+c logical prng_chkpnt, status
+c status = prng_chkpnt (me, iseed) where
+c
+c me is the particular generator whose state is being gotten
+c seed is an 4-element integer array where the "l"-values will be saved
+c
+crc entry prng_chkpnt (me, iseed)
+ logical function prng_chkpnt (me, iseed)
+ integer iseed(4)
+ parameter(nmax=1021)
+ common/ksrprng/l(16,0:nmax),n(16,0:nmax)
+ if (me .lt. 0 .or. me .gt. nmax) then
+ prng_chkpnt=.false.
+ else
+ prng_chkpnt=.true.
+ iseed(1)=l(1,me)
+ iseed(2)=l(2,me)
+ iseed(3)=l(3,me)
+ iseed(4)=l(4,me)
+ endif
+ return
+ end
+c
+c prng_restart Restart generator from a saved state
+c
+c Calling sequence:
+c logical prng_restart, status
+c status = prng_restart (me, iseed) where
+c
+c me is the particular generator being restarted
+c seed is an 4-element integer array containing the "l"-values
+c
+crc entry prng_restart (me, iseed)
+ logical function prng_restart (me, iseed)
+ integer iseed(4)
+ parameter(nmax=1021)
+ common/ksrprng/l(16,0:nmax),n(16,0:nmax)
+ if (me .lt. 0 .or. me .gt. nmax) then
+ prng_restart=.false.
+ return
+ else
+ prng_restart=.true.
+ l(1,me)=iseed(1)
+ l(2,me)=iseed(2)
+ l(3,me)=iseed(3)
+ l(4,me)=iseed(4)
+ endif
+ return
+ end
+
+ block data prngblk
+c
+c Sequence of prime numbers represented as pairs of 16-bit integers
+c modulo 2**16, obtained from Mal Kalos August 28, 1992. Only 98
+c continuation cards are allowed by ksr Fortran, so several DATA
+c statements are used to initialize 1022 generators.
+c
+c @cornell university, 1992
+c
+ parameter(nmax=1021,nmax1=2*nmax+2)
+ common/ksrprng/l(16,0:nmax),n(16,0:nmax)
+c*ksr*subpage /ksrprng/
+
+c High order quads in arrays "l" and "n" are initialized to zero : rows 1-2
+c Rows 5-16 remain uninitialized. They are just pads, never used.
+ DATA ((l(i,j),i=1,2),j=0,nmax)/nmax1*0.0/
+ DATA ((n(i,j),i=1,2),j=0,nmax)/nmax1*0.0/
+
+c The rest of array "l" and "n" are initialized to a 20-bit seed
+ DATA ((l(i,j),i=3,4),j=0,489)/
+ .180, 51739,180, 51757,180, 51761,180, 51767,180,51773,
+ .180, 51791,180, 51817,180, 51833,180, 51859,180, 51871,
+ .180, 51877,180, 51883,180, 51887,180, 51893,180, 51899,
+ .180, 51913,180, 51953,180, 51971,180, 51989,180, 51997,
+ .180, 52009,180, 52013,180, 52033,180, 52043,180, 52051,
+ .180, 52057,180, 52073,180, 52109,180, 52111,180, 52121,
+ .180, 52139,180, 52157,180, 52183,180, 52193,180, 52199,
+ .180, 52211,180, 52219,180, 52229,180, 52237,180, 52241,
+ .180, 52249,180, 52261,180, 52271,180, 52277,180, 52307,
+ .180, 52321,180, 52349,180, 52373,180, 52381,180, 52387,
+ .180, 52393,180, 52411,180, 52429,180, 52439,180, 52451,
+ .180, 52457,180, 52481,180, 52501,180, 52541,180, 52559,
+ .180, 52573,180, 52579,180, 52589,180, 52597,180, 52607,
+ .180, 52613,180, 52627,180, 52631,180, 52649,180, 52657,
+ .180, 52697,180, 52703,180, 52723,180, 52751,180, 52757,
+ .180, 52759,180, 52769,180, 52771,180, 52789,180, 52793,
+ .180, 52811,180, 52817,180, 52829,180, 52859,180, 52879,
+ .180, 52883,180, 52919,180, 52921,180, 52933,180, 52937,
+ .180, 52957,180, 52963,180, 52993,180, 53011,180, 53023,
+ .180, 53027,180, 53077,180, 53087,180, 53089,180, 53093,
+ .180, 53107,180, 53119,180, 53153,180, 53161,180, 53173,
+ .180, 53179,180, 53191,180, 53203,180, 53209,180, 53213,
+ .180, 53219,180, 53221,180, 53227,180, 53233,180, 53243,
+ .180, 53261,180, 53263,180, 53279,180, 53287,180, 53291,
+ .180, 53311,180, 53321,180, 53329,180, 53333,180, 53389,
+ .180, 53401,180, 53411,180, 53429,180, 53443,180, 53453,
+ .180, 53467,180, 53507,180, 53521,180, 53531,180, 53539,
+ .180, 53543,180, 53551,180, 53569,180, 53581,180, 53593,
+ .180, 53597,180, 53623,180, 53629,180, 53641,180, 53647,
+ .180, 53653,180, 53669,180, 53681,180, 53689,180, 53711,
+ .180, 53753,180, 53767,180, 53779,180, 53789,180, 53803,
+ .180, 53821,180, 53861,180, 53867,180, 53887,180, 53893,
+ .180, 53899,180, 53909,180, 53927,180, 53947,180, 53957,
+ .180, 53989,180, 54001,180, 54031,180, 54049,180, 54061,
+ .180, 54077,180, 54127,180, 54131,180, 54187,180, 54197,
+ .180, 54199,180, 54221,180, 54251,180, 54259,180, 54269,
+ .180, 54311,180, 54323,180, 54349,180, 54353,180, 54379,
+ .180, 54397,180, 54419,180, 54427,180, 54433,180, 54439,
+ .180, 54451,180, 54461,180, 54467,180, 54473,180, 54481,
+ .180, 54503,180, 54511,180, 54517,180, 54551,180, 54553,
+ .180, 54571,180, 54581,180, 54587,180, 54613,180, 54629,
+ .180, 54643,180, 54647,180, 54659,180, 54677,180, 54683,
+ .180, 54701,180, 54721,180, 54739,180, 54811,180, 54823,
+ .180, 54829,180, 54833,180, 54839,180, 54869,180, 54871,
+ .180, 54881,180, 54893,180, 54923,180, 54929,180, 54943,
+ .180, 54967,180, 54971,180, 55001,180, 55013,180, 55039,
+ .180, 55043,180, 55049,180, 55067,180, 55069,180, 55079,
+ .180, 55097,180, 55109,180, 55111,180, 55117,180, 55123,
+ .180, 55127,180, 55133,180, 55141,180, 55147,180, 55159,
+ .180, 55193,180, 55201,180, 55247,180, 55273,180, 55279,
+ .180, 55307,180, 55313,180, 55319,180, 55333,180, 55361,
+ .180, 55379,180, 55387,180, 55411,180, 55429,180, 55439,
+ .180, 55447,180, 55453,180, 55469,180, 55487,180, 55517,
+ .180, 55537,180, 55571,180, 55573,180, 55579,180, 55603,
+ .180, 55609,180, 55649,180, 55667,180, 55669,180, 55681,
+ .180, 55691,180, 55697,180, 55729,180, 55741,180, 55757,
+ .180, 55771,180, 55783,180, 55793,180, 55799,180, 55807,
+ .180, 55813,180, 55817,180, 55823,180, 55831,180, 55847,
+ .180, 55859,180, 55861,180, 55879,180, 55889,180, 55957,
+ .180, 55973,180, 55979,180, 55993,180, 56033,180, 56051,
+ .180, 56057,180, 56059,180, 56077,180, 56093,180, 56099,
+ .180, 56111,180, 56129,180, 56131,180, 56143,180, 56161,
+ .180, 56167,180, 56177,180, 56183,180, 56237,180, 56239,
+ .180, 56261,180, 56279,180, 56287,180, 56293,180, 56323,
+ .180, 56327,180, 56329,180, 56351,180, 56353,180, 56357,
+ .180, 56377,180, 56393,180, 56399,180, 56411,180, 56437,
+ .180, 56441,180, 56477,180, 56479,180, 56489,180, 56503,
+ .180, 56509,180, 56521,180, 56533,180, 56539,180, 56551,
+ .180, 56609,180, 56653,180, 56677,180, 56681,180, 56701,
+ .180, 56723,180, 56737,180, 56741,180, 56747,180, 56761,
+ .180, 56827,180, 56839,180, 56843,180, 56849,180, 56887,
+ .180, 56903,180, 56939,180, 56941,180, 56947,180, 56969,
+ .180, 56971,180, 56983,180, 57049,180, 57077,180, 57091,
+ .180, 57121,180, 57133,180, 57137,180, 57149,180, 57169,
+ .180, 57179,180, 57199,180, 57209,180, 57239,180, 57251,
+ .180, 57277,180, 57281,180, 57293,180, 57311,180, 57337,
+ .180, 57359,180, 57367,180, 57377,180, 57389,180, 57403,
+ .180, 57407,180, 57409,180, 57413,180, 57419,180, 57431,
+ .180, 57451,180, 57463,180, 57499,180, 57511,180, 57521,
+ .180, 57529,180, 57539,180, 57577,180, 57581,180, 57667,
+ .180, 57679,180, 57683,180, 57689,180, 57731,180, 57767,
+ .180, 57781,180, 57787,180, 57799,180, 57823,180, 57847,
+ .180, 57851,180, 57853,180, 57883,180, 57899,180, 57919,
+ .180, 57931,180, 57949,180, 57953,180, 57959,180, 57961,
+ .180, 57983,180, 57997,180, 58009,180, 58037,180, 58039,
+ .180, 58043,180, 58049,180, 58087,180, 58091,180, 58093,
+ .180, 58123,180, 58127,180, 58201,180, 58211,180, 58229,
+ .180, 58243,180, 58277,180, 58303,180, 58313,180, 58333,
+ .180, 58367,180, 58373,180, 58393,180, 58397,180, 58403,
+ .180, 58411,180, 58417,180, 58421,180, 58439,180, 58457,
+ .180, 58481,180, 58483,180, 58499,180, 58523,180, 58537,
+ .180, 58543,180, 58549,180, 58553,180, 58631,180, 58661,
+ .180, 58667,180, 58669,180, 58679,180, 58697,180, 58723,
+ .180, 58733,180, 58739,180, 58751,180, 58787,180, 58789,
+ .180, 58823,180, 58829,180, 58841,180, 58849,180, 58859,
+ .180, 58871,180, 58873,180, 58877,180, 58879,180, 58901,
+ .180, 58903,180, 58907,180, 58919,180, 58927,180, 58933,
+ .180, 59009,180, 59011,180, 59027,180, 59041,180, 59051/
+ DATA ((l(i,j),i=3,4),j=490,979)/
+ .180, 59069,180, 59071,180, 59087,180, 59101,180, 59107,
+ .180, 59113,180, 59153,180, 59173,180, 59183,180, 59207,
+ .180, 59209,180, 59219,180, 59233,180, 59251,180, 59257,
+ .180, 59263,180, 59267,180, 59279,180, 59293,180, 59321,
+ .180, 59327,180, 59333,180, 59347,180, 59359,180, 59389,
+ .180, 59401,180, 59423,180, 59431,180, 59453,180, 59479,
+ .180, 59509,180, 59513,180, 59519,180, 59521,180, 59543,
+ .180, 59569,180, 59591,180, 59621,180, 59627,180, 59633,
+ .180, 59659,180, 59671,180, 59681,180, 59699,180, 59713,
+ .180, 59719,180, 59743,180, 59759,180, 59783,180, 59789,
+ .180, 59801,180, 59807,180, 59827,180, 59831,180, 59849,
+ .180, 59863,180, 59879,180, 59891,180, 59893,180, 59929,
+ .180, 59939,180, 59981,180, 59989,180, 59993,180, 59999,
+ .180, 60031,180, 60037,180, 60061,180, 60067,180, 60073,
+ .180, 60103,180, 60149,180, 60161,180, 60173,180, 60179,
+ .180, 60193,180, 60217,180, 60229,180, 60247,180, 60251,
+ .180, 60283,180, 60329,180, 60331,180, 60341,180, 60361,
+ .180, 60377,180, 60397,180, 60403,180, 60419,180, 60439,
+ .180, 60467,180, 60473,180, 60499,180, 60523,180, 60553,
+ .180, 60557,180, 60559,180, 60569,180, 60581,180, 60587,
+ .180, 60593,180, 60601,180, 60611,180, 60613,180, 60619,
+ .180, 60643,180, 60647,180, 60667,180, 60671,180, 60713,
+ .180, 60737,180, 60749,180, 60763,180, 60769,180, 60787,
+ .180, 60797,180, 60811,180, 60823,180, 60829,180, 60847,
+ .180, 60851,180, 60853,180, 60881,180, 60887,180, 60889,
+ .180, 60913,180, 60919,180, 60929,180, 60941,180, 60943,
+ .180, 60971,180, 60973,180, 60977,180, 60997,180, 61001,
+ .180, 61013,180, 61019,180, 61039,180, 61043,180, 61049,
+ .180, 61063,180, 61081,180, 61109,180, 61111,180, 61133,
+ .180, 61141,180, 61181,180, 61187,180, 61213,180, 61217,
+ .180, 61229,180, 61231,180, 61271,180, 61273,180, 61279,
+ .180, 61283,180, 61297,180, 61307,180, 61313,180, 61321,
+ .180, 61337,180, 61339,180, 61351,180, 61357,180, 61393,
+ .180, 61397,180, 61403,180, 61409,180, 61427,180, 61433,
+ .180, 61451,180, 61489,180, 61511,180, 61519,180, 61529,
+ .180, 61537,180, 61543,180, 61549,180, 61559,180, 61571,
+ .180, 61577,180, 61579,180, 61621,180, 61631,180, 61651,
+ .180, 61669,180, 61679,180, 61697,180, 61711,180, 61721,
+ .180, 61747,180, 61763,180, 61787,180, 61789,180, 61799,
+ .180, 61801,180, 61811,180, 61831,180, 61843,180, 61879,
+ .180, 61897,180, 61901,180, 61907,180, 61943,180, 61963,
+ .180, 61967,180, 61999,180, 62053,180, 62063,180, 62071,
+ .180, 62077,180, 62089,180, 62093,180, 62099,180, 62117,
+ .180, 62119,180, 62149,180, 62177,180, 62179,180, 62203,
+ .180, 62221,180, 62239,180, 62243,180, 62249,180, 62267,
+ .180, 62299,180, 62303,180, 62321,180, 62327,180, 62333,
+ .180, 62359,180, 62371,180, 62413,180, 62417,180, 62441,
+ .180, 62467,180, 62473,180, 62489,180, 62491,180, 62509,
+ .180, 62537,180, 62551,180, 62569,180, 62581,180, 62593,
+ .180, 62597,180, 62599,180, 62603,180, 62621,180, 62629,
+ .180, 62657,180, 62659,180, 62671,180, 62677,180, 62683,
+ .180, 62687,180, 62699,180, 62707,180, 62749,180, 62753,
+ .180, 62761,180, 62767,180, 62789,180, 62813,180, 62827,
+ .180, 62831,180, 62869,180, 62879,180, 62891,180, 62897,
+ .180, 62903,180, 62947,180, 62953,180, 62971,180, 62977,
+ .180, 62981,180, 62993,180, 63001,180, 63007,180, 63013,
+ .180, 63023,180, 63029,180, 63059,180, 63061,180, 63083,
+ .180, 63089,180, 63091,180, 63103,180, 63119,180, 63131,
+ .180, 63163,180, 63227,180, 63233,180, 63239,180, 63259,
+ .180, 63271,180, 63311,180, 63337,180, 63341,180, 63353,
+ .180, 63367,180, 63373,180, 63397,180, 63409,180, 63413,
+ .180, 63421,180, 63427,180, 63437,180, 63443,180, 63449,
+ .180, 63481,180, 63499,180, 63509,180, 63517,180, 63541,
+ .180, 63551,180, 63559,180, 63569,180, 63601,180, 63607,
+ .180, 63617,180, 63623,180, 63629,180, 63637,180, 63653,
+ .180, 63671,180, 63691,180, 63727,180, 63743,180, 63751,
+ .180, 63763,180, 63787,180, 63821,180, 63827,180, 63847,
+ .180, 63899,180, 63917,180, 63931,180, 63989,180, 63997,
+ .180, 64003,180, 64007,180, 64009,180, 64013,180, 64037,
+ .180, 64067,180, 64087,180, 64093,180, 64133,180, 64139,
+ .180, 64147,180, 64157,180, 64163,180, 64169,180, 64181,
+ .180, 64189,180, 64207,180, 64211,180, 64217,180, 64219,
+ .180, 64223,180, 64247,180, 64261,180, 64273,180, 64297,
+ .180, 64307,180, 64309,180, 64331,180, 64357,180, 64379,
+ .180, 64387,180, 64409,180, 64417,180, 64483,180, 64489,
+ .180, 64493,180, 64513,180, 64531,180, 64553,180, 64591,
+ .180, 64601,180, 64609,180, 64613,180, 64619,180, 64627,
+ .180, 64651,180, 64661,180, 64679,180, 64687,180, 64711,
+ .180, 64717,180, 64727,180, 64739,180, 64741,180, 64751,
+ .180, 64757,180, 64793,180, 64813,180, 64819,180, 64823,
+ .180, 64847,180, 64871,180, 64877,180, 64883,180, 64891,
+ .180, 64921,180, 64927,180, 64931,180, 64933,180, 64949,
+ .180, 64961,180, 64987,180, 65047,180, 65059,180, 65063,
+ .180, 65077,180, 65089,180, 65093,180, 65099,180, 65101,
+ .180, 65119,180, 65131,180, 65137,180, 65147,180, 65159,
+ .180, 65171,180, 65179,180, 65191,180, 65203,180, 65207,
+ .180, 65213,180, 65221,180, 65231,180, 65233,180, 65269,
+ .180, 65311,180, 65323,180, 65339,180, 65347,180, 65369,
+ .180, 65393,180, 65399,180, 65407,180, 65431,180, 65437,
+ .180, 65441,180, 65443,180, 65473,180, 65479,180, 65507,
+ .180, 65527,180, 65533,181, 13,181, 15,181, 33,
+ .181, 61,181, 67,181, 141,181, 151,181, 183,
+ .181, 187,181, 201,181, 207,181, 213,181, 217,
+ .181, 223,181, 225,181, 243,181, 253,181, 255,
+ .181, 277,181, 291,181, 297,181, 301,181, 327,
+ .181, 337,181, 357,181, 375,181, 423,181, 453,
+ .181, 477,181, 511,181, 531,181, 547,181, 553,
+ .181, 561,181, 565,181, 595,181, 607,181, 645/
+ DATA ((l(i,j),i=3,4),j=980,nmax)/
+ .181, 657,181, 663,181, 685,181, 687,181, 697,
+ .181, 745,181, 775,181, 787,181, 823,181, 825,
+ .181, 841,181, 853,181, 865,181, 895,181, 903,
+ .181, 943,181, 963,181, 973,181, 981,181, 1005,
+ .181,1015,181,1021,181,1023,181,1041,181,1051,
+ .181, 1057,181, 1083,181, 1093,181, 1105,181, 1107,
+ .181, 1117,181, 1135,181, 1137,181, 1155,181, 1167,
+ .181, 1191,181, 1197,181, 1221,181, 1233,181, 1237,
+ .181, 1243,181, 1263/
+ DATA ((n(i,j),i=3,4),j=0,489)/
+ .180, 51739,180, 51757,180, 51761,180, 51767,180, 51773,
+ .180, 51791,180, 51817,180, 51833,180, 51859,180, 51871,
+ .180, 51877,180, 51883,180, 51887,180, 51893,180, 51899,
+ .180, 51913,180, 51953,180, 51971,180, 51989,180, 51997,
+ .180, 52009,180, 52013,180, 52033,180, 52043,180, 52051,
+ .180, 52057,180, 52073,180, 52109,180, 52111,180, 52121,
+ .180, 52139,180, 52157,180, 52183,180, 52193,180, 52199,
+ .180, 52211,180, 52219,180, 52229,180, 52237,180, 52241,
+ .180, 52249,180, 52261,180, 52271,180, 52277,180, 52307,
+ .180, 52321,180, 52349,180, 52373,180, 52381,180, 52387,
+ .180, 52393,180, 52411,180, 52429,180, 52439,180, 52451,
+ .180, 52457,180, 52481,180, 52501,180, 52541,180, 52559,
+ .180, 52573,180, 52579,180, 52589,180, 52597,180, 52607,
+ .180, 52613,180, 52627,180, 52631,180, 52649,180, 52657,
+ .180, 52697,180, 52703,180, 52723,180, 52751,180, 52757,
+ .180, 52759,180, 52769,180, 52771,180, 52789,180, 52793,
+ .180, 52811,180, 52817,180, 52829,180, 52859,180, 52879,
+ .180, 52883,180, 52919,180, 52921,180, 52933,180, 52937,
+ .180, 52957,180, 52963,180, 52993,180, 53011,180, 53023,
+ .180, 53027,180, 53077,180, 53087,180, 53089,180, 53093,
+ .180, 53107,180, 53119,180, 53153,180, 53161,180, 53173,
+ .180, 53179,180, 53191,180, 53203,180, 53209,180, 53213,
+ .180, 53219,180, 53221,180, 53227,180, 53233,180, 53243,
+ .180, 53261,180, 53263,180, 53279,180, 53287,180, 53291,
+ .180, 53311,180, 53321,180, 53329,180, 53333,180, 53389,
+ .180, 53401,180, 53411,180, 53429,180, 53443,180, 53453,
+ .180, 53467,180, 53507,180, 53521,180, 53531,180, 53539,
+ .180, 53543,180, 53551,180, 53569,180, 53581,180, 53593,
+ .180, 53597,180, 53623,180, 53629,180, 53641,180, 53647,
+ .180, 53653,180, 53669,180, 53681,180, 53689,180, 53711,
+ .180, 53753,180, 53767,180, 53779,180, 53789,180, 53803,
+ .180, 53821,180, 53861,180, 53867,180, 53887,180, 53893,
+ .180, 53899,180, 53909,180, 53927,180, 53947,180, 53957,
+ .180, 53989,180, 54001,180, 54031,180, 54049,180, 54061,
+ .180, 54077,180, 54127,180, 54131,180, 54187,180, 54197,
+ .180, 54199,180, 54221,180, 54251,180, 54259,180, 54269,
+ .180, 54311,180, 54323,180, 54349,180, 54353,180, 54379,
+ .180, 54397,180, 54419,180, 54427,180, 54433,180, 54439,
+ .180, 54451,180, 54461,180, 54467,180, 54473,180, 54481,
+ .180, 54503,180, 54511,180, 54517,180, 54551,180, 54553,
+ .180, 54571,180, 54581,180, 54587,180, 54613,180, 54629,
+ .180, 54643,180, 54647,180, 54659,180, 54677,180, 54683,
+ .180, 54701,180, 54721,180, 54739,180, 54811,180, 54823,
+ .180, 54829,180, 54833,180, 54839,180, 54869,180, 54871,
+ .180, 54881,180, 54893,180, 54923,180, 54929,180, 54943,
+ .180, 54967,180, 54971,180, 55001,180, 55013,180, 55039,
+ .180, 55043,180, 55049,180, 55067,180, 55069,180, 55079,
+ .180, 55097,180, 55109,180, 55111,180, 55117,180, 55123,
+ .180, 55127,180, 55133,180, 55141,180, 55147,180, 55159,
+ .180, 55193,180, 55201,180, 55247,180, 55273,180, 55279,
+ .180, 55307,180, 55313,180, 55319,180, 55333,180, 55361,
+ .180, 55379,180, 55387,180, 55411,180, 55429,180, 55439,
+ .180, 55447,180, 55453,180, 55469,180, 55487,180, 55517,
+ .180, 55537,180, 55571,180, 55573,180, 55579,180, 55603,
+ .180, 55609,180, 55649,180, 55667,180, 55669,180, 55681,
+ .180, 55691,180, 55697,180, 55729,180, 55741,180, 55757,
+ .180, 55771,180, 55783,180, 55793,180, 55799,180, 55807,
+ .180, 55813,180, 55817,180, 55823,180, 55831,180, 55847,
+ .180, 55859,180, 55861,180, 55879,180, 55889,180, 55957,
+ .180, 55973,180, 55979,180, 55993,180, 56033,180, 56051,
+ .180, 56057,180, 56059,180, 56077,180, 56093,180, 56099,
+ .180, 56111,180, 56129,180, 56131,180, 56143,180, 56161,
+ .180, 56167,180, 56177,180, 56183,180, 56237,180, 56239,
+ .180, 56261,180, 56279,180, 56287,180, 56293,180, 56323,
+ .180, 56327,180, 56329,180, 56351,180, 56353,180, 56357,
+ .180, 56377,180, 56393,180, 56399,180, 56411,180, 56437,
+ .180, 56441,180, 56477,180, 56479,180, 56489,180, 56503,
+ .180, 56509,180, 56521,180, 56533,180, 56539,180, 56551,
+ .180, 56609,180, 56653,180, 56677,180, 56681,180, 56701,
+ .180, 56723,180, 56737,180, 56741,180, 56747,180, 56761,
+ .180, 56827,180, 56839,180, 56843,180, 56849,180, 56887,
+ .180, 56903,180, 56939,180, 56941,180, 56947,180, 56969,
+ .180, 56971,180, 56983,180, 57049,180, 57077,180, 57091,
+ .180, 57121,180, 57133,180, 57137,180, 57149,180, 57169,
+ .180, 57179,180, 57199,180, 57209,180, 57239,180, 57251,
+ .180, 57277,180, 57281,180, 57293,180, 57311,180, 57337,
+ .180, 57359,180, 57367,180, 57377,180, 57389,180, 57403,
+ .180, 57407,180, 57409,180, 57413,180, 57419,180, 57431,
+ .180, 57451,180, 57463,180, 57499,180, 57511,180, 57521,
+ .180, 57529,180, 57539,180, 57577,180, 57581,180, 57667,
+ .180, 57679,180, 57683,180, 57689,180, 57731,180, 57767,
+ .180, 57781,180, 57787,180, 57799,180, 57823,180, 57847,
+ .180, 57851,180, 57853,180, 57883,180, 57899,180, 57919,
+ .180, 57931,180, 57949,180, 57953,180, 57959,180, 57961,
+ .180, 57983,180, 57997,180, 58009,180, 58037,180, 58039,
+ .180, 58043,180, 58049,180, 58087,180, 58091,180, 58093,
+ .180, 58123,180, 58127,180, 58201,180, 58211,180, 58229,
+ .180, 58243,180, 58277,180, 58303,180, 58313,180, 58333,
+ .180, 58367,180, 58373,180, 58393,180, 58397,180, 58403,
+ .180, 58411,180, 58417,180, 58421,180, 58439,180, 58457,
+ .180, 58481,180, 58483,180, 58499,180, 58523,180, 58537,
+ .180, 58543,180, 58549,180, 58553,180, 58631,180, 58661,
+ .180, 58667,180, 58669,180, 58679,180, 58697,180, 58723,
+ .180, 58733,180, 58739,180, 58751,180, 58787,180, 58789,
+ .180, 58823,180, 58829,180, 58841,180, 58849,180, 58859,
+ .180, 58871,180, 58873,180, 58877,180, 58879,180, 58901,
+ .180, 58903,180, 58907,180, 58919,180, 58927,180, 58933,
+ .180, 59009,180, 59011,180, 59027,180, 59041,180, 59051/
+ DATA ((n(i,j),i=3,4),j=490,979)/
+ .180, 59069,180, 59071,180, 59087,180, 59101,180, 59107,
+ .180, 59113,180, 59153,180, 59173,180, 59183,180, 59207,
+ .180, 59209,180, 59219,180, 59233,180, 59251,180, 59257,
+ .180, 59263,180, 59267,180, 59279,180, 59293,180, 59321,
+ .180, 59327,180, 59333,180, 59347,180, 59359,180, 59389,
+ .180, 59401,180, 59423,180, 59431,180, 59453,180, 59479,
+ .180, 59509,180, 59513,180, 59519,180, 59521,180, 59543,
+ .180, 59569,180, 59591,180, 59621,180, 59627,180, 59633,
+ .180, 59659,180, 59671,180, 59681,180, 59699,180, 59713,
+ .180, 59719,180, 59743,180, 59759,180, 59783,180, 59789,
+ .180, 59801,180, 59807,180, 59827,180, 59831,180, 59849,
+ .180, 59863,180, 59879,180, 59891,180, 59893,180, 59929,
+ .180, 59939,180, 59981,180, 59989,180, 59993,180, 59999,
+ .180, 60031,180, 60037,180, 60061,180, 60067,180, 60073,
+ .180, 60103,180, 60149,180, 60161,180, 60173,180, 60179,
+ .180, 60193,180, 60217,180, 60229,180, 60247,180, 60251,
+ .180, 60283,180, 60329,180, 60331,180, 60341,180, 60361,
+ .180, 60377,180, 60397,180, 60403,180, 60419,180, 60439,
+ .180, 60467,180, 60473,180, 60499,180, 60523,180, 60553,
+ .180, 60557,180, 60559,180, 60569,180, 60581,180, 60587,
+ .180, 60593,180, 60601,180, 60611,180, 60613,180, 60619,
+ .180, 60643,180, 60647,180, 60667,180, 60671,180, 60713,
+ .180, 60737,180, 60749,180, 60763,180, 60769,180, 60787,
+ .180, 60797,180, 60811,180, 60823,180, 60829,180, 60847,
+ .180, 60851,180, 60853,180, 60881,180, 60887,180, 60889,
+ .180, 60913,180, 60919,180, 60929,180, 60941,180, 60943,
+ .180, 60971,180, 60973,180, 60977,180, 60997,180, 61001,
+ .180, 61013,180, 61019,180, 61039,180, 61043,180, 61049,
+ .180, 61063,180, 61081,180, 61109,180, 61111,180, 61133,
+ .180, 61141,180, 61181,180, 61187,180, 61213,180, 61217,
+ .180, 61229,180, 61231,180, 61271,180, 61273,180, 61279,
+ .180, 61283,180, 61297,180, 61307,180, 61313,180, 61321,
+ .180, 61337,180, 61339,180, 61351,180, 61357,180, 61393,
+ .180, 61397,180, 61403,180, 61409,180, 61427,180, 61433,
+ .180, 61451,180, 61489,180, 61511,180, 61519,180, 61529,
+ .180, 61537,180, 61543,180, 61549,180, 61559,180, 61571,
+ .180, 61577,180, 61579,180, 61621,180, 61631,180, 61651,
+ .180, 61669,180, 61679,180, 61697,180, 61711,180, 61721,
+ .180, 61747,180, 61763,180, 61787,180, 61789,180, 61799,
+ .180, 61801,180, 61811,180, 61831,180, 61843,180, 61879,
+ .180, 61897,180, 61901,180, 61907,180, 61943,180, 61963,
+ .180, 61967,180, 61999,180, 62053,180, 62063,180, 62071,
+ .180, 62077,180, 62089,180, 62093,180, 62099,180, 62117,
+ .180, 62119,180, 62149,180, 62177,180, 62179,180, 62203,
+ .180, 62221,180, 62239,180, 62243,180, 62249,180, 62267,
+ .180, 62299,180, 62303,180, 62321,180, 62327,180, 62333,
+ .180, 62359,180, 62371,180, 62413,180, 62417,180, 62441,
+ .180, 62467,180, 62473,180, 62489,180, 62491,180, 62509,
+ .180, 62537,180, 62551,180, 62569,180, 62581,180, 62593,
+ .180, 62597,180, 62599,180, 62603,180, 62621,180, 62629,
+ .180, 62657,180, 62659,180, 62671,180, 62677,180, 62683,
+ .180, 62687,180, 62699,180, 62707,180, 62749,180, 62753,
+ .180, 62761,180, 62767,180, 62789,180, 62813,180, 62827,
+ .180, 62831,180, 62869,180, 62879,180, 62891,180, 62897,
+ .180, 62903,180, 62947,180, 62953,180, 62971,180, 62977,
+ .180, 62981,180, 62993,180, 63001,180, 63007,180, 63013,
+ .180, 63023,180, 63029,180, 63059,180, 63061,180, 63083,
+ .180, 63089,180, 63091,180, 63103,180, 63119,180, 63131,
+ .180, 63163,180, 63227,180, 63233,180, 63239,180, 63259,
+ .180, 63271,180, 63311,180, 63337,180, 63341,180, 63353,
+ .180, 63367,180, 63373,180, 63397,180, 63409,180, 63413,
+ .180, 63421,180, 63427,180, 63437,180, 63443,180, 63449,
+ .180, 63481,180, 63499,180, 63509,180, 63517,180, 63541,
+ .180, 63551,180, 63559,180, 63569,180, 63601,180, 63607,
+ .180, 63617,180, 63623,180, 63629,180, 63637,180, 63653,
+ .180, 63671,180, 63691,180, 63727,180, 63743,180, 63751,
+ .180, 63763,180, 63787,180, 63821,180, 63827,180, 63847,
+ .180, 63899,180, 63917,180, 63931,180, 63989,180, 63997,
+ .180, 64003,180, 64007,180, 64009,180, 64013,180, 64037,
+ .180, 64067,180, 64087,180, 64093,180, 64133,180, 64139,
+ .180, 64147,180, 64157,180, 64163,180, 64169,180, 64181,
+ .180, 64189,180, 64207,180, 64211,180, 64217,180, 64219,
+ .180, 64223,180, 64247,180, 64261,180, 64273,180, 64297,
+ .180, 64307,180, 64309,180, 64331,180, 64357,180, 64379,
+ .180, 64387,180, 64409,180, 64417,180, 64483,180, 64489,
+ .180, 64493,180, 64513,180, 64531,180, 64553,180, 64591,
+ .180, 64601,180, 64609,180, 64613,180, 64619,180, 64627,
+ .180, 64651,180, 64661,180, 64679,180, 64687,180, 64711,
+ .180, 64717,180, 64727,180, 64739,180, 64741,180, 64751,
+ .180, 64757,180, 64793,180, 64813,180, 64819,180, 64823,
+ .180, 64847,180, 64871,180, 64877,180, 64883,180, 64891,
+ .180, 64921,180, 64927,180, 64931,180, 64933,180, 64949,
+ .180, 64961,180, 64987,180, 65047,180, 65059,180, 65063,
+ .180, 65077,180, 65089,180, 65093,180, 65099,180, 65101,
+ .180, 65119,180, 65131,180, 65137,180, 65147,180, 65159,
+ .180, 65171,180, 65179,180, 65191,180, 65203,180, 65207,
+ .180, 65213,180, 65221,180, 65231,180, 65233,180, 65269,
+ .180, 65311,180, 65323,180, 65339,180, 65347,180, 65369,
+ .180, 65393,180, 65399,180, 65407,180, 65431,180, 65437,
+ .180, 65441,180, 65443,180, 65473,180, 65479,180, 65507,
+ .180, 65527,180, 65533,181, 13,181, 15,181, 33,
+ .181, 61,181, 67,181, 141,181, 151,181, 183,
+ .181, 187,181, 201,181, 207,181, 213,181, 217,
+ .181, 223,181, 225,181, 243,181, 253,181, 255,
+ .181, 277,181, 291,181, 297,181, 301,181, 327,
+ .181, 337,181, 357,181, 375,181, 423,181, 453,
+ .181, 477,181, 511,181, 531,181, 547,181, 553,
+ .181, 561,181, 565,181, 595,181, 607,181, 645/
+ DATA ((n(i,j),i=3,4),j=980,nmax)/
+ .181, 657,181, 663,181, 685,181, 687,181, 697,
+ .181, 745,181, 775,181, 787,181, 823,181, 825,
+ .181, 841,181, 853,181, 865,181, 895,181, 903,
+ .181, 943,181, 963,181, 973,181, 981,181, 1005,
+ .181, 1015,181, 1021,181, 1023,181, 1041,181, 1051,
+ .181, 1057,181, 1083,181, 1093,181, 1105,181, 1107,
+ .181, 1117,181, 1135,181, 1137,181, 1155,181, 1167,
+ .181, 1191,181, 1197,181, 1221,181, 1233,181, 1237,
+ .181, 1243,181, 1263/
+ end
+#endif
--- /dev/null
+#include <stdlib.h>
+#include <math.h>
+
+#ifdef CRAY
+void PROC_PROC(long int *f, int *i)
+#else
+#ifdef LINUX
+#ifdef PGI
+void proc_proc_(long int *f, int *i)
+#else
+void proc_proc__(long int *f, int *i)
+#endif
+#endif
+#ifdef SGI
+void proc_proc_(long int *f, int *i)
+#endif
+#if defined(WIN) && !defined(WINIFL)
+void _stdcall PROC_PROC(long int *f, int *i)
+#endif
+#ifdef WINIFL
+void proc_proc(long int *f, int *i)
+#endif
+#if defined(AIX) || defined(WINPGI)
+void proc_proc(long int *f, int *i)
+#endif
+#endif
+
+{
+static long int NaNQ;
+static long int NaNQm;
+
+if(*i==-1)
+ {
+ NaNQ=*f;
+ NaNQm=0xffffffff;
+ return;
+ }
+*i=0;
+if(*f==NaNQ)
+ *i=1;
+if(*f==NaNQm)
+ *i=1;
+}
+
+#ifdef CRAY
+void PROC_CONV(char *buf, int *i, int n)
+#endif
+#ifdef LINUX
+void proc_conv__(char *buf, int *i, int n)
+#endif
+#ifdef SGI
+void proc_conv_(char *buf, int *i, int n)
+#endif
+#if defined(AIX) || defined(WINPGI)
+void proc_conv(char *buf, int *i, int n)
+#endif
+#ifdef WIN
+void _stdcall PROC_CONV(char *buf, int *i, int n)
+#endif
+{
+int j;
+
+sscanf(buf,"%d",&j);
+*i=j;
+return;
+}
+
+#ifdef CRAY
+void PROC_CONV_R(char *buf, int *i, int n)
+#endif
+#ifdef LINUX
+void proc_conv_r__(char *buf, int *i, int n)
+#endif
+#ifdef SGI
+void proc_conv_r_(char *buf, int *i, int n)
+#endif
+#if defined(AIX) || defined(WINPGI)
+void proc_conv_r(char *buf, int *i, int n)
+#endif
+#ifdef WIN
+void _stdcall PROC_CONV_R(char *buf, int *i, int n)
+#endif
+
+{
+
+/* sprintf(buf,"%d",*i); */
+
+return;
+}
+
+
+#ifndef IMSL
+#ifdef CRAY
+void DSVRGP(int *n, double *tab1, double *tab2, int *itab)
+#endif
+#ifdef LINUX
+void dsvrgp__(int *n, double *tab1, double *tab2, int *itab)
+#endif
+#ifdef SGI
+void dsvrgp_(int *n, double *tab1, double *tab2, int *itab)
+#endif
+#if defined(AIX) || defined(WINPGI)
+void dsvrgp(int *n, double *tab1, double *tab2, int *itab)
+#endif
+#ifdef WIN
+void _stdcall DSVRGP(int *n, double *tab1, double *tab2, int *itab)
+#endif
+{
+double t;
+int i,j,k;
+
+if(tab1 != tab2)
+ {
+ for(i=0; i<*n; i++)
+ tab2[i]=tab1[i];
+ }
+k=0;
+while(k<*n-1)
+ {
+ j=k;
+ t=tab2[k];
+ for(i=k+1; i<*n; i++)
+ if(t>tab2[i])
+ {
+ j=i;
+ t=tab2[i];
+ }
+ if(j!=k)
+ {
+ tab2[j]=tab2[k];
+ tab2[k]=t;
+ i=itab[j];
+ itab[j]=itab[k];
+ itab[k]=i;
+ }
+ k++;
+ }
+}
+#endif
--- /dev/null
+ double precision function qwolynes(seg1,seg2,flag,seg3,seg4)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.VAR'
+ integer i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,
+ & secseg
+ integer nsep /3/
+ double precision dist,qm
+ double precision qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM
+ logical lprn /.false./
+ logical flag
+ double precision sigm,x
+ sigm(x)=0.25d0*x
+ qq = 0.0d0
+ nl=0
+ if(flag) then
+ do il=seg1+nsep,seg2
+ do jl=seg1,il-nsep
+ nl=nl+1
+ d0ij=dsqrt((cref(1,jl)-cref(1,il))**2+
+ & (cref(2,jl)-cref(2,il))**2+
+ & (cref(3,jl)-cref(3,il))**2)
+ dij=dist(il,jl)
+ qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
+ if (itype(il).ne.10 .or. itype(jl).ne.10) then
+ nl=nl+1
+ d0ijCM=dsqrt(
+ & (cref(1,jl+nres)-cref(1,il+nres))**2+
+ & (cref(2,jl+nres)-cref(2,il+nres))**2+
+ & (cref(3,jl+nres)-cref(3,il+nres))**2)
+ dijCM=dist(il+nres,jl+nres)
+ qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
+ endif
+ qq = qq+qqij+qqijCM
+ enddo
+ enddo
+ qq = qq/nl
+ else
+ do il=seg1,seg2
+ if((seg3-il).lt.3) then
+ secseg=il+3
+ else
+ secseg=seg3
+ endif
+ do jl=secseg,seg4
+ nl=nl+1
+ d0ij=dsqrt((cref(1,jl)-cref(1,il))**2+
+ & (cref(2,jl)-cref(2,il))**2+
+ & (cref(3,jl)-cref(3,il))**2)
+ dij=dist(il,jl)
+ qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
+ if (itype(il).ne.10 .or. itype(jl).ne.10) then
+ nl=nl+1
+ d0ijCM=dsqrt(
+ & (cref(1,jl+nres)-cref(1,il+nres))**2+
+ & (cref(2,jl+nres)-cref(2,il+nres))**2+
+ & (cref(3,jl+nres)-cref(3,il+nres))**2)
+ dijCM=dist(il+nres,jl+nres)
+ qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
+ endif
+ qq = qq+qqij+qqijCM
+ enddo
+ enddo
+ qq = qq/nl
+ endif
+ qwolynes=1.0d0-qq
+ return
+ end
+c-------------------------------------------------------------------
+ subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+ integer i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,
+ & secseg
+ integer nsep /3/
+ double precision dist
+ double precision dij,d0ij,dijCM,d0ijCM
+ logical lprn /.false./
+ logical flag
+ double precision sigm,x,sim,dd0,fac,ddqij
+ sigm(x)=0.25d0*x
+
+ do i=0,nres
+ do j=1,3
+ dqwol(j,i)=0.0d0
+ dxqwol(j,i)=0.0d0
+ enddo
+ enddo
+ nl=0
+ if(flag) then
+ do il=seg1+nsep,seg2
+ do jl=seg1,il-nsep
+ nl=nl+1
+ d0ij=dsqrt((cref(1,jl)-cref(1,il))**2+
+ & (cref(2,jl)-cref(2,il))**2+
+ & (cref(3,jl)-cref(3,il))**2)
+ dij=dist(il,jl)
+ sim = 1.0d0/sigm(d0ij)
+ sim = sim*sim
+ dd0 = dij-d0ij
+ fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
+ do k=1,3
+ ddqij = (c(k,il)-c(k,jl))*fac
+ dqwol(k,il)=dqwol(k,il)+ddqij
+ dqwol(k,jl)=dqwol(k,jl)-ddqij
+ enddo
+
+ if (itype(il).ne.10 .or. itype(jl).ne.10) then
+ nl=nl+1
+ d0ijCM=dsqrt(
+ & (cref(1,jl+nres)-cref(1,il+nres))**2+
+ & (cref(2,jl+nres)-cref(2,il+nres))**2+
+ & (cref(3,jl+nres)-cref(3,il+nres))**2)
+ dijCM=dist(il+nres,jl+nres)
+ sim = 1.0d0/sigm(d0ijCM)
+ sim = sim*sim
+ dd0=dijCM-d0ijCM
+ fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
+ do k=1,3
+ ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
+ dxqwol(k,il)=dxqwol(k,il)+ddqij
+ dxqwol(k,jl)=dxqwol(k,jl)-ddqij
+ enddo
+ endif
+ enddo
+ enddo
+ else
+ do il=seg1,seg2
+ if((seg3-il).lt.3) then
+ secseg=il+3
+ else
+ secseg=seg3
+ endif
+ do jl=secseg,seg4
+ nl=nl+1
+ d0ij=dsqrt((cref(1,jl)-cref(1,il))**2+
+ & (cref(2,jl)-cref(2,il))**2+
+ & (cref(3,jl)-cref(3,il))**2)
+ dij=dist(il,jl)
+ sim = 1.0d0/sigm(d0ij)
+ sim = sim*sim
+ dd0 = dij-d0ij
+ fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
+ do k=1,3
+ ddqij = (c(k,il)-c(k,jl))*fac
+ dqwol(k,il)=dqwol(k,il)+ddqij
+ dqwol(k,jl)=dqwol(k,jl)-ddqij
+ enddo
+ if (itype(il).ne.10 .or. itype(jl).ne.10) then
+ nl=nl+1
+ d0ijCM=dsqrt(
+ & (cref(1,jl+nres)-cref(1,il+nres))**2+
+ & (cref(2,jl+nres)-cref(2,il+nres))**2+
+ & (cref(3,jl+nres)-cref(3,il+nres))**2)
+ dijCM=dist(il+nres,jl+nres)
+ sim = 1.0d0/sigm(d0ijCM)
+ sim=sim*sim
+ dd0 = dijCM-d0ijCM
+ fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
+ do k=1,3
+ ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
+ dxqwol(k,il)=dxqwol(k,il)+ddqij
+ dxqwol(k,jl)=dxqwol(k,jl)-ddqij
+ enddo
+ endif
+ enddo
+ enddo
+ endif
+ do i=0,nres
+ do j=1,3
+ dqwol(j,i)=dqwol(j,i)/nl
+ dxqwol(j,i)=dxqwol(j,i)/nl
+ enddo
+ enddo
+ return
+ end
+c-------------------------------------------------------------------
+ subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.VAR'
+ integer seg1,seg2,seg3,seg4
+ logical flag
+ double precision qwolan(3,0:maxres),cdummy(3,0:maxres2),
+ & qwolxan(3,0:maxres),q1,q2
+ double precision delta /1.0d-10/
+ do i=0,nres
+ do j=1,3
+ q1=qwolynes(seg1,seg2,flag,seg3,seg4)
+ cdummy(j,i)=c(j,i)
+ c(j,i)=c(j,i)+delta
+ q2=qwolynes(seg1,seg2,flag,seg3,seg4)
+ qwolan(j,i)=(q2-q1)/delta
+ c(j,i)=cdummy(j,i)
+ enddo
+ enddo
+ do i=0,nres
+ do j=1,3
+ q1=qwolynes(seg1,seg2,flag,seg3,seg4)
+ cdummy(j,i+nres)=c(j,i+nres)
+ c(j,i+nres)=c(j,i+nres)+delta
+ q2=qwolynes(seg1,seg2,flag,seg3,seg4)
+ qwolxan(j,i)=(q2-q1)/delta
+ c(j,i+nres)=cdummy(j,i+nres)
+ enddo
+ enddo
+c write(iout,*) "Numerical Q carteisan gradients backbone: "
+c do i=0,nct
+c write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
+c enddo
+c write(iout,*) "Numerical Q carteisan gradients side-chain: "
+c do i=0,nct
+c write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
+c enddo
+ return
+ end
+c------------------------------------------------------------------------
+ subroutine EconstrQ
+c MD with umbrella_sampling using Wolyne's distance measure as a constraint
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+#ifndef LANG0
+ include 'COMMON.LANGEVIN'
+#else
+ include 'COMMON.LANGEVIN.lang0'
+#endif
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ include 'COMMON.TIME1'
+ double precision uzap1,uzap2,hm1,hm2,hmnum
+ double precision ucdelan,dUcartan(3,0:MAXRES)
+ & ,dUxcartan(3,0:MAXRES),cdummy(3,0:MAXRES),
+ & duconst(3,0:MAXRES),duxconst(3,0:MAXRES)
+ integer kstart,kend,lstart,lend,idummy
+ double precision delta /1.0d-7/
+ do i=0,nres
+ do j=1,3
+ duconst(j,i)=0.0d0
+ dudconst(j,i)=0.0d0
+ duxconst(j,i)=0.0d0
+ dudxconst(j,i)=0.0d0
+ enddo
+ enddo
+ Uconst=0.0d0
+ do i=1,nfrag
+ qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.
+ & ,idummy,idummy)
+ Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
+c Calculating the derivatives of Constraint energy with respect to Q
+ Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),
+ & qinfrag(i,iset))
+c hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
+c hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
+c hmnum=(hm2-hm1)/delta
+c write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
+c & qinfrag(i,iset))
+c write(iout,*) "harmonicnum frag", hmnum
+c Calculating the derivatives of Q with respect to cartesian coordinates
+ call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.
+ & ,idummy,idummy)
+c write(iout,*) "dqwol "
+c do ii=1,nres
+c write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
+c enddo
+c write(iout,*) "dxqwol "
+c do ii=1,nres
+c write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
+c enddo
+c Calculating numerical gradients of dU/dQi and dQi/dxi
+c call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
+c & ,idummy,idummy)
+c The gradients of Uconst in Cs
+ do ii=0,nres
+ do j=1,3
+ duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
+ dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
+ enddo
+ enddo
+ enddo
+ do i=1,npair
+ kstart=ifrag(1,ipair(1,i,iset),iset)
+ kend=ifrag(2,ipair(1,i,iset),iset)
+ lstart=ifrag(1,ipair(2,i,iset),iset)
+ lend=ifrag(2,ipair(2,i,iset),iset)
+ qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
+ Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
+c Calculating dU/dQ
+ Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
+c hm1=harmonic(qpair(i),qinpair(i,iset))
+c hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
+c hmnum=(hm2-hm1)/delta
+c write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
+c & qinpair(i,iset))
+c write(iout,*) "harmonicnum pair ", hmnum
+c Calculating dQ/dXi
+ call qwolynes_prim(kstart,kend,.false.
+ & ,lstart,lend)
+c write(iout,*) "dqwol "
+c do ii=1,nres
+c write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
+c enddo
+c write(iout,*) "dxqwol "
+c do ii=1,nres
+c write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
+c enddo
+c Calculating numerical gradients
+c call qwol_num(kstart,kend,.false.
+c & ,lstart,lend)
+c The gradients of Uconst in Cs
+ do ii=0,nres
+ do j=1,3
+ duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
+ dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
+ enddo
+ enddo
+ enddo
+c write(iout,*) "Uconst inside subroutine ", Uconst
+c Transforming the gradients from Cs to dCs for the backbone
+ do i=0,nres
+ do j=i+1,nres
+ do k=1,3
+ dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
+ enddo
+ enddo
+ enddo
+c Transforming the gradients from Cs to dCs for the side chains
+ do i=1,nres
+ do j=1,3
+ dudxconst(j,i)=duxconst(j,i)
+ enddo
+ enddo
+c write(iout,*) "dU/ddc backbone "
+c do ii=0,nres
+c write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
+c enddo
+c write(iout,*) "dU/ddX side chain "
+c do ii=1,nres
+c write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
+c enddo
+c Calculating numerical gradients of dUconst/ddc and dUconst/ddx
+c call dEconstrQ_num
+ return
+ end
+c-----------------------------------------------------------------------
+ subroutine dEconstrQ_num
+c Calculating numerical dUconst/ddc and dUconst/ddx
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+#ifndef LANG0
+ include 'COMMON.LANGEVIN'
+#else
+ include 'COMMON.LANGEVIN.lang0'
+#endif
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ include 'COMMON.TIME1'
+ double precision uzap1,uzap2
+ double precision dUcartan(3,0:MAXRES)
+ & ,dUxcartan(3,0:MAXRES),cdummy(3,0:MAXRES)
+ integer kstart,kend,lstart,lend,idummy
+ double precision delta /1.0d-7/
+c For the backbone
+ do i=0,nres-1
+ do j=1,3
+ dUcartan(j,i)=0.0d0
+ cdummy(j,i)=dc(j,i)
+ dc(j,i)=dc(j,i)+delta
+ call chainbuild_cart
+ uzap2=0.0d0
+ do ii=1,nfrag
+ qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.
+ & ,idummy,idummy)
+ uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),
+ & qinfrag(ii,iset))
+ enddo
+ do ii=1,npair
+ kstart=ifrag(1,ipair(1,ii,iset),iset)
+ kend=ifrag(2,ipair(1,ii,iset),iset)
+ lstart=ifrag(1,ipair(2,ii,iset),iset)
+ lend=ifrag(2,ipair(2,ii,iset),iset)
+ qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
+ uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),
+ & qinpair(ii,iset))
+ enddo
+ dc(j,i)=cdummy(j,i)
+ call chainbuild_cart
+ uzap1=0.0d0
+ do ii=1,nfrag
+ qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.
+ & ,idummy,idummy)
+ uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),
+ & qinfrag(ii,iset))
+ enddo
+ do ii=1,npair
+ kstart=ifrag(1,ipair(1,ii,iset),iset)
+ kend=ifrag(2,ipair(1,ii,iset),iset)
+ lstart=ifrag(1,ipair(2,ii,iset),iset)
+ lend=ifrag(2,ipair(2,ii,iset),iset)
+ qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
+ uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),
+ & qinpair(ii,iset))
+ enddo
+ ducartan(j,i)=(uzap2-uzap1)/(delta)
+ enddo
+ enddo
+c Calculating numerical gradients for dU/ddx
+ do i=0,nres-1
+ duxcartan(j,i)=0.0d0
+ do j=1,3
+ cdummy(j,i)=dc(j,i+nres)
+ dc(j,i+nres)=dc(j,i+nres)+delta
+ call chainbuild_cart
+ uzap2=0.0d0
+ do ii=1,nfrag
+ qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.
+ & ,idummy,idummy)
+ uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),
+ & qinfrag(ii,iset))
+ enddo
+ do ii=1,npair
+ kstart=ifrag(1,ipair(1,ii,iset),iset)
+ kend=ifrag(2,ipair(1,ii,iset),iset)
+ lstart=ifrag(1,ipair(2,ii,iset),iset)
+ lend=ifrag(2,ipair(2,ii,iset),iset)
+ qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
+ uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),
+ & qinpair(ii,iset))
+ enddo
+ dc(j,i+nres)=cdummy(j,i)
+ call chainbuild_cart
+ uzap1=0.0d0
+ do ii=1,nfrag
+ qfrag(ii)=qwolynes(ifrag(1,ii,iset),
+ & ifrag(2,ii,iset),.true.,idummy,idummy)
+ uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),
+ & qinfrag(ii,iset))
+ enddo
+ do ii=1,npair
+ kstart=ifrag(1,ipair(1,ii,iset),iset)
+ kend=ifrag(2,ipair(1,ii,iset),iset)
+ lstart=ifrag(1,ipair(2,ii,iset),iset)
+ lend=ifrag(2,ipair(2,ii,iset),iset)
+ qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
+ uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),
+ & qinpair(ii,iset))
+ enddo
+ duxcartan(j,i)=(uzap2-uzap1)/(delta)
+ enddo
+ enddo
+ write(iout,*) "Numerical dUconst/ddc backbone "
+ do ii=0,nres
+ write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
+ enddo
+c write(iout,*) "Numerical dUconst/ddx side-chain "
+c do ii=1,nres
+c write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
+c enddo
+ return
+ end
+c---------------------------------------------------------------------------
--- /dev/null
+ double precision function qwolynes(seg1,seg2,flag,seg3,seg4)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+ integer i,j,jl,k,l,il,kl,nl,np,seg1,seg2,seg3,seg4,secseg
+ integer nsep /3/
+ double precision dist,qm
+ double precision qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM
+ logical lprn /.false./
+ logical flag
+ qq = 0.0d0
+ nl=0
+ do i=0,nres
+ do j=1,3
+ dqwol(j,i)=0.0d0
+ dxqwol(j,i)=0.0d0
+ enddo
+ enddo
+ if (lprn) then
+ write (iout,*) "seg1",seg1," seg2",seg2," seg3",seg3," seg4",seg4,
+ & " flag",flag
+ call flush(iout)
+ endif
+ if (flag) then
+ do il=seg1+nsep,seg2
+ do jl=seg1,il-nsep
+ nl=nl+1
+ if (itype(il).ne.10) then
+ ilnres=il+nres
+ else
+ ilnres=il
+ endif
+ if (itype(jl).ne.10) then
+ jlnres=jl+nres
+ else
+ jlnres=jl
+ endif
+ qqijCM = qcontrib(il,jl,ilnres,jlnres)
+ qq = qq+qqijCM
+ if (lprn) then
+ write (iout,*) "qqijCM",qqijCM
+ call flush(iout)
+ endif
+ enddo
+ enddo
+ if (lprn) then
+ write (iout,*) "nl",nl," qq",qq
+ call flush(iout)
+ endif
+ else
+ do il=seg1,seg2
+ if((seg3-il).lt.3) then
+ secseg=il+3
+ else
+ secseg=seg3
+ endif
+ do jl=secseg,seg4
+ nl=nl+1
+ if (itype(il).ne.10) then
+ ilnres=il+nres
+ else
+ ilnres=il
+ endif
+ if (itype(jl).ne.10) then
+ jlnres=jl+nres
+ else
+ jlnres=jl
+ endif
+ qqijCM = qcontrib(il,jl,ilnres,jlnres)
+ qq = qq+qqijCM
+ if (lprn) then
+ write (iout,*) "qqijCM",qqijCM
+ call flush(iout)
+ endif
+ enddo
+ enddo
+ endif
+ qq = qq/nl
+ qwolynes=1.0d0-qq
+ do i=0,nres
+ do j=1,3
+ dqwol(j,i)=dqwol(j,i)/nl
+ dxqwol(j,i)=dxqwol(j,i)/nl
+ enddo
+ enddo
+ return
+ end
+c-------------------------------------------------------------------
+ subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+ integer seg1,seg2,seg3,seg4
+ logical flag
+ double precision qwolan(3,0:maxres),cdummy(3,0:maxres2),
+ & qwolxan(3,0:maxres),q1,q2
+ double precision delta /1.0d-7/
+ write (iout,*) "seg1",seg1," seg2",seg2," seg3",seg3," seg4",seg4
+ write(iout,*) "dQ/dc backbone "
+ do i=0,nres
+ write(iout,'(i5,3e15.5)') i, (dqwol(j,i),j=1,3)
+ enddo
+ write(iout,*) "dQ/dX side chain "
+ do i=1,nres
+ write(iout,'(i5,3e15.5)') i,(dxqwol(j,i),j=1,3)
+ enddo
+ do i=1,nres
+ do j=1,3
+ cdummy(j,i)=c(j,i)
+ c(j,i)=c(j,i)-delta
+ q1=qwolynes(seg1,seg2,flag,seg3,seg4)
+ c(j,i)=cdummy(j,i)+delta
+ q2=qwolynes(seg1,seg2,flag,seg3,seg4)
+ qwolan(j,i)=0.5d0*(q2-q1)/delta
+ c(j,i)=cdummy(j,i)
+c write (iout,*) "i",i," j",j," q1",q1," a2",q2
+ enddo
+ enddo
+ do i=1,nres
+ do j=1,3
+ cdummy(j,i+nres)=c(j,i+nres)
+ c(j,i+nres)=c(j,i+nres)-delta
+ q1=qwolynes(seg1,seg2,flag,seg3,seg4)
+ c(j,i+nres)=cdummy(j,i+nres)+delta
+ q2=qwolynes(seg1,seg2,flag,seg3,seg4)
+ qwolxan(j,i)=0.5d0*(q2-q1)/delta
+ c(j,i+nres)=cdummy(j,i+nres)
+ enddo
+ enddo
+ write(iout,*) "Numerical Q cartesian gradients backbone: "
+ do i=0,nres
+ write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
+ enddo
+ write(iout,*) "Numerical Q cartesian gradients side-chain: "
+ do i=0,nres
+ write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
+ enddo
+ return
+ end
+c------------------------------------------------------------------------
+ subroutine EconstrQ
+c MD with umbrella_sampling using Wolyne's distance measure as a constraint
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+#ifndef LANG0
+ include 'COMMON.LANGEVIN'
+#else
+ include 'COMMON.LANGEVIN.lang0'
+#endif
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ include 'COMMON.TIME1'
+ double precision uzap1,uzap2,hm1,hm2,hmnum
+ double precision ucdelan,dUcartan(3,0:MAXRES)
+ & ,dUxcartan(3,0:MAXRES),cdummy(3,0:MAXRES),
+ & duconst(3,0:MAXRES),duxconst(3,0:MAXRES)
+ integer kstart,kend,lstart,lend,idummy
+ double precision delta /1.0d-7/
+ do i=0,nres
+ do j=1,3
+ duconst(j,i)=0.0d0
+ dudconst(j,i)=0.0d0
+ duxconst(j,i)=0.0d0
+ dudxconst(j,i)=0.0d0
+ enddo
+ enddo
+ Uconst=0.0d0
+ do i=1,nfrag
+ qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.
+ & ,idummy,idummy)
+ Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
+c Calculating the derivatives of Constraint energy with respect to Q
+ Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),qinfrag(i,iset))
+c Calculating the derivatives of Q with respect to cartesian coordinates
+ do ii=0,nres
+ do j=1,3
+ duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
+ dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
+ enddo
+ enddo
+c write (iout,*) "Calling qwol_num"
+c call qwol_num(ifrag(1,i),ifrag(2,i),.true.,idummy,idummy)
+ enddo
+ do i=1,npair
+ kstart=ifrag(1,ipair(1,i,iset),iset)
+ kend=ifrag(2,ipair(1,i,iset),iset)
+ lstart=ifrag(1,ipair(2,i,iset),iset)
+ lend=ifrag(2,ipair(2,i,iset),iset)
+ qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
+ Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
+c Calculating dU/dQ
+ Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
+c Calculating dQ/dXi
+ do ii=0,nres
+ do j=1,3
+ duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
+ dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
+ enddo
+ enddo
+ enddo
+c write(iout,*) "Uconst inside subroutine ", Uconst
+c Transforming the gradients from Cs to dCs for the backbone
+ do i=0,nres
+ do j=i+1,nres
+ do k=1,3
+ dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
+ enddo
+ enddo
+ enddo
+c Transforming the gradients from Cs to dCs for the side chains
+ do i=1,nres
+ do j=1,3
+ dudxconst(j,i)=duxconst(j,i)
+ enddo
+ enddo
+c write(iout,*) "dU/dc backbone "
+c do ii=0,nres
+c write(iout,'(i5,3e15.5)') ii, (duconst(j,ii),j=1,3)
+c enddo
+c write(iout,*) "dU/dX side chain "
+c do ii=1,nres
+c write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
+c enddo
+c write(iout,*) "dU/ddc backbone "
+c do ii=0,nres
+c write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
+c enddo
+c write(iout,*) "dU/ddX side chain "
+c do ii=1,nres
+c write(iout,'(i5,3e15.5)') ii,(dudxconst(j,ii),j=1,3)
+c enddo
+c Calculating numerical gradients of dUconst/ddc and dUconst/ddx
+c call dEconstrQ_num
+ return
+ end
+c-----------------------------------------------------------------------
+ subroutine dEconstrQ_num
+c Calculating numerical dUconst/ddc and dUconst/ddx
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+#ifndef LANG0
+ include 'COMMON.LANGEVIN'
+#else
+ include 'COMMON.LANGEVIN.lang0'
+#endif
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ include 'COMMON.TIME1'
+ double precision uzap1,uzap2
+ double precision dUcartan(3,0:MAXRES)
+ & ,dUxcartan(3,0:MAXRES),cdummy(3,0:MAXRES)
+ integer kstart,kend,lstart,lend,idummy
+ double precision delta /1.0d-7/
+c For the backbone
+ do i=0,nres-1
+ do j=1,3
+ dUcartan(j,i)=0.0d0
+ cdummy(j,i)=dc(j,i)
+ dc(j,i)=dc(j,i)+delta
+ call chainbuild_cart
+ uzap2=0.0d0
+ do ii=1,nfrag
+ qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),
+ & .true.,idummy,idummy)
+ uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),
+ & qinfrag(ii,iset))
+ enddo
+ do ii=1,npair
+ kstart=ifrag(1,ipair(1,ii,iset),iset)
+ kend=ifrag(2,ipair(1,ii,iset),iset)
+ lstart=ifrag(1,ipair(2,ii,iset),iset)
+ lend=ifrag(2,ipair(2,ii,iset),iset)
+ qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
+ uzap2=uzap2+wpair(ii,iset)*
+ & harmonic(qpair(ii),qinpair(ii,iset))
+ enddo
+ dc(j,i)=cdummy(j,i)
+ call chainbuild_cart
+ uzap1=0.0d0
+ do ii=1,nfrag
+ qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),
+ & .true.,idummy,idummy)
+ uzap1=uzap1+wfrag(ii,iset)*
+ & harmonic(qfrag(ii),qinfrag(ii,iset))
+ enddo
+ do ii=1,npair
+ kstart=ifrag(1,ipair(1,ii,iset),iset)
+ kend=ifrag(2,ipair(1,ii,iset),iset)
+ lstart=ifrag(1,ipair(2,ii,iset),iset)
+ lend=ifrag(2,ipair(2,ii,iset),iset)
+ qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
+ uzap1=uzap1+wpair(ii,iset)*
+ & harmonic(qpair(ii),qinpair(ii,iset))
+ enddo
+ ducartan(j,i)=(uzap2-uzap1)/(delta)
+ enddo
+ enddo
+c Calculating numerical gradients for dU/ddx
+ do i=0,nres-1
+ do j=1,3
+ duxcartan(j,i)=0.0d0
+ enddo
+ do j=1,3
+ cdummy(j,i)=dc(j,i+nres)
+ dc(j,i+nres)=dc(j,i+nres)+delta
+ call chainbuild_cart
+ uzap2=0.0d0
+ do ii=1,nfrag
+ qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),
+ & .true.,idummy,idummy)
+ uzap2=uzap2+wfrag(ii,iset)*
+ & harmonic(qfrag(ii),qinfrag(ii,iset))
+ enddo
+ do ii=1,npair
+ kstart=ifrag(1,ipair(1,ii,iset),iset)
+ kend=ifrag(2,ipair(1,ii,iset),iset)
+ lstart=ifrag(1,ipair(2,ii,iset),iset)
+ lend=ifrag(2,ipair(2,ii,iset),iset)
+ qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
+ uzap2=uzap2+wpair(ii,iset)*
+ & harmonic(qpair(ii),qinpair(ii,iset))
+ enddo
+ dc(j,i+nres)=cdummy(j,i)
+ call chainbuild_cart
+ uzap1=0.0d0
+ do ii=1,nfrag
+ qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),
+ & .true.,idummy,idummy)
+ uzap1=uzap1+wfrag(ii,iset)*
+ & harmonic(qfrag(ii),qinfrag(ii,iset))
+ enddo
+ do ii=1,npair
+ kstart=ifrag(1,ipair(1,ii,iset),iset)
+ kend=ifrag(2,ipair(1,ii,iset),iset)
+ lstart=ifrag(1,ipair(2,ii,iset),iset)
+ lend=ifrag(2,ipair(2,ii,iset),iset)
+ qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
+ uzap1=uzap1+wpair(ii,iset)*
+ & harmonic(qpair(ii),qinpair(ii,iset))
+ enddo
+ duxcartan(j,i)=(uzap2-uzap1)/(delta)
+ enddo
+ enddo
+ write(iout,*) "Numerical dUconst/ddc backbone "
+ do ii=0,nres
+ write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
+ enddo
+ write(iout,*) "Numerical dUconst/ddx side-chain "
+ do ii=1,nres
+ write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
+ enddo
+ return
+ end
+c---------------------------------------------------------------------------
+ double precision function qcontrib(il,jl,il1,jl1)
+ implicit none
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.MD'
+ integer i,j,k,il,jl,il1,jl1,nd
+ double precision dist
+ external dist
+ double precision dij1,dij2,dij3,dij4,d0ij1,d0ij2,d0ij3,d0ij4,fac,
+ & fac1,ddave,ssij,ddqij
+ logical lprn /.false./
+ d0ij1=dsqrt((cref(1,jl)-cref(1,il))**2+
+ & (cref(2,jl)-cref(2,il))**2+
+ & (cref(3,jl)-cref(3,il))**2)
+ dij1=dist(il,jl)
+ ddave=(dij1-d0ij1)**2
+ nd=1
+ if (jl1.ne.jl) then
+ d0ij2=dsqrt((cref(1,jl1)-cref(1,il))**2+
+ & (cref(2,jl1)-cref(2,il))**2+
+ & (cref(3,jl1)-cref(3,il))**2)
+ dij2=dist(il,jl1)
+ ddave=ddave+(dij2-d0ij2)**2
+ nd=nd+1
+ endif
+ if (il1.ne.il) then
+ d0ij3=dsqrt((cref(1,jl)-cref(1,il1))**2+
+ & (cref(2,jl)-cref(2,il1))**2+
+ & (cref(3,jl)-cref(3,il1))**2)
+ dij3=dist(il1,jl)
+ ddave=ddave+(dij3-d0ij3)**2
+ nd=nd+1
+ endif
+ if (il1.ne.il .and. jl1.ne.jl) then
+ d0ij4=dsqrt((cref(1,jl1)-cref(1,il1))**2+
+ & (cref(2,jl1)-cref(2,il1))**2+
+ & (cref(3,jl1)-cref(3,il1))**2)
+ dij4=dist(il1,jl1)
+ ddave=ddave+(dij4-d0ij4)**2
+ nd=nd+1
+ endif
+ ddave=ddave/nd
+ if (lprn) then
+ write (iout,*) "il",il," jl",jl,
+ & " itype",itype(il),itype(jl)," nd",nd
+ write (iout,*)"d0ij",d0ij1,d0ij2,d0ij3,d0ij4,
+ & " dij",dij1,dij2,dij3,dij4," ddave",ddave
+ call flush(iout)
+ endif
+c ssij = (0.25d0*d0ij1)**2
+ if (il.ne.il1 .and. jl.ne.jl1) then
+ ssij = 16.0d0/(d0ij1*d0ij4)
+ else
+ ssij = 16.0d0/(d0ij1*d0ij1)
+ endif
+ qcontrib = dexp(-0.5d0*ddave*ssij)
+c Compute gradient
+ fac1 = qcontrib*ssij/nd
+ fac = fac1*(dij1-d0ij1)/dij1
+ do k=1,3
+ ddqij = (c(k,il)-c(k,jl))*fac
+ dqwol(k,il)=dqwol(k,il)+ddqij
+ dqwol(k,jl)=dqwol(k,jl)-ddqij
+ enddo
+ if (jl1.ne.jl) then
+ fac = fac1*(dij2-d0ij2)/dij2
+ do k=1,3
+ ddqij = (c(k,il)-c(k,jl1))*fac
+ dqwol(k,il)=dqwol(k,il)+ddqij
+ dxqwol(k,jl)=dxqwol(k,jl)-ddqij
+ enddo
+ endif
+ if (il1.ne.il) then
+ fac = fac1*(dij3-d0ij3)/dij3
+ do k=1,3
+ ddqij = (c(k,il1)-c(k,jl))*fac
+ dxqwol(k,il)=dxqwol(k,il)+ddqij
+ dqwol(k,jl)=dqwol(k,jl)-ddqij
+ enddo
+ endif
+ if (il1.ne.il .and. jl1.ne.jl) then
+ fac = fac1*(dij4-d0ij4)/dij4
+ do k=1,3
+ ddqij = (c(k,il1)-c(k,jl1))*fac
+ dxqwol(k,il)=dxqwol(k,il)+ddqij
+ dxqwol(k,jl)=dxqwol(k,jl)-ddqij
+ enddo
+ endif
+ return
+ end
--- /dev/null
+ double precision function qwolynes(seg1,seg2,flag,seg3,seg4)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+ integer i,j,jl,k,l,il,kl,nl,np,seg1,seg2,seg3,seg4,secseg
+ integer nsep /3/
+ double precision dist,qm
+ double precision qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM
+ logical lprn /.false./
+ logical flag
+ qq = 0.0d0
+ nl=0
+ do i=0,nres
+ do j=1,3
+ dqwol(j,i)=0.0d0
+ dxqwol(j,i)=0.0d0
+ enddo
+ enddo
+ if (lprn) then
+ write (iout,*) "seg1",seg1," seg2",seg2," seg3",seg3," seg4",seg4,
+ & " flag",flag
+ call flush(iout)
+ endif
+ if (flag) then
+ do il=seg1+nsep,seg2
+ do jl=seg1,il-nsep
+ nl=nl+1
+ if (itype(il).ne.10) then
+ ilnres=il+nres
+ else
+ ilnres=il
+ endif
+ if (itype(jl).ne.10) then
+ jlnres=jl+nres
+ else
+ jlnres=jl
+ endif
+ qqijCM = qcontrib(il,jl,ilnres,jlnres)
+ qq = qq+qqijCM
+ if (lprn) then
+ write (iout,*) "qqijCM",qqijCM
+ call flush(iout)
+ endif
+ enddo
+ enddo
+ if (lprn) then
+ write (iout,*) "nl",nl," qq",qq
+ call flush(iout)
+ endif
+ else
+ do il=seg1,seg2
+ if((seg3-il).lt.3) then
+ secseg=il+3
+ else
+ secseg=seg3
+ endif
+ do jl=secseg,seg4
+ nl=nl+1
+ if (itype(il).ne.10) then
+ ilnres=il+nres
+ else
+ ilnres=il
+ endif
+ if (itype(jl).ne.10) then
+ jlnres=jl+nres
+ else
+ jlnres=jl
+ endif
+ qqijCM = qcontrib(il,jl,ilnres,jlnres)
+ qq = qq+qqijCM
+ if (lprn) then
+ write (iout,*) "qqijCM",qqijCM
+ call flush(iout)
+ endif
+ enddo
+ enddo
+ endif
+ qq = qq/nl
+ qwolynes=1.0d0-qq
+ do i=0,nres
+ do j=1,3
+ dqwol(j,i)=dqwol(j,i)/nl
+ dxqwol(j,i)=dxqwol(j,i)/nl
+ enddo
+ enddo
+ return
+ end
+c-------------------------------------------------------------------
+ subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+ integer seg1,seg2,seg3,seg4
+ logical flag
+ double precision qwolan(3,0:maxres),cdummy(3,0:maxres2),
+ & qwolxan(3,0:maxres),q1,q2
+ double precision delta /1.0d-7/
+ write (iout,*) "seg1",seg1," seg2",seg2," seg3",seg3," seg4",seg4
+ write(iout,*) "dQ/dc backbone "
+ do i=0,nres
+ write(iout,'(i5,3e15.5)') i, (dqwol(j,i),j=1,3)
+ enddo
+ write(iout,*) "dQ/dX side chain "
+ do i=1,nres
+ write(iout,'(i5,3e15.5)') i,(dxqwol(j,i),j=1,3)
+ enddo
+ do i=1,nres
+ do j=1,3
+ cdummy(j,i)=c(j,i)
+ c(j,i)=c(j,i)-delta
+ q1=qwolynes(seg1,seg2,flag,seg3,seg4)
+ c(j,i)=cdummy(j,i)+delta
+ q2=qwolynes(seg1,seg2,flag,seg3,seg4)
+ qwolan(j,i)=0.5d0*(q2-q1)/delta
+ c(j,i)=cdummy(j,i)
+c write (iout,*) "i",i," j",j," q1",q1," a2",q2
+ enddo
+ enddo
+ do i=1,nres
+ do j=1,3
+ cdummy(j,i+nres)=c(j,i+nres)
+ c(j,i+nres)=c(j,i+nres)-delta
+ q1=qwolynes(seg1,seg2,flag,seg3,seg4)
+ c(j,i+nres)=cdummy(j,i+nres)+delta
+ q2=qwolynes(seg1,seg2,flag,seg3,seg4)
+ qwolxan(j,i)=0.5d0*(q2-q1)/delta
+ c(j,i+nres)=cdummy(j,i+nres)
+ enddo
+ enddo
+ write(iout,*) "Numerical Q cartesian gradients backbone: "
+ do i=0,nres
+ write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
+ enddo
+ write(iout,*) "Numerical Q cartesian gradients side-chain: "
+ do i=0,nres
+ write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
+ enddo
+ return
+ end
+c------------------------------------------------------------------------
+ subroutine EconstrQ
+c MD with umbrella_sampling using Wolyne's distance measure as a constraint
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+#ifndef LANG0
+ include 'COMMON.LANGEVIN'
+#else
+ include 'COMMON.LANGEVIN.lang0'
+#endif
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ include 'COMMON.TIME1'
+ double precision uzap1,uzap2,hm1,hm2,hmnum
+ double precision ucdelan,dUcartan(3,0:MAXRES)
+ & ,dUxcartan(3,0:MAXRES),cdummy(3,0:MAXRES),
+ & duconst(3,0:MAXRES),duxconst(3,0:MAXRES)
+ integer kstart,kend,lstart,lend,idummy
+ double precision delta /1.0d-7/
+ do i=0,nres
+ do j=1,3
+ duconst(j,i)=0.0d0
+ dudconst(j,i)=0.0d0
+ duxconst(j,i)=0.0d0
+ dudxconst(j,i)=0.0d0
+ enddo
+ enddo
+ Uconst=0.0d0
+ do i=1,nfrag
+ qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.
+ & ,idummy,idummy)
+ Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
+c Calculating the derivatives of Constraint energy with respect to Q
+ Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),qinfrag(i,iset))
+c Calculating the derivatives of Q with respect to cartesian coordinates
+ do ii=0,nres
+ do j=1,3
+ duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
+ dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
+ enddo
+ enddo
+c write (iout,*) "Calling qwol_num"
+c call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.,idummy,idummy)
+ enddo
+c stop
+ do i=1,npair
+ kstart=ifrag(1,ipair(1,i,iset),iset)
+ kend=ifrag(2,ipair(1,i,iset),iset)
+ lstart=ifrag(1,ipair(2,i,iset),iset)
+ lend=ifrag(2,ipair(2,i,iset),iset)
+ qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
+ Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
+c Calculating dU/dQ
+ Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
+c Calculating dQ/dXi
+ do ii=0,nres
+ do j=1,3
+ duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
+ dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
+ enddo
+ enddo
+ enddo
+c write(iout,*) "Uconst inside subroutine ", Uconst
+c Transforming the gradients from Cs to dCs for the backbone
+ do i=0,nres
+ do j=i+1,nres
+ do k=1,3
+ dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
+ enddo
+ enddo
+ enddo
+c Transforming the gradients from Cs to dCs for the side chains
+ do i=1,nres
+ do j=1,3
+ dudxconst(j,i)=duxconst(j,i)
+ enddo
+ enddo
+c write(iout,*) "dU/dc backbone "
+c do ii=0,nres
+c write(iout,'(i5,3e15.5)') ii, (duconst(j,ii),j=1,3)
+c enddo
+c write(iout,*) "dU/dX side chain "
+c do ii=1,nres
+c write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
+c enddo
+c write(iout,*) "dU/ddc backbone "
+c do ii=0,nres
+c write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
+c enddo
+c write(iout,*) "dU/ddX side chain "
+c do ii=1,nres
+c write(iout,'(i5,3e15.5)') ii,(dudxconst(j,ii),j=1,3)
+c enddo
+c Calculating numerical gradients of dUconst/ddc and dUconst/ddx
+c call dEconstrQ_num
+ return
+ end
+c-----------------------------------------------------------------------
+ subroutine dEconstrQ_num
+c Calculating numerical dUconst/ddc and dUconst/ddx
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+#ifndef LANG0
+ include 'COMMON.LANGEVIN'
+#else
+ include 'COMMON.LANGEVIN.lang0'
+#endif
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ include 'COMMON.TIME1'
+ double precision uzap1,uzap2
+ double precision dUcartan(3,0:MAXRES)
+ & ,dUxcartan(3,0:MAXRES),cdummy(3,0:MAXRES)
+ integer kstart,kend,lstart,lend,idummy
+ double precision delta /1.0d-7/
+c For the backbone
+ do i=0,nres-1
+ do j=1,3
+ dUcartan(j,i)=0.0d0
+ cdummy(j,i)=dc(j,i)
+ dc(j,i)=dc(j,i)+delta
+ call chainbuild_cart
+ uzap2=0.0d0
+ do ii=1,nfrag
+ qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),
+ & .true.,idummy,idummy)
+ uzap2=uzap2+wfrag(ii,iset)*
+ & harmonic(qfrag(ii),qinfrag(ii,iset))
+ enddo
+ do ii=1,npair
+ kstart=ifrag(1,ipair(1,ii,iset),iset)
+ kend=ifrag(2,ipair(1,ii,iset),iset)
+ lstart=ifrag(1,ipair(2,ii,iset),iset)
+ lend=ifrag(2,ipair(2,ii,iset),iset)
+ qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
+ uzap2=uzap2+wpair(ii,iset)*
+ & harmonic(qpair(ii),qinpair(ii,iset))
+ enddo
+ dc(j,i)=cdummy(j,i)
+ call chainbuild_cart
+ uzap1=0.0d0
+ do ii=1,nfrag
+ qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),
+ & .true.,idummy,idummy)
+ uzap1=uzap1+wfrag(ii,iset)*
+ & harmonic(qfrag(ii),qinfrag(ii,iset))
+ enddo
+ do ii=1,npair
+ kstart=ifrag(1,ipair(1,ii,iset),iset)
+ kend=ifrag(2,ipair(1,ii,iset),iset)
+ lstart=ifrag(1,ipair(2,ii,iset),iset)
+ lend=ifrag(2,ipair(2,ii,iset),iset)
+ qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
+ uzap1=uzap1+wpair(ii,iset)*
+ & harmonic(qpair(ii),qinpair(ii,iset))
+ enddo
+ ducartan(j,i)=(uzap2-uzap1)/(delta)
+ enddo
+ enddo
+c Calculating numerical gradients for dU/ddx
+ do i=0,nres-1
+ do j=1,3
+ duxcartan(j,i)=0.0d0
+ enddo
+ do j=1,3
+ cdummy(j,i)=dc(j,i+nres)
+ dc(j,i+nres)=dc(j,i+nres)+delta
+ call chainbuild_cart
+ uzap2=0.0d0
+ do ii=1,nfrag
+ qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),
+ & .true.,idummy,idummy)
+ uzap2=uzap2+wfrag(ii,iset)*
+ & harmonic(qfrag(ii),qinfrag(ii,iset))
+ enddo
+ do ii=1,npair
+ kstart=ifrag(1,ipair(1,ii,iset),iset)
+ kend=ifrag(2,ipair(1,ii,iset),iset)
+ lstart=ifrag(1,ipair(2,ii,iset),iset)
+ lend=ifrag(2,ipair(2,ii,iset),iset)
+ qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
+ uzap2=uzap2+wpair(ii,iset)*
+ & harmonic(qpair(ii),qinpair(ii,iset))
+ enddo
+ dc(j,i+nres)=cdummy(j,i)
+ call chainbuild_cart
+ uzap1=0.0d0
+ do ii=1,nfrag
+ qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),
+ & .true.,idummy,idummy)
+ uzap1=uzap1+wfrag(ii,iset)*
+ & harmonic(qfrag(ii),qinfrag(ii,iset))
+ enddo
+ do ii=1,npair
+ kstart=ifrag(1,ipair(1,ii,iset),iset)
+ kend=ifrag(2,ipair(1,ii,iset),iset)
+ lstart=ifrag(1,ipair(2,ii,iset),iset)
+ lend=ifrag(2,ipair(2,ii,iset),iset)
+ qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
+ uzap1=uzap1+wpair(ii,iset)*
+ & harmonic(qpair(ii),qinpair(ii,iset))
+ enddo
+ duxcartan(j,i)=(uzap2-uzap1)/(delta)
+ enddo
+ enddo
+ write(iout,*) "Numerical dUconst/ddc backbone "
+ do ii=0,nres
+ write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
+ enddo
+ write(iout,*) "Numerical dUconst/ddx side-chain "
+ do ii=1,nres
+ write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
+ enddo
+ return
+ end
+c---------------------------------------------------------------------------
+ double precision function qcontrib(il,jl,il1,jl1)
+ implicit none
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.MD'
+ include 'COMMON.LOCAL'
+ integer i,j,k,il,jl,il1,jl1,nd,itl,jtl
+ double precision dist
+ external dist
+ double precision dij,dij1,d0ij,d0ij1,om1,om2,om12,om10,om20,om120
+ & ,fac,fac1,ddave,ssij,ddqij,d0ii1,d0jj1,rij,eom1,eom2,eom12
+ double precision u(3),v(3),er(3),er0(3),dcosom1(3),dcosom2(3),
+ & aux1,aux2
+ double precision scalar
+ external scalar
+ logical lprn /.false./
+ if (lprn) write (iout,*) "il",il," jl",jl," il1",il1," jl1",jl1
+ d0ij=dsqrt((cref(1,jl)-cref(1,il))**2+
+ & (cref(2,jl)-cref(2,il))**2+
+ & (cref(3,jl)-cref(3,il))**2)
+ dij=dist(il,jl)
+ dij1=dist(il1,jl1)
+ do i=1,3
+ er(i)=(c(i,jl1)-c(i,il1))/dij1
+ enddo
+ do i=1,3
+ er0(i)=cref(i,jl1)-cref(i,il1)
+ enddo
+ d0ij1=dsqrt(scalar(er0,er0))
+ do i=1,3
+ er0(i)=er0(i)/d0ij1
+ enddo
+ if (il.ne.il1 .or. jl.ne.jl1) then
+ ddave=0.5d0*((dij-d0ij)**2+(dij1-d0ij1)**2)
+ nd=2
+ else
+ ddave=(dij-d0ij)**2
+ nd=1
+ endif
+ if (il.ne.il1) then
+ do i=1,3
+ u(i)=cref(i,il1)-cref(i,il)
+ enddo
+ d0ii1=dsqrt(scalar(u,u))
+ do i=1,3
+ u(i)=u(i)/d0ii1
+ enddo
+ if (lprn) then
+ write (iout,*) "u",(u(i),i=1,3)
+ write (iout,*) "er0",(er0(i),i=1,3)
+ om10=scalar(er0,u)
+ om1=scalar(er,dc_norm(1,il1))
+ write (iout,*) "om10",om10," om1",om1
+ endif
+ else
+ om1=0.0d0
+ om10=0.0d0
+ endif
+ if (jl.ne.jl1) then
+ do i=1,3
+ v(i)=cref(i,jl1)-cref(i,jl)
+ enddo
+ d0jj1=dsqrt(scalar(v,v))
+ do i=1,3
+ v(i)=v(i)/d0jj1
+ enddo
+ if (lprn) then
+ write (iout,*) "v",(v(i),i=1,3)
+ write (iout,*) "er0",(er0(i),i=1,3)
+ om20=scalar(er,v)
+ om2=scalar(er,dc_norm(1,jl1))
+ write (iout,*) "om20",om20," om2",om2
+ endif
+ else
+ om2=0.0d0
+ om20=0.0d0
+ endif
+ if (il.ne.il1 .and. jl.ne.jl1) then
+ om120=scalar(u,v)
+ om12=scalar(dc_norm(1,il1),dc_norm(1,jl1))
+ else
+ om12=0.0d0
+ om120=0.0d0
+ endif
+ if (lprn) then
+ write (iout,*) "il",il," jl",jl,itype(il),itype(jl)
+ write (iout,*)"d0ij",d0ij," om10",om10," om20",om20,
+ & " om120",om120,
+ & " dij",dij," om1",om1," om2",om2," om12",om12
+ call flush(iout)
+ endif
+ ssij = 16.0d0/(d0ij*d0ij)
+ qcontrib = dexp(-0.5d0*(ddave*ssij+((om1-om10)**2
+ & +(om2-om20)**2+(om12-om120)**2)))
+ if (lprn) write (iout,*) "ssij",ssij," qcontrib",qcontrib
+c qcontrib = dexp(-0.5d0*(ddave*ssij)+(om1-om10)**2+(om2-om20)**2)
+c qcontrib = dexp(-0.5d0*(ddave*ssij))
+c Compute gradient - radial component
+ fac1 = qcontrib*ssij/nd
+ fac = fac1*(dij-d0ij)/dij
+ do k=1,3
+ ddqij = (c(k,il)-c(k,jl))*fac
+ dqwol(k,il)=dqwol(k,il)+ddqij
+ dqwol(k,jl)=dqwol(k,jl)-ddqij
+ enddo
+ if (il1.ne.il .or. jl1.ne.jl) then
+ fac = fac1*(dij1-d0ij1)/dij1
+ do k=1,3
+ ddqij = (c(k,il1)-c(k,jl1))*fac
+ if (il1.ne.il) then
+ dxqwol(k,il)=dxqwol(k,il)+ddqij
+ else
+ dqwol(k,il)=dqwol(k,il)+ddqij
+ endif
+ if (jl1.ne.jl) then
+ dxqwol(k,jl)=dxqwol(k,jl)-ddqij
+ else
+ dqwol(k,jl)=dqwol(k,jl)-ddqij
+ endif
+ enddo
+ endif
+c return
+c Orientational contributions
+ rij=1.0d0/dij1
+ eom1=qcontrib*(om1-om10)
+ eom2=qcontrib*(om2-om20)
+ eom12=qcontrib*(om12-om120)
+ do k=1,3
+ dcosom1(k)=rij*(dc_norm(k,il1)-om1*er(k))
+ dcosom2(k)=rij*(dc_norm(k,jl1)-om2*er(k))
+ enddo
+ do k=1,3
+ ddqij=eom1*dcosom1(k)+eom2*dcosom2(k)
+ aux1=(eom12*(dc_norm(k,jl1)-om12*dc_norm(k,il1))
+ & +eom1*(er(k)-om1*dc_norm(k,il1)))*vbld_inv(il1)
+ aux2=(eom12*(dc_norm(k,il1)-om12*dc_norm(k,jl1))
+ & +eom2*(er(k)-om2*dc_norm(k,jl1)))*vbld_inv(jl1)
+ dqwol(k,il)=dqwol(k,il)-ddqij-aux1
+ dqwol(k,jl)=dqwol(k,jl)+ddqij-aux2
+ dxqwol(k,il)=dxqwol(k,il)-ddqij+aux1
+c & +(eom12*(dc_norm(k,jl1)-om12*dc_norm(k,il1))
+c & +eom1*(er(k)-om1*dc_norm(k,il1)))*vbld_inv(il1)
+ dxqwol(k,jl)=dxqwol(k,jl)+ddqij+aux2
+c & +(eom12*(dc_norm(k,il1)-om12*dc_norm(k,jl1))
+c & +eom2*(er(k)-om2*dc_norm(k,jl1)))*vbld_inv(jl1)
+ enddo
+ return
+ end
--- /dev/null
+C $Date: 1994/10/04 16:19:52 $
+C $Revision: 2.1 $
+C
+C
+C See help for RANDOMV on the PSFSHARE disk to understand these
+C subroutines. This is the VS Fortran version of this code.
+C
+C
+ SUBROUTINE VRND(VEC,N)
+ INTEGER A(250)
+ COMMON /VRANDD/ A, I, I147
+ INTEGER LOOP,I,I147,VEC(N)
+ DO 23000 LOOP=1,N
+ I=I+1
+ IF(.NOT.(I.GE.251))GOTO 23002
+ I=1
+23002 CONTINUE
+ I147=I147+1
+ IF(.NOT.(I147.GE.251))GOTO 23004
+ I147=1
+23004 CONTINUE
+ A(I)=IEOR(A(I147),A(I))
+ VEC(LOOP)=A(I)
+23000 CONTINUE
+ RETURN
+ END
+C
+C
+ DOUBLE PRECISION FUNCTION RNDV(IDUM)
+ DOUBLE PRECISION RM1,RM2,R(99)
+ INTEGER IA1,IC1,M1, IA2,IC2,M2, IA3,IC3,M3, IDUM
+ SAVE
+ DATA IA1,IC1,M1/1279,351762,1664557/
+ DATA IA2,IC2,M2/2011,221592,1048583/
+ DATA IA3,IC3,M3/15551,6150,29101/
+ IF(.NOT.(IDUM.LT.0))GOTO 23006
+ IX1 = MOD(-IDUM,M1)
+ IX1 = MOD(IA1*IX1+IC1,M1)
+ IX2 = MOD(IX1,M2)
+ IX1 = MOD(IA1*IX1+IC1,M1)
+ IX3 = MOD(IX1,M3)
+ RM1 = 1./DBLE(M1)
+ RM2 = 1./DBLE(M2)
+ DO 23008 J = 1,99
+ IX1 = MOD(IA1*IX1+IC1,M1)
+ IX2 = MOD(IA2*IX2+IC2,M2)
+ R(J) = (DBLE(IX1)+DBLE(IX2)*RM2)*RM1
+23008 CONTINUE
+23006 CONTINUE
+ IX1 = MOD(IA1*IX1+IC1,M1)
+ IX2 = MOD(IA2*IX2+IC2,M2)
+ IX3 = MOD(IA3*IX3+IC3,M3)
+ J = 1+(99*IX3)/M3
+ RNDV = R(J)
+ R(J) = (DBLE(IX1)+DBLE(IX2)*RM2)*RM1
+ IDUM = IX1
+ RETURN
+ END
+C
+C
+ SUBROUTINE VRNDST(SEED)
+ INTEGER A(250),LOOP,IDUM,SEED
+ DOUBLE PRECISION RNDV
+ COMMON /VRANDD/ A, I, I147
+ I=0
+ I147=103
+ IDUM=SEED
+ DO 23010 LOOP=1,250
+ A(LOOP)=INT(RNDV(IDUM)*2147483647)
+23010 CONTINUE
+ RETURN
+ END
+C
+C
+ SUBROUTINE VRNDIN(IODEV)
+ INTEGER IODEV, A(250)
+ COMMON/VRANDD/ A, I, I147
+ READ(IODEV) A, I, I147
+ RETURN
+ END
+C
+C
+ SUBROUTINE VRNDOU(IODEV)
+C This corresponds to VRNDOUT in the APFTN64 version
+ INTEGER IODEV, A(250)
+ COMMON/VRANDD/ A, I, I147
+ WRITE(IODEV) A, I, I147
+ RETURN
+ END
+ FUNCTION RNUNF(N)
+ INTEGER IRAN1(2000)
+ DATA FCTOR /2147483647.0D0/
+C We get only one random number, here! DR 9/1/92
+ CALL VRND(IRAN1,1)
+ RNUNF= DBLE( IRAN1(1) ) / FCTOR
+C******************************
+C write(6,*) 'rnunf in rnunf = ',rnunf
+ RETURN
+ END
--- /dev/null
+ subroutine rattle1
+c RATTLE algorithm for velocity Verlet - step 1, UNRES
+c AL 9/24/04
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+#ifndef LANG0
+ include 'COMMON.LANGEVIN'
+#else
+ include 'COMMON.LANGEVIN.lang0'
+#endif
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ include 'COMMON.TIME1'
+ double precision gginv(maxres2,maxres2),
+ & gdc(3,MAXRES2,MAXRES2),dC_uncor(3,MAXRES2),
+ & Cmat(MAXRES2,MAXRES2),x(MAXRES2),xcorr(3,MAXRES2)
+ common /przechowalnia/ GGinv,gdc,Cmat,nbond
+ integer max_rattle /5/
+ logical lprn /.false./, lprn1 /.false./,not_done
+ double precision tol_rattle /1.0d-5/
+ if (lprn) write (iout,*) "RATTLE1"
+ nbond=nct-nnt
+ do i=nnt,nct
+ if (itype(i).ne.10) nbond=nbond+1
+ enddo
+c Make a folded form of the Ginv-matrix
+ ind=0
+ ii=0
+ do i=nnt,nct-1
+ ii=ii+1
+ do j=1,3
+ ind=ind+1
+ ind1=0
+ jj=0
+ do k=nnt,nct-1
+ jj=jj+1
+ do l=1,3
+ ind1=ind1+1
+ if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=Ginv(ind,ind1)
+ enddo
+ enddo
+ do k=nnt,nct
+ if (itype(k).ne.10) then
+ jj=jj+1
+ do l=1,3
+ ind1=ind1+1
+ if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=Ginv(ind,ind1)
+ enddo
+ endif
+ enddo
+ enddo
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ ii=ii+1
+ do j=1,3
+ ind=ind+1
+ ind1=0
+ jj=0
+ do k=nnt,nct-1
+ jj=jj+1
+ do l=1,3
+ ind1=ind1+1
+ if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=Ginv(ind,ind1)
+ enddo
+ enddo
+ do k=nnt,nct
+ if (itype(k).ne.10) then
+ jj=jj+1
+ do l=1,3
+ ind1=ind1+1
+ if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=Ginv(ind,ind1)
+ enddo
+ endif
+ enddo
+ enddo
+ endif
+ enddo
+ if (lprn1) then
+ write (iout,*) "Matrix GGinv"
+ call MATOUT(nbond,nbond,MAXRES2,MAXRES2,GGinv)
+ endif
+ not_done=.true.
+ iter=0
+ do while (not_done)
+ iter=iter+1
+ if (iter.gt.max_rattle) then
+ write (iout,*) "Error - too many iterations in RATTLE."
+ stop
+ endif
+c Calculate the matrix C = GG**(-1) dC_old o dC
+ ind1=0
+ do i=nnt,nct-1
+ ind1=ind1+1
+ do j=1,3
+ dC_uncor(j,ind1)=dC(j,i)
+ enddo
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ ind1=ind1+1
+ do j=1,3
+ dC_uncor(j,ind1)=dC(j,i+nres)
+ enddo
+ endif
+ enddo
+ do i=1,nbond
+ ind=0
+ do k=nnt,nct-1
+ ind=ind+1
+ do j=1,3
+ gdc(j,i,ind)=GGinv(i,ind)*dC_old(j,k)
+ enddo
+ enddo
+ do k=nnt,nct
+ if (itype(k).ne.10) then
+ ind=ind+1
+ do j=1,3
+ gdc(j,i,ind)=GGinv(i,ind)*dC_old(j,k+nres)
+ enddo
+ endif
+ enddo
+ enddo
+c Calculate deviations from standard virtual-bond lengths
+ ind=0
+ do i=nnt,nct-1
+ ind=ind+1
+ x(ind)=vbld(i+1)**2-vbl**2
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ ind=ind+1
+ x(ind)=vbld(i+nres)**2-vbldsc0(1,itype(i))**2
+ endif
+ enddo
+ if (lprn) then
+ write (iout,*) "Coordinates and violations"
+ do i=1,nbond
+ write(iout,'(i5,3f10.5,5x,e15.5)')
+ & i,(dC_uncor(j,i),j=1,3),x(i)
+ enddo
+ write (iout,*) "Velocities and violations"
+ ind=0
+ do i=nnt,nct-1
+ ind=ind+1
+ write (iout,'(2i5,3f10.5,5x,e15.5)')
+ & i,ind,(d_t_new(j,i),j=1,3),scalar(d_t_new(1,i),dC_old(1,i))
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ ind=ind+1
+ write (iout,'(2i5,3f10.5,5x,e15.5)')
+ & i+nres,ind,(d_t_new(j,i+nres),j=1,3),
+ & scalar(d_t_new(1,i+nres),dC_old(1,i+nres))
+ endif
+ enddo
+c write (iout,*) "gdc"
+c do i=1,nbond
+c write (iout,*) "i",i
+c do j=1,nbond
+c write (iout,'(i5,3f10.5)') j,(gdc(k,j,i),k=1,3)
+c enddo
+c enddo
+ endif
+ xmax=dabs(x(1))
+ do i=2,nbond
+ if (dabs(x(i)).gt.xmax) then
+ xmax=dabs(x(i))
+ endif
+ enddo
+ if (xmax.lt.tol_rattle) then
+ not_done=.false.
+ goto 100
+ endif
+c Calculate the matrix of the system of equations
+ do i=1,nbond
+ do j=1,nbond
+ Cmat(i,j)=0.0d0
+ do k=1,3
+ Cmat(i,j)=Cmat(i,j)+dC_uncor(k,i)*gdc(k,i,j)
+ enddo
+ enddo
+ enddo
+ if (lprn1) then
+ write (iout,*) "Matrix Cmat"
+ call MATOUT(nbond,nbond,MAXRES2,MAXRES2,Cmat)
+ endif
+ call gauss(Cmat,X,MAXRES2,nbond,1,*10)
+c Add constraint term to positions
+ ind=0
+ do i=nnt,nct-1
+ ind=ind+1
+ do j=1,3
+ xx=0.0d0
+ do ii=1,nbond
+ xx = xx+x(ii)*gdc(j,ind,ii)
+ enddo
+ xx=0.5d0*xx
+ dC(j,i)=dC(j,i)-xx
+ d_t_new(j,i)=d_t_new(j,i)-xx/d_time
+ enddo
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ ind=ind+1
+ do j=1,3
+ xx=0.0d0
+ do ii=1,nbond
+ xx = xx+x(ii)*gdc(j,ind,ii)
+ enddo
+ xx=0.5d0*xx
+ dC(j,i+nres)=dC(j,i+nres)-xx
+ d_t_new(j,i+nres)=d_t_new(j,i+nres)-xx/d_time
+ enddo
+ endif
+ enddo
+c Rebuild the chain using the new coordinates
+ call chainbuild_cart
+ if (lprn) then
+ write (iout,*) "New coordinates, Lagrange multipliers,",
+ & " and differences between actual and standard bond lengths"
+ ind=0
+ do i=nnt,nct-1
+ ind=ind+1
+ xx=vbld(i+1)**2-vbl**2
+ write (iout,'(i5,3f10.5,5x,f10.5,e15.5)')
+ & i,(dC(j,i),j=1,3),x(ind),xx
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ ind=ind+1
+ xx=vbld(i+nres)**2-vbldsc0(1,itype(i))**2
+ write (iout,'(i5,3f10.5,5x,f10.5,e15.5)')
+ & i,(dC(j,i+nres),j=1,3),x(ind),xx
+ endif
+ enddo
+ write (iout,*) "Velocities and violations"
+ ind=0
+ do i=nnt,nct-1
+ ind=ind+1
+ write (iout,'(2i5,3f10.5,5x,e15.5)')
+ & i,ind,(d_t_new(j,i),j=1,3),scalar(d_t_new(1,i),dC_old(1,i))
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ ind=ind+1
+ write (iout,'(2i5,3f10.5,5x,e15.5)')
+ & i+nres,ind,(d_t_new(j,i+nres),j=1,3),
+ & scalar(d_t_new(1,i+nres),dC_old(1,i+nres))
+ endif
+ enddo
+ endif
+ enddo
+ 100 continue
+ return
+ 10 write (iout,*) "Error - singularity in solving the system",
+ & " of equations for Lagrange multipliers."
+ stop
+ end
+c------------------------------------------------------------------------------
+ subroutine rattle2
+c RATTLE algorithm for velocity Verlet - step 2, UNRES
+c AL 9/24/04
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+#ifndef LANG0
+ include 'COMMON.LANGEVIN'
+#else
+ include 'COMMON.LANGEVIN.lang0'
+#endif
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ include 'COMMON.TIME1'
+ double precision gginv(maxres2,maxres2),
+ & gdc(3,MAXRES2,MAXRES2),dC_uncor(3,MAXRES2),
+ & Cmat(MAXRES2,MAXRES2),x(MAXRES2)
+ common /przechowalnia/ GGinv,gdc,Cmat,nbond
+ integer max_rattle /5/
+ logical lprn /.false./, lprn1 /.false./,not_done
+ double precision tol_rattle /1.0d-5/
+ if (lprn) write (iout,*) "RATTLE2"
+ if (lprn) write (iout,*) "Velocity correction"
+c Calculate the matrix G dC
+ do i=1,nbond
+ ind=0
+ do k=nnt,nct-1
+ ind=ind+1
+ do j=1,3
+ gdc(j,i,ind)=GGinv(i,ind)*dC(j,k)
+ enddo
+ enddo
+ do k=nnt,nct
+ if (itype(k).ne.10) then
+ ind=ind+1
+ do j=1,3
+ gdc(j,i,ind)=GGinv(i,ind)*dC(j,k+nres)
+ enddo
+ endif
+ enddo
+ enddo
+c if (lprn) then
+c write (iout,*) "gdc"
+c do i=1,nbond
+c write (iout,*) "i",i
+c do j=1,nbond
+c write (iout,'(i5,3f10.5)') j,(gdc(k,j,i),k=1,3)
+c enddo
+c enddo
+c endif
+c Calculate the matrix of the system of equations
+ ind=0
+ do i=nnt,nct-1
+ ind=ind+1
+ do j=1,nbond
+ Cmat(ind,j)=0.0d0
+ do k=1,3
+ Cmat(ind,j)=Cmat(ind,j)+dC(k,i)*gdc(k,ind,j)
+ enddo
+ enddo
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ ind=ind+1
+ do j=1,nbond
+ Cmat(ind,j)=0.0d0
+ do k=1,3
+ Cmat(ind,j)=Cmat(ind,j)+dC(k,i+nres)*gdc(k,ind,j)
+ enddo
+ enddo
+ endif
+ enddo
+c Calculate the scalar product dC o d_t_new
+ ind=0
+ do i=nnt,nct-1
+ ind=ind+1
+ x(ind)=scalar(d_t(1,i),dC(1,i))
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ ind=ind+1
+ x(ind)=scalar(d_t(1,i+nres),dC(1,i+nres))
+ endif
+ enddo
+ if (lprn) then
+ write (iout,*) "Velocities and violations"
+ ind=0
+ do i=nnt,nct-1
+ ind=ind+1
+ write (iout,'(2i5,3f10.5,5x,e15.5)')
+ & i,ind,(d_t(j,i),j=1,3),x(ind)
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ ind=ind+1
+ write (iout,'(2i5,3f10.5,5x,e15.5)')
+ & i+nres,ind,(d_t(j,i+nres),j=1,3),x(ind)
+ endif
+ enddo
+ endif
+ xmax=dabs(x(1))
+ do i=2,nbond
+ if (dabs(x(i)).gt.xmax) then
+ xmax=dabs(x(i))
+ endif
+ enddo
+ if (xmax.lt.tol_rattle) then
+ not_done=.false.
+ goto 100
+ endif
+ if (lprn1) then
+ write (iout,*) "Matrix Cmat"
+ call MATOUT(nbond,nbond,MAXRES2,MAXRES2,Cmat)
+ endif
+ call gauss(Cmat,X,MAXRES2,nbond,1,*10)
+c Add constraint term to velocities
+ ind=0
+ do i=nnt,nct-1
+ ind=ind+1
+ do j=1,3
+ xx=0.0d0
+ do ii=1,nbond
+ xx = xx+x(ii)*gdc(j,ind,ii)
+ enddo
+ d_t(j,i)=d_t(j,i)-xx
+ enddo
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ ind=ind+1
+ do j=1,3
+ xx=0.0d0
+ do ii=1,nbond
+ xx = xx+x(ii)*gdc(j,ind,ii)
+ enddo
+ d_t(j,i+nres)=d_t(j,i+nres)-xx
+ enddo
+ endif
+ enddo
+ if (lprn) then
+ write (iout,*)
+ & "New velocities, Lagrange multipliers violations"
+ ind=0
+ do i=nnt,nct-1
+ ind=ind+1
+ if (lprn) write (iout,'(2i5,3f10.5,5x,2e15.5)')
+ & i,ind,(d_t(j,i),j=1,3),x(ind),scalar(d_t(1,i),dC(1,i))
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ ind=ind+1
+ write (iout,'(2i5,3f10.5,5x,2e15.5)')
+ & i+nres,ind,(d_t(j,i+nres),j=1,3),x(ind),
+ & scalar(d_t(1,i+nres),dC(1,i+nres))
+ endif
+ enddo
+ endif
+ 100 continue
+ return
+ 10 write (iout,*) "Error - singularity in solving the system",
+ & " of equations for Lagrange multipliers."
+ stop
+ end
+c------------------------------------------------------------------------------
+ subroutine rattle_brown
+c RATTLE/LINCS algorithm for Brownian dynamics, UNRES
+c AL 9/24/04
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+#ifndef LANG0
+ include 'COMMON.LANGEVIN'
+#else
+ include 'COMMON.LANGEVIN.lang0'
+#endif
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ include 'COMMON.TIME1'
+ double precision gginv(maxres2,maxres2),
+ & gdc(3,MAXRES2,MAXRES2),dC_uncor(3,MAXRES2),
+ & Cmat(MAXRES2,MAXRES2),x(MAXRES2)
+ common /przechowalnia/ GGinv,gdc,Cmat,nbond
+ integer max_rattle /5/
+ logical lprn /.true./, lprn1 /.true./,not_done
+ double precision tol_rattle /1.0d-5/
+ if (lprn) write (iout,*) "RATTLE_BROWN"
+ nbond=nct-nnt
+ do i=nnt,nct
+ if (itype(i).ne.10) nbond=nbond+1
+ enddo
+c Make a folded form of the Ginv-matrix
+ ind=0
+ ii=0
+ do i=nnt,nct-1
+ ii=ii+1
+ do j=1,3
+ ind=ind+1
+ ind1=0
+ jj=0
+ do k=nnt,nct-1
+ jj=jj+1
+ do l=1,3
+ ind1=ind1+1
+ if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=fricmat(ind,ind1)
+ enddo
+ enddo
+ do k=nnt,nct
+ if (itype(k).ne.10) then
+ jj=jj+1
+ do l=1,3
+ ind1=ind1+1
+ if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=fricmat(ind,ind1)
+ enddo
+ endif
+ enddo
+ enddo
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ ii=ii+1
+ do j=1,3
+ ind=ind+1
+ ind1=0
+ jj=0
+ do k=nnt,nct-1
+ jj=jj+1
+ do l=1,3
+ ind1=ind1+1
+ if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=fricmat(ind,ind1)
+ enddo
+ enddo
+ do k=nnt,nct
+ if (itype(k).ne.10) then
+ jj=jj+1
+ do l=1,3
+ ind1=ind1+1
+ if (j.eq.1 .and. l.eq.1)GGinv(ii,jj)=fricmat(ind,ind1)
+ enddo
+ endif
+ enddo
+ enddo
+ endif
+ enddo
+ if (lprn1) then
+ write (iout,*) "Matrix GGinv"
+ call MATOUT(nbond,nbond,MAXRES2,MAXRES2,GGinv)
+ endif
+ not_done=.true.
+ iter=0
+ do while (not_done)
+ iter=iter+1
+ if (iter.gt.max_rattle) then
+ write (iout,*) "Error - too many iterations in RATTLE."
+ stop
+ endif
+c Calculate the matrix C = GG**(-1) dC_old o dC
+ ind1=0
+ do i=nnt,nct-1
+ ind1=ind1+1
+ do j=1,3
+ dC_uncor(j,ind1)=dC(j,i)
+ enddo
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ ind1=ind1+1
+ do j=1,3
+ dC_uncor(j,ind1)=dC(j,i+nres)
+ enddo
+ endif
+ enddo
+ do i=1,nbond
+ ind=0
+ do k=nnt,nct-1
+ ind=ind+1
+ do j=1,3
+ gdc(j,i,ind)=GGinv(i,ind)*dC_old(j,k)
+ enddo
+ enddo
+ do k=nnt,nct
+ if (itype(k).ne.10) then
+ ind=ind+1
+ do j=1,3
+ gdc(j,i,ind)=GGinv(i,ind)*dC_old(j,k+nres)
+ enddo
+ endif
+ enddo
+ enddo
+c Calculate deviations from standard virtual-bond lengths
+ ind=0
+ do i=nnt,nct-1
+ ind=ind+1
+ x(ind)=vbld(i+1)**2-vbl**2
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ ind=ind+1
+ x(ind)=vbld(i+nres)**2-vbldsc0(1,itype(i))**2
+ endif
+ enddo
+ if (lprn) then
+ write (iout,*) "Coordinates and violations"
+ do i=1,nbond
+ write(iout,'(i5,3f10.5,5x,e15.5)')
+ & i,(dC_uncor(j,i),j=1,3),x(i)
+ enddo
+ write (iout,*) "Velocities and violations"
+ ind=0
+ do i=nnt,nct-1
+ ind=ind+1
+ write (iout,'(2i5,3f10.5,5x,e15.5)')
+ & i,ind,(d_t(j,i),j=1,3),scalar(d_t(1,i),dC_old(1,i))
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ ind=ind+1
+ write (iout,'(2i5,3f10.5,5x,e15.5)')
+ & i+nres,ind,(d_t(j,i+nres),j=1,3),
+ & scalar(d_t(1,i+nres),dC_old(1,i+nres))
+ endif
+ enddo
+ write (iout,*) "gdc"
+ do i=1,nbond
+ write (iout,*) "i",i
+ do j=1,nbond
+ write (iout,'(i5,3f10.5)') j,(gdc(k,j,i),k=1,3)
+ enddo
+ enddo
+ endif
+ xmax=dabs(x(1))
+ do i=2,nbond
+ if (dabs(x(i)).gt.xmax) then
+ xmax=dabs(x(i))
+ endif
+ enddo
+ if (xmax.lt.tol_rattle) then
+ not_done=.false.
+ goto 100
+ endif
+c Calculate the matrix of the system of equations
+ do i=1,nbond
+ do j=1,nbond
+ Cmat(i,j)=0.0d0
+ do k=1,3
+ Cmat(i,j)=Cmat(i,j)+dC_uncor(k,i)*gdc(k,i,j)
+ enddo
+ enddo
+ enddo
+ if (lprn1) then
+ write (iout,*) "Matrix Cmat"
+ call MATOUT(nbond,nbond,MAXRES2,MAXRES2,Cmat)
+ endif
+ call gauss(Cmat,X,MAXRES2,nbond,1,*10)
+c Add constraint term to positions
+ ind=0
+ do i=nnt,nct-1
+ ind=ind+1
+ do j=1,3
+ xx=0.0d0
+ do ii=1,nbond
+ xx = xx+x(ii)*gdc(j,ind,ii)
+ enddo
+ xx=-0.5d0*xx
+ d_t(j,i)=d_t(j,i)+xx/d_time
+ dC(j,i)=dC(j,i)+xx
+ enddo
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ ind=ind+1
+ do j=1,3
+ xx=0.0d0
+ do ii=1,nbond
+ xx = xx+x(ii)*gdc(j,ind,ii)
+ enddo
+ xx=-0.5d0*xx
+ d_t(j,i+nres)=d_t(j,i+nres)+xx/d_time
+ dC(j,i+nres)=dC(j,i+nres)+xx
+ enddo
+ endif
+ enddo
+c Rebuild the chain using the new coordinates
+ call chainbuild_cart
+ if (lprn) then
+ write (iout,*) "New coordinates, Lagrange multipliers,",
+ & " and differences between actual and standard bond lengths"
+ ind=0
+ do i=nnt,nct-1
+ ind=ind+1
+ xx=vbld(i+1)**2-vbl**2
+ write (iout,'(i5,3f10.5,5x,f10.5,e15.5)')
+ & i,(dC(j,i),j=1,3),x(ind),xx
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ ind=ind+1
+ xx=vbld(i+nres)**2-vbldsc0(1,itype(i))**2
+ write (iout,'(i5,3f10.5,5x,f10.5,e15.5)')
+ & i,(dC(j,i+nres),j=1,3),x(ind),xx
+ endif
+ enddo
+ write (iout,*) "Velocities and violations"
+ ind=0
+ do i=nnt,nct-1
+ ind=ind+1
+ write (iout,'(2i5,3f10.5,5x,e15.5)')
+ & i,ind,(d_t_new(j,i),j=1,3),scalar(d_t_new(1,i),dC_old(1,i))
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ ind=ind+1
+ write (iout,'(2i5,3f10.5,5x,e15.5)')
+ & i+nres,ind,(d_t_new(j,i+nres),j=1,3),
+ & scalar(d_t_new(1,i+nres),dC_old(1,i+nres))
+ endif
+ enddo
+ endif
+ enddo
+ 100 continue
+ return
+ 10 write (iout,*) "Error - singularity in solving the system",
+ & " of equations for Lagrange multipliers."
+ stop
+ end
--- /dev/null
+ subroutine readpdb
+C Read the PDB file and convert the peptide geometry into virtual-chain
+C 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.DISTFIT'
+ include 'COMMON.SETUP'
+ character*3 seq,atom,res
+ character*80 card
+ dimension sccor(3,20)
+ integer rescode
+ ibeg=1
+ lsecondary=.false.
+ nhfrag=0
+ nbfrag=0
+ do i=1,10000
+ read (ipdbin,'(a80)',end=10) card
+ if (card(:5).eq.'HELIX') then
+ nhfrag=nhfrag+1
+ lsecondary=.true.
+ read(card(22:25),*) hfrag(1,nhfrag)
+ read(card(34:37),*) hfrag(2,nhfrag)
+ endif
+ if (card(:5).eq.'SHEET') then
+ nbfrag=nbfrag+1
+ lsecondary=.true.
+ read(card(24:26),*) bfrag(1,nbfrag)
+ read(card(35:37),*) bfrag(2,nbfrag)
+crc----------------------------------------
+crc to be corrected !!!
+ bfrag(3,nbfrag)=bfrag(1,nbfrag)
+ bfrag(4,nbfrag)=bfrag(2,nbfrag)
+crc----------------------------------------
+ endif
+ if (card(:3).eq.'END' .or. card(:3).eq.'TER') goto 10
+C Fish out the ATOM cards.
+ if (index(card(1:4),'ATOM').gt.0) then
+ read (card(14:16),'(a3)') atom
+ if (atom.eq.'CA' .or. atom.eq.'CH3') then
+C Calculate the CM of the preceding residue.
+ if (ibeg.eq.0) then
+ if (unres_pdb) then
+ do j=1,3
+ dc(j,ires+nres)=sccor(j,iii)
+ enddo
+ else
+ call sccenter(ires,iii,sccor)
+ endif
+ endif
+C Start new residue.
+ read (card(24: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)=21
+ endif
+ ibeg=0
+ endif
+ ires=ires-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)
+c if(me.eq.king.or..not.out1file)
+c & write (iout,'(2i3,2x,a,3f8.3)')
+c & 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.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 if(me.eq.king.or..not.out1file)
+ & write (iout,'(a,i5)') ' Nres: ',ires
+C Calculate the CM of the last side chain.
+ if (unres_pdb) then
+ do j=1,3
+ dc(j,ires+nres)=sccor(j,iii)
+ enddo
+ else
+ call sccenter(ires,iii,sccor)
+ endif
+ nres=ires
+ nsup=nres
+ nstart_sup=1
+ if (itype(nres).ne.10) then
+ nres=nres+1
+ itype(nres)=21
+ if (unres_pdb) then
+ c(1,nres)=c(1,nres-1)+3.8d0
+ c(2,nres)=c(2,nres-1)
+ c(3,nres)=c(3,nres-1)
+ else
+ do j=1,3
+ dcj=c(j,nres-2)-c(j,nres-3)
+ c(j,nres)=c(j,nres-1)+dcj
+ c(j,2*nres)=c(j,nres)
+ enddo
+ endif
+ endif
+ do i=2,nres-1
+ do j=1,3
+ c(j,i+nres)=dc(j,i)
+ enddo
+ enddo
+ do j=1,3
+ c(j,nres+1)=c(j,1)
+ c(j,2*nres)=c(j,nres)
+ enddo
+ if (itype(1).eq.21) then
+ nsup=nsup-1
+ nstart_sup=2
+ if (unres_pdb) then
+ c(1,1)=c(1,2)-3.8d0
+ c(2,1)=c(2,2)
+ c(3,1)=c(3,2)
+ else
+ do j=1,3
+ dcj=c(j,4)-c(j,3)
+ c(j,1)=c(j,2)-dcj
+ c(j,nres+1)=c(j,1)
+ enddo
+ endif
+ endif
+C Calculate internal coordinates.
+ if(me.eq.king.or..not.out1file)then
+ write (iout,'(a)')
+ & "Backbone and SC coordinates as read from the PDB"
+ 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 sc_loc_geom(.false.)
+ 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
+c call chainbuild
+C Copy the coordinates to reference coordinates
+ do i=1,2*nres
+ do j=1,3
+ cref(j,i)=c(j,i)
+ enddo
+ enddo
+
+
+ do j=1,nbfrag
+ do i=1,4
+ bfrag(i,j)=bfrag(i,j)-ishift
+ enddo
+ enddo
+
+ do j=1,nhfrag
+ do i=1,2
+ hfrag(i,j)=hfrag(i,j)-ishift
+ enddo
+ enddo
+
+ return
+ end
+c---------------------------------------------------------------------------
+ subroutine int_from_cart(lside,lprn)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include "mpif.h"
+#endif
+ 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'
+ character*3 seq,atom,res
+ character*80 card
+ dimension sccor(3,20)
+ integer rescode
+ logical lside,lprn
+ if(me.eq.king.or..not.out1file)then
+ if (lprn) then
+ write (iout,'(/a)')
+ & 'Internal coordinates calculated from crystal structure.'
+ if (lside) then
+ write (iout,'(8a)') ' Res ',' dvb',' Theta',
+ & ' Gamma',' Dsc_id',' Dsc',' Alpha',
+ & ' Beta '
+ else
+ write (iout,'(4a)') ' Res ',' dvb',' Theta',
+ & ' Gamma'
+ endif
+ endif
+ endif
+ do i=1,nres-1
+ iti=itype(i)
+ if (dist(i,i+1).lt.2.0D0 .or. dist(i,i+1).gt.5.0D0) then
+ write (iout,'(a,i4)') 'Bad Cartesians for residue',i
+ctest stop
+ endif
+ vbld(i+1)=dist(i,i+1)
+ vbld_inv(i+1)=1.0d0/vbld(i+1)
+ if (i.gt.1) 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 (unres_pdb) then
+c if (itype(1).eq.21) then
+c theta(3)=90.0d0*deg2rad
+c phi(4)=180.0d0*deg2rad
+c vbld(2)=3.8d0
+c vbld_inv(2)=1.0d0/vbld(2)
+c endif
+c if (itype(nres).eq.21) then
+c theta(nres)=90.0d0*deg2rad
+c phi(nres)=180.0d0*deg2rad
+c vbld(nres)=3.8d0
+c vbld_inv(nres)=1.0d0/vbld(2)
+c endif
+c endif
+ if (lside) then
+ do i=2,nres-1
+ do j=1,3
+ c(j,maxres2)=0.5D0*(2*c(j,i)+(c(j,i-1)-c(j,i))*vbld_inv(i)
+ & +(c(j,i+1)-c(j,i))*vbld_inv(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(me.eq.king.or..not.out1file)then
+ if (lprn)
+ & write (iout,'(a3,i4,7f10.3)') restyp(iti),i,vbld(i),
+ & rad2deg*theta(i),rad2deg*phi(i),dsc(iti),vbld(nres+i),
+ & rad2deg*alph(i),rad2deg*omeg(i)
+ endif
+ enddo
+ else if (lprn) then
+ do i=2,nres
+ iti=itype(i)
+ if(me.eq.king.or..not.out1file)
+ & 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 sc_loc_geom(lprn)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include "mpif.h"
+#endif
+ 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) 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) 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
+ call vecpr(x_prime,y_prime,z_prime)
+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
+ do i=2,nres
+ iti=itype(i)
+ if(me.eq.king.or..not.out1file)
+ & write (iout,'(a3,i4,3f10.5)') restyp(iti),i,xxref(i),
+ & yyref(i),zzref(i)
+ enddo
+ endif
+ return
+ end
+c---------------------------------------------------------------------------
+ subroutine sccenter(ires,nscat,sccor)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ dimension sccor(3,20)
+ 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 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(itype(i+1))
+ vbld_inv(i+1+nres)=dsc_inv(itype(i+1))
+c print *,vbld(i+1),vbld(i+1+nres)
+ enddo
+ return
+ end
+
--- /dev/null
+ subroutine readrtns
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.SETUP'
+ include 'COMMON.CONTROL'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.IOUNITS'
+ logical file_exist
+C Read force-field parameters except weights
+ call parmread
+C Read job setup parameters
+ call read_control
+C Read control parameters for energy minimzation if required
+ if (minim) call read_minim
+C Read MCM control parameters if required
+ if (modecalc.eq.3 .or. modecalc.eq.6) call mcmread
+C Read MD control parameters if reqjuired
+ if (modecalc.eq.12) call read_MDpar
+C Read MREMD control parameters if required
+ if (modecalc.eq.14) then
+ call read_MDpar
+ call read_REMDpar
+ endif
+C Read MUCA control parameters if required
+ if (lmuca) call read_muca
+C Read CSA control parameters if required (from fort.40 if exists
+C otherwise from general input file)
+csa if (modecalc.eq.8) then
+csa inquire (file="fort.40",exist=file_exist)
+csa if (.not.file_exist) call csaread
+csa endif
+cfmc if (modecalc.eq.10) call mcmfread
+C Read molecule information, molecule geometry, energy-term weights, and
+C restraints if requested
+ call molread
+C Print restraint information
+#ifdef MPI
+ if (.not. out1file .or. me.eq.king) then
+#endif
+ if (nhpb.gt.nss)
+ &write (iout,'(a,i5,a)') "The following",nhpb-nss,
+ & " distance constraints have been imposed"
+ do i=nss+1,nhpb
+ write (iout,'(3i6,i2,3f10.5)') i-nss,ihpb(i),jhpb(i),
+ & ibecarb(i),dhpb(i),dhpb1(i),forcon(i)
+ enddo
+#ifdef MPI
+ endif
+#endif
+c print *,"Processor",myrank," leaves READRTNS"
+ return
+ end
+C-------------------------------------------------------------------------------
+ subroutine read_control
+C
+C Read contorl data
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MP
+ include 'mpif.h'
+ logical OKRandom, prng_restart
+ real*8 r1
+#endif
+ include 'COMMON.IOUNITS'
+ include 'COMMON.TIME1'
+ include 'COMMON.THREAD'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.CONTROL'
+ include 'COMMON.MCM'
+ include 'COMMON.MAP'
+ include 'COMMON.HEADER'
+csa include 'COMMON.CSA'
+ include 'COMMON.CHAIN'
+ include 'COMMON.MUCA'
+ include 'COMMON.MD'
+ include 'COMMON.FFIELD'
+ include 'COMMON.SETUP'
+ COMMON /MACHSW/ KDIAG,ICORFL,IXDR
+ character*8 diagmeth(0:3) /'Library','EVVRSP','Givens','Jacobi'/
+ character*80 ucase
+ character*320 controlcard
+
+ nglob_csa=0
+ eglob_csa=1d99
+ nmin_csa=0
+ read (INP,'(a)') titel
+ call card_concat(controlcard)
+c out1file=index(controlcard,'OUT1FILE').gt.0 .or. fg_rank.gt.0
+c print *,"Processor",me," fg_rank",fg_rank," out1file",out1file
+ call reada(controlcard,'SEED',seed,0.0D0)
+ call random_init(seed)
+C Set up the time limit (caution! The time must be input in minutes!)
+ read_cart=index(controlcard,'READ_CART').gt.0
+ call readi(controlcard,'CONSTR_DIST',constr_dist,0)
+ call reada(controlcard,'TIMLIM',timlim,960.0D0) ! default 16 hours
+ unres_pdb = index(controlcard,'UNRES_PDB') .gt. 0
+ call reada(controlcard,'SAFETY',safety,30.0D0) ! default 30 minutes
+ call reada(controlcard,'RMSDBC',rmsdbc,3.0D0)
+ call reada(controlcard,'RMSDBC1',rmsdbc1,0.5D0)
+ call reada(controlcard,'RMSDBC1MAX',rmsdbc1max,1.5D0)
+ call reada(controlcard,'RMSDBCM',rmsdbcm,3.0D0)
+ call reada(controlcard,'DRMS',drms,0.1D0)
+ if(me.eq.king .or. .not. out1file .and. fg_rank.eq.0) then
+ write (iout,'(a,f10.1)')'RMSDBC = ',rmsdbc
+ write (iout,'(a,f10.1)')'RMSDBC1 = ',rmsdbc1
+ write (iout,'(a,f10.1)')'RMSDBC1MAX = ',rmsdbc1max
+ write (iout,'(a,f10.1)')'DRMS = ',drms
+ write (iout,'(a,f10.1)')'RMSDBCM = ',rmsdbcm
+ write (iout,'(a,f10.1)') 'Time limit (min):',timlim
+ endif
+ call readi(controlcard,'NZ_START',nz_start,0)
+ call readi(controlcard,'NZ_END',nz_end,0)
+ call readi(controlcard,'IZ_SC',iz_sc,0)
+ timlim=60.0D0*timlim
+ safety = 60.0d0*safety
+ timem=timlim
+ modecalc=0
+ call reada(controlcard,"T_BATH",t_bath,300.0d0)
+ minim=(index(controlcard,'MINIMIZE').gt.0)
+ dccart=(index(controlcard,'CART').gt.0)
+ overlapsc=(index(controlcard,'OVERLAP').gt.0)
+ overlapsc=.not.overlapsc
+ searchsc=(index(controlcard,'NOSEARCHSC').gt.0)
+ searchsc=.not.searchsc
+ sideadd=(index(controlcard,'SIDEADD').gt.0)
+ energy_dec=(index(controlcard,'ENERGY_DEC').gt.0)
+ outpdb=(index(controlcard,'PDBOUT').gt.0)
+ outmol2=(index(controlcard,'MOL2OUT').gt.0)
+ pdbref=(index(controlcard,'PDBREF').gt.0)
+ refstr=pdbref .or. (index(controlcard,'REFSTR').gt.0)
+ indpdb=index(controlcard,'PDBSTART')
+ extconf=(index(controlcard,'EXTCONF').gt.0)
+ call readi(controlcard,'IPRINT',iprint,0)
+ call readi(controlcard,'MAXGEN',maxgen,10000)
+ call readi(controlcard,'MAXOVERLAP',maxoverlap,1000)
+ call readi(controlcard,"KDIAG",kdiag,0)
+ call readi(controlcard,"RESCALE_MODE",rescale_mode,2)
+ if(me.eq.king .or. .not. out1file .and. fg_rank.eq.0)
+ & write (iout,*) "RESCALE_MODE",rescale_mode
+ split_ene=index(controlcard,'SPLIT_ENE').gt.0
+ if (index(controlcard,'REGULAR').gt.0.0D0) then
+ call reada(controlcard,'WEIDIS',weidis,0.1D0)
+ modecalc=1
+ refstr=.true.
+ endif
+ if (index(controlcard,'CHECKGRAD').gt.0) then
+ modecalc=5
+ if (index(controlcard,'CART').gt.0) then
+ icheckgrad=1
+ elseif (index(controlcard,'CARINT').gt.0) then
+ icheckgrad=2
+ else
+ icheckgrad=3
+ endif
+ elseif (index(controlcard,'THREAD').gt.0) then
+ modecalc=2
+ call readi(controlcard,'THREAD',nthread,0)
+ if (nthread.gt.0) then
+ call reada(controlcard,'WEIDIS',weidis,0.1D0)
+ else
+ if (fg_rank.eq.0)
+ & write (iout,'(a)')'A number has to follow the THREAD keyword.'
+ stop 'Error termination in Read_Control.'
+ endif
+ else if (index(controlcard,'MCMA').gt.0) then
+ modecalc=3
+ else if (index(controlcard,'MCEE').gt.0) then
+ modecalc=6
+ else if (index(controlcard,'MULTCONF').gt.0) then
+ modecalc=4
+ else if (index(controlcard,'MAP').gt.0) then
+ modecalc=7
+ call readi(controlcard,'MAP',nmap,0)
+ else if (index(controlcard,'CSA').gt.0) then
+ write(*,*) "CSA not supported in this version"
+ stop
+csa modecalc=8
+crc else if (index(controlcard,'ZSCORE').gt.0) then
+crc
+crc ZSCORE is rm from UNRES, modecalc=9 is available
+crc
+crc modecalc=9
+cfcm else if (index(controlcard,'MCMF').gt.0) then
+cfmc modecalc=10
+ else if (index(controlcard,'SOFTREG').gt.0) then
+ modecalc=11
+ else if (index(controlcard,'CHECK_BOND').gt.0) then
+ modecalc=-1
+ else if (index(controlcard,'TEST').gt.0) then
+ modecalc=-2
+ else if (index(controlcard,'MD').gt.0) then
+ modecalc=12
+ else if (index(controlcard,'RE ').gt.0) then
+ modecalc=14
+ endif
+
+ lmuca=index(controlcard,'MUCA').gt.0
+ call readi(controlcard,'MUCADYN',mucadyn,0)
+ call readi(controlcard,'MUCASMOOTH',muca_smooth,0)
+ if (lmuca .and. (me.eq.king .or. .not.out1file ))
+ & then
+ write (iout,*) 'MUCADYN=',mucadyn
+ write (iout,*) 'MUCASMOOTH=',muca_smooth
+ endif
+
+ iscode=index(controlcard,'ONE_LETTER')
+ indphi=index(controlcard,'PHI')
+ indback=index(controlcard,'BACK')
+ iranconf=index(controlcard,'RAND_CONF')
+ i2ndstr=index(controlcard,'USE_SEC_PRED')
+ gradout=index(controlcard,'GRADOUT').gt.0
+ gnorm_check=index(controlcard,'GNORM_CHECK').gt.0
+
+ if(me.eq.king.or..not.out1file)
+ & write (iout,'(2a)') diagmeth(kdiag),
+ & ' routine used to diagonalize matrices.'
+ return
+ end
+c--------------------------------------------------------------------------
+ subroutine read_REMDpar
+C
+C Read REMD settings
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.TIME1'
+ include 'COMMON.MD'
+#ifndef LANG0
+ include 'COMMON.LANGEVIN'
+#else
+ include 'COMMON.LANGEVIN.lang0'
+#endif
+ include 'COMMON.INTERACT'
+ include 'COMMON.NAMES'
+ include 'COMMON.GEO'
+ include 'COMMON.REMD'
+ include 'COMMON.CONTROL'
+ include 'COMMON.SETUP'
+ character*80 ucase
+ character*320 controlcard
+ character*3200 controlcard1
+ integer iremd_m_total
+
+ if(me.eq.king.or..not.out1file)
+ & write (iout,*) "REMD setup"
+
+ call card_concat(controlcard)
+ call readi(controlcard,"NREP",nrep,3)
+ call readi(controlcard,"NSTEX",nstex,1000)
+ call reada(controlcard,"RETMIN",retmin,10.0d0)
+ call reada(controlcard,"RETMAX",retmax,1000.0d0)
+ mremdsync=(index(controlcard,'SYNC').gt.0)
+ call readi(controlcard,"NSYN",i_sync_step,100)
+ restart1file=(index(controlcard,'REST1FILE').gt.0)
+ traj1file=(index(controlcard,'TRAJ1FILE').gt.0)
+ call readi(controlcard,"TRAJCACHE",max_cache_traj_use,1)
+ if(max_cache_traj_use.gt.max_cache_traj)
+ & max_cache_traj_use=max_cache_traj
+ if(me.eq.king.or..not.out1file) then
+cd if (traj1file) then
+crc caching is in testing - NTWX is not ignored
+cd write (iout,*) "NTWX value is ignored"
+cd write (iout,*) " trajectory is stored to one file by master"
+cd write (iout,*) " before exchange at NSTEX intervals"
+cd endif
+ write (iout,*) "NREP= ",nrep
+ write (iout,*) "NSTEX= ",nstex
+ write (iout,*) "SYNC= ",mremdsync
+ write (iout,*) "NSYN= ",i_sync_step
+ write (iout,*) "TRAJCACHE= ",max_cache_traj_use
+ endif
+
+ t_exchange_only=(index(controlcard,'TONLY').gt.0)
+ call readi(controlcard,"HREMD",hremd,0)
+ if((me.eq.king.or..not.out1file).and.hremd.gt.0) then
+ write (iout,*) "Hamiltonian REMD with ",hremd," sets of weights"
+ endif
+ if(usampl.and.hremd.gt.0) then
+ write (iout,'(//a)')
+ & "========== ERROR: USAMPL and HREMD cannot be used together"
+#ifdef MPI
+ call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE)
+#endif
+ stop
+ endif
+
+
+ remd_tlist=.false.
+ if (index(controlcard,'TLIST').gt.0) then
+ remd_tlist=.true.
+ call card_concat(controlcard1)
+ read(controlcard1,*) (remd_t(i),i=1,nrep)
+ if(me.eq.king.or..not.out1file)
+ & write (iout,*)'tlist',(remd_t(i),i=1,nrep)
+ endif
+ remd_mlist=.false.
+ if (index(controlcard,'MLIST').gt.0) then
+ remd_mlist=.true.
+ call card_concat(controlcard1)
+ read(controlcard1,*) (remd_m(i),i=1,nrep)
+ if(me.eq.king.or..not.out1file) then
+ write (iout,*)'mlist',(remd_m(i),i=1,nrep)
+ iremd_m_total=0
+ do i=1,nrep
+ iremd_m_total=iremd_m_total+remd_m(i)
+ enddo
+ if(hremd.gt.1)then
+ write (iout,*) 'Total number of replicas ',
+ & iremd_m_total*hremd
+ else
+ write (iout,*) 'Total number of replicas ',iremd_m_total
+ endif
+ endif
+ endif
+ if(me.eq.king.or..not.out1file)
+ & write (iout,'(/30(1h=),a,29(1h=)/)') " End of REMD run setup "
+ return
+ end
+c--------------------------------------------------------------------------
+ subroutine read_MDpar
+C
+C Read MD settings
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.TIME1'
+ include 'COMMON.MD'
+#ifndef LANG0
+ include 'COMMON.LANGEVIN'
+#else
+ include 'COMMON.LANGEVIN.lang0'
+#endif
+ include 'COMMON.INTERACT'
+ include 'COMMON.NAMES'
+ include 'COMMON.GEO'
+ include 'COMMON.SETUP'
+ include 'COMMON.CONTROL'
+ include 'COMMON.SPLITELE'
+ character*80 ucase
+ character*320 controlcard
+
+ call card_concat(controlcard)
+ call readi(controlcard,"NSTEP",n_timestep,1000000)
+ call readi(controlcard,"NTWE",ntwe,100)
+ call readi(controlcard,"NTWX",ntwx,1000)
+ call reada(controlcard,"DT",d_time,1.0d-1)
+ call reada(controlcard,"DVMAX",dvmax,2.0d1)
+ call reada(controlcard,"DAMAX",damax,1.0d1)
+ call reada(controlcard,"EDRIFTMAX",edriftmax,1.0d+1)
+ call readi(controlcard,"LANG",lang,0)
+ RESPA = index(controlcard,"RESPA") .gt. 0
+ call readi(controlcard,"NTIME_SPLIT",ntime_split,1)
+ ntime_split0=ntime_split
+ call readi(controlcard,"MAXTIME_SPLIT",maxtime_split,64)
+ ntime_split0=ntime_split
+ call reada(controlcard,"R_CUT",r_cut,2.0d0)
+ call reada(controlcard,"LAMBDA",rlamb,0.3d0)
+ rest = index(controlcard,"REST").gt.0
+ tbf = index(controlcard,"TBF").gt.0
+ call readi(controlcard,"HMC",hmc,0)
+ tnp = index(controlcard,"NOSEPOINCARE99").gt.0
+ tnp1 = index(controlcard,"NOSEPOINCARE01").gt.0
+ tnh = index(controlcard,"NOSEHOOVER96").gt.0
+ if (RESPA.and.tnh)then
+ xiresp = index(controlcard,"XIRESP").gt.0
+ endif
+ call reada(controlcard,"Q_NP",Q_np,0.1d0)
+ usampl = index(controlcard,"USAMPL").gt.0
+
+ mdpdb = index(controlcard,"MDPDB").gt.0
+ call reada(controlcard,"T_BATH",t_bath,300.0d0)
+ call reada(controlcard,"TAU_BATH",tau_bath,1.0d-1)
+ call reada(controlcard,"EQ_TIME",eq_time,1.0d+4)
+ call readi(controlcard,"RESET_MOMENT",count_reset_moment,1000)
+ if (count_reset_moment.eq.0) count_reset_moment=1000000000
+ call readi(controlcard,"RESET_VEL",count_reset_vel,1000)
+ reset_moment=lang.eq.0 .and. tbf .and. count_reset_moment.gt.0
+ reset_vel=lang.eq.0 .and. tbf .and. count_reset_vel.gt.0
+ if (count_reset_vel.eq.0) count_reset_vel=1000000000
+ large = index(controlcard,"LARGE").gt.0
+ print_compon = index(controlcard,"PRINT_COMPON").gt.0
+ rattle = index(controlcard,"RATTLE").gt.0
+c if performing umbrella sampling, fragments constrained are read from the fragment file
+ nset=0
+ if(usampl) then
+ call read_fragments
+ endif
+
+ if(me.eq.king.or..not.out1file) then
+ write (iout,*)
+ write (iout,'(27(1h=),a26,27(1h=))') " Parameters of the MD run "
+ write (iout,*)
+ write (iout,'(a)') "The units are:"
+ write (iout,'(a)') "positions: angstrom, time: 48.9 fs"
+ write (iout,'(2a)') "velocity: angstrom/(48.9 fs),",
+ & " acceleration: angstrom/(48.9 fs)**2"
+ write (iout,'(a)') "energy: kcal/mol, temperature: K"
+ write (iout,*)
+ write (iout,'(a60,i10)') "Number of time steps:",n_timestep
+ write (iout,'(a60,f10.5,a)')
+ & "Initial time step of numerical integration:",d_time,
+ & " natural units"
+ write (iout,'(60x,f10.5,a)') d_time*48.9," fs"
+ if (RESPA) then
+ write (iout,'(2a,i4,a)')
+ & "A-MTS algorithm used; initial time step for fast-varying",
+ & " short-range forces split into",ntime_split," steps."
+ write (iout,'(a,f5.2,a,f5.2)') "Short-range force cutoff",
+ & r_cut," lambda",rlamb
+ endif
+ write (iout,'(2a,f10.5)')
+ & "Maximum acceleration threshold to reduce the time step",
+ & "/increase split number:",damax
+ write (iout,'(2a,f10.5)')
+ & "Maximum predicted energy drift to reduce the timestep",
+ & "/increase split number:",edriftmax
+ write (iout,'(a60,f10.5)')
+ & "Maximum velocity threshold to reduce velocities:",dvmax
+ write (iout,'(a60,i10)') "Frequency of property output:",ntwe
+ write (iout,'(a60,i10)') "Frequency of coordinate output:",ntwx
+ if (rattle) write (iout,'(a60)')
+ & "Rattle algorithm used to constrain the virtual bonds"
+ endif
+ reset_fricmat=1000
+ if (lang.gt.0) then
+ call reada(controlcard,"ETAWAT",etawat,0.8904d0)
+ call reada(controlcard,"RWAT",rwat,1.4d0)
+ call reada(controlcard,"SCAL_FRIC",scal_fric,2.0d-2)
+ surfarea=index(controlcard,"SURFAREA").gt.0
+ call readi(controlcard,"RESET_FRICMAT",reset_fricmat,1000)
+ if(me.eq.king.or..not.out1file)then
+ write (iout,'(/a,$)') "Langevin dynamics calculation"
+ if (lang.eq.1) then
+ write (iout,'(a/)')
+ & " with direct integration of Langevin equations"
+ else if (lang.eq.2) then
+ write (iout,'(a/)') " with TINKER stochasic MD integrator"
+ else if (lang.eq.3) then
+ write (iout,'(a/)') " with Ciccotti's stochasic MD integrator"
+ else if (lang.eq.4) then
+ write (iout,'(a/)') " in overdamped mode"
+ else
+ write (iout,'(//a,i5)')
+ & "=========== ERROR: Unknown Langevin dynamics mode:",lang
+ stop
+ endif
+ write (iout,'(a60,f10.5)') "Temperature:",t_bath
+ write (iout,'(a60,f10.5)') "Viscosity of the solvent:",etawat
+ write (iout,'(a60,f10.5)') "Radius of solvent molecule:",rwat
+ write (iout,'(a60,f10.5)')
+ & "Scaling factor of the friction forces:",scal_fric
+ if (surfarea) write (iout,'(2a,i10,a)')
+ & "Friction coefficients will be scaled by solvent-accessible",
+ & " surface area every",reset_fricmat," steps."
+ endif
+c Calculate friction coefficients and bounds of stochastic forces
+ eta=6*pi*cPoise*etawat
+ if(me.eq.king.or..not.out1file)
+ & write(iout,'(a60,f10.5)')"Eta of the solvent in natural units:"
+ & ,eta
+ gamp=scal_fric*(pstok+rwat)*eta
+ stdfp=dsqrt(2*Rb*t_bath/d_time)
+ do i=1,ntyp
+ gamsc(i)=scal_fric*(restok(i)+rwat)*eta
+ stdfsc(i)=dsqrt(2*Rb*t_bath/d_time)
+ enddo
+ if(me.eq.king.or..not.out1file)then
+ write (iout,'(/2a/)')
+ & "Radii of site types and friction coefficients and std's of",
+ & " stochastic forces of fully exposed sites"
+ write (iout,'(a5,f5.2,2f10.5)')'p',pstok,gamp,stdfp*dsqrt(gamp)
+ do i=1,ntyp
+ write (iout,'(a5,f5.2,2f10.5)') restyp(i),restok(i),
+ & gamsc(i),stdfsc(i)*dsqrt(gamsc(i))
+ enddo
+ endif
+ else if (tbf) then
+ if(me.eq.king.or..not.out1file)then
+ write (iout,'(a)') "Berendsen bath calculation"
+ write (iout,'(a60,f10.5)') "Temperature:",t_bath
+ write (iout,'(a60,f10.5)') "Coupling constant (tau):",tau_bath
+ if (reset_moment)
+ & write (iout,'(a,i10,a)') "Momenta will be reset at zero every",
+ & count_reset_moment," steps"
+ if (reset_vel)
+ & write (iout,'(a,i10,a)')
+ & "Velocities will be reset at random every",count_reset_vel,
+ & " steps"
+ endif
+ else if (tnp .or. tnp1 .or. tnh) then
+ if (tnp .or. tnp1) then
+ write (iout,'(a)') "Nose-Poincare bath calculation"
+ if (tnp) write (iout,'(a)')
+ & "J.Comput.Phys. 151 114 (1999) S.D.Bond B.J.Leimkuhler B.B.Laird"
+ if (tnp1) write (iout,'(a)') "JPSJ 70 75 (2001) S. Nose"
+ else
+ write (iout,'(a)') "Nose-Hoover bath calculation"
+ write (iout,'(a)') "Mol.Phys. 87 1117 (1996) Martyna et al."
+ nresn=1
+ nyosh=1
+ nnos=1
+ do i=1,nnos
+ qmass(i)=Q_np
+ xlogs(i)=1.0
+ vlogs(i)=0.0
+ enddo
+ do i=1,nyosh
+ WDTI(i) = 1.0*d_time/nresn
+ WDTI2(i)=WDTI(i)/2
+ WDTI4(i)=WDTI(i)/4
+ WDTI8(i)=WDTI(i)/8
+ enddo
+ if (RESPA) then
+ if(xiresp) then
+ write (iout,'(a)') "NVT-XI-RESPA algorithm"
+ else
+ write (iout,'(a)') "NVT-XO-RESPA algorithm"
+ endif
+ do i=1,nyosh
+ WDTIi(i) = 1.0*d_time/nresn/ntime_split
+ WDTIi2(i)=WDTIi(i)/2
+ WDTIi4(i)=WDTIi(i)/4
+ WDTIi8(i)=WDTIi(i)/8
+ enddo
+ endif
+ endif
+
+ write (iout,'(a60,f10.5)') "Temperature:",t_bath
+ write (iout,'(a60,f10.5)') "Q =",Q_np
+ if (reset_moment)
+ & write (iout,'(a,i10,a)') "Momenta will be reset at zero every",
+ & count_reset_moment," steps"
+ if (reset_vel)
+ & write (iout,'(a,i10,a)')
+ & "Velocities will be reset at random every",count_reset_vel,
+ & " steps"
+
+ else if (hmc.gt.0) then
+ write (iout,'(a)') "Hybrid Monte Carlo calculation"
+ write (iout,'(a60,f10.5)') "Temperature:",t_bath
+ write (iout,'(a60,i10)')
+ & "Number of MD steps between Metropolis tests:",hmc
+
+ else
+ if(me.eq.king.or..not.out1file)
+ & write (iout,'(a31)') "Microcanonical mode calculation"
+ endif
+ if(me.eq.king.or..not.out1file)then
+ if (rest) write (iout,'(/a/)') "===== Calculation restarted ===="
+ if (usampl) then
+ write(iout,*) "MD running with constraints."
+ write(iout,*) "Equilibration time ", eq_time, " mtus."
+ write(iout,*) "Constraining ", nfrag," fragments."
+ write(iout,*) "Length of each fragment, weight and q0:"
+ do iset=1,nset
+ write (iout,*) "Set of restraints #",iset
+ do i=1,nfrag
+ write(iout,'(2i5,f8.1,f7.4)') ifrag(1,i,iset),
+ & ifrag(2,i,iset),wfrag(i,iset),qinfrag(i,iset)
+ enddo
+ write(iout,*) "constraints between ", npair, "fragments."
+ write(iout,*) "constraint pairs, weights and q0:"
+ do i=1,npair
+ write(iout,'(2i5,f8.1,f7.4)') ipair(1,i,iset),
+ & ipair(2,i,iset),wpair(i,iset),qinpair(i,iset)
+ enddo
+ write(iout,*) "angle constraints within ", nfrag_back,
+ & "backbone fragments."
+ write(iout,*) "fragment, weights:"
+ do i=1,nfrag_back
+ write(iout,'(2i5,3f8.1)') ifrag_back(1,i,iset),
+ & ifrag_back(2,i,iset),wfrag_back(1,i,iset),
+ & wfrag_back(2,i,iset),wfrag_back(3,i,iset)
+ enddo
+ enddo
+ iset=mod(kolor,nset)+1
+ endif
+ endif
+ if(me.eq.king.or..not.out1file)
+ & write (iout,'(/30(1h=),a,29(1h=)/)') " End of MD run setup "
+ return
+ end
+c------------------------------------------------------------------------------
+ subroutine molread
+C
+C Read molecular data.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+ integer error_msg
+#endif
+ 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.DBASE'
+ include 'COMMON.THREAD'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.TORCNSTR'
+ include 'COMMON.TIME1'
+ include 'COMMON.BOUNDS'
+ include 'COMMON.MD'
+ include 'COMMON.REMD'
+ include 'COMMON.SETUP'
+ character*4 sequence(maxres)
+ integer rescode
+ double precision x(maxvar)
+ character*256 pdbfile
+ character*320 weightcard
+ character*80 weightcard_t,ucase
+ dimension itype_pdb(maxres)
+ common /pizda/ itype_pdb
+ logical seq_comp,fail
+ double precision energia(0:n_ene)
+ integer ilen
+ external ilen
+C
+C Body
+C
+C Read weights of the subsequent energy terms.
+ if(hremd.gt.0) then
+
+ k=0
+ do il=1,hremd
+ do i=1,nrep
+ do j=1,remd_m(i)
+ i2set(k)=il
+ k=k+1
+ enddo
+ enddo
+ enddo
+
+ if(me.eq.king.or..not.out1file) then
+ write (iout,*) 'Reading ',hremd,' sets of weights for HREMD'
+ write (iout,*) 'Current weights for processor ',
+ & me,' set ',i2set(me)
+ endif
+
+ do i=1,hremd
+ call card_concat(weightcard)
+ call reada(weightcard,'WLONG',wlong,1.0D0)
+ call reada(weightcard,'WSC',wsc,wlong)
+ call reada(weightcard,'WSCP',wscp,wlong)
+ 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,'WSCCOR',wsccor,1.0D0)
+ call reada(weightcard,'WSTRAIN',wstrain,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,'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)
+ call reada(weightcard,'TEMP0',temp0,300.0d0)
+ if (index(weightcard,'SOFT').gt.0) ipot=6
+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
+
+ hweights(i,1)=wsc
+ hweights(i,2)=wscp
+ hweights(i,3)=welec
+ hweights(i,4)=wcorr
+ hweights(i,5)=wcorr5
+ hweights(i,6)=wcorr6
+ hweights(i,7)=wel_loc
+ hweights(i,8)=wturn3
+ hweights(i,9)=wturn4
+ hweights(i,10)=wturn6
+ hweights(i,11)=wang
+ hweights(i,12)=wscloc
+ hweights(i,13)=wtor
+ hweights(i,14)=wtor_d
+ hweights(i,15)=wstrain
+ hweights(i,16)=wvdwpp
+ hweights(i,17)=wbond
+ hweights(i,18)=scal14
+ hweights(i,21)=wsccor
+
+ enddo
+
+ do i=1,n_ene
+ weights(i)=hweights(i2set(me),i)
+ enddo
+ wsc =weights(1)
+ wscp =weights(2)
+ welec =weights(3)
+ wcorr =weights(4)
+ wcorr5 =weights(5)
+ wcorr6 =weights(6)
+ wel_loc=weights(7)
+ wturn3 =weights(8)
+ wturn4 =weights(9)
+ wturn6 =weights(10)
+ wang =weights(11)
+ wscloc =weights(12)
+ wtor =weights(13)
+ wtor_d =weights(14)
+ wstrain=weights(15)
+ wvdwpp =weights(16)
+ wbond =weights(17)
+ scal14 =weights(18)
+ wsccor =weights(21)
+
+
+ else
+ call card_concat(weightcard)
+ call reada(weightcard,'WLONG',wlong,1.0D0)
+ call reada(weightcard,'WSC',wsc,wlong)
+ call reada(weightcard,'WSCP',wscp,wlong)
+ 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,'WSCCOR',wsccor,1.0D0)
+ call reada(weightcard,'WSTRAIN',wstrain,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,'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)
+ call reada(weightcard,'TEMP0',temp0,300.0d0)
+ if (index(weightcard,'SOFT').gt.0) ipot=6
+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)=wbond
+ weights(18)=scal14
+ weights(21)=wsccor
+ endif
+
+ if(me.eq.king.or..not.out1file)
+ & write (iout,10) wsc,wscp,welec,wvdwpp,wbond,wang,wscloc,wtor,
+ & wtor_d,wstrain,wel_loc,wcorr,wcorr5,wcorr6,wsccor,wturn3,
+ & wturn4,wturn6
+ 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)'/
+ & 'WSCCOR= ',f10.6,' (back-scloc correlation)'/
+ & 'WTURN3= ',f10.6,' (turns, 3rd order)'/
+ & 'WTURN4= ',f10.6,' (turns, 4th order)'/
+ & 'WTURN6= ',f10.6,' (turns, 6th order)')
+ if(me.eq.king.or..not.out1file)then
+ 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
+ endif
+ 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
+ call rescale_weights(t_bath)
+ if(me.eq.king.or..not.out1file)
+ & write (iout,22) wsc,wscp,welec,wvdwpp,wbond,wang,wscloc,wtor,
+ & wtor_d,wstrain,wel_loc,wcorr,wcorr5,wcorr6,wsccor,wturn3,
+ & wturn4,wturn6
+ 22 format (/'Energy-term weights (scaled):'//
+ & '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)'/
+ & 'WSCCOR= ',f10.6,' (back-scloc correlatkion)'/
+ & 'WTURN3= ',f10.6,' (turns, 3rd order)'/
+ & 'WTURN4= ',f10.6,' (turns, 4th order)'/
+ & 'WTURN6= ',f10.6,' (turns, 6th order)')
+ if(me.eq.king.or..not.out1file)
+ & write (iout,*) "Reference temperature for weights calculation:",
+ & temp0
+ 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)
+ if(me.eq.king.or..not.out1file) then
+ write (iout,*) "Parameters of the SS-bond potential:"
+ write (iout,*) "D0CM",d0cm," AKCM",akcm," AKTH",akth,
+ & " AKCT",akct
+ write (iout,*) "V1SS",v1ss," V2SS",v2ss," V3SS",v3ss
+ write (iout,*) "EBR",ebr
+ print *,'indpdb=',indpdb,' pdbref=',pdbref
+ endif
+ if (indpdb.gt.0 .or. pdbref) then
+ read(inp,'(a)') pdbfile
+ if(me.eq.king.or..not.out1file)
+ & write (iout,'(2a)') '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.'
+ stop
+ 34 continue
+c print *,'Begin reading pdb data'
+ call readpdb
+c print *,'Finished reading pdb data'
+ if(me.eq.king.or..not.out1file)
+ & write (iout,'(a,i3,a,i3)')'nsup=',nsup,
+ & ' nstart_sup=',nstart_sup
+ do i=1,nres
+ itype_pdb(i)=itype(i)
+ enddo
+ close (ipdbin)
+ nnt=nstart_sup
+ nct=nstart_sup+nsup-1
+ call contact(.false.,ncont_ref,icont_ref,co)
+
+ if (sideadd) then
+ if(me.eq.king.or..not.out1file)
+ & write(iout,*)'Adding sidechains'
+ maxsi=1000
+ do i=2,nres-1
+ iti=itype(i)
+ if (iti.ne.10) then
+ nsi=0
+ fail=.true.
+ do while (fail.and.nsi.le.maxsi)
+ call gen_side(iti,theta(i+1),alph(i),omeg(i),fail)
+ nsi=nsi+1
+ enddo
+ if(fail) write(iout,*)'Adding sidechain failed for res ',
+ & i,' after ',nsi,' trials'
+ endif
+ enddo
+ endif
+ endif
+ if (indpdb.eq.0) then
+C Read sequence if not taken from the pdb file.
+ read (inp,*) nres
+c print *,'nres=',nres
+ 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 Assign initial virtual bond lengths
+ do i=2,nres
+ vbld(i)=vbl
+ vbld_inv(i)=vblinv
+ enddo
+ do i=2,nres-1
+ vbld(i+nres)=dsc(itype(i))
+ vbld_inv(i+nres)=dsc_inv(itype(i))
+c write (iout,*) "i",i," itype",itype(i),
+c & " dsc",dsc(itype(i))," vbld",vbld(i),vbld(i+nres)
+ enddo
+ endif
+c print *,nres
+c print '(20i4)',(itype(i),i=1,nres)
+ do i=1,nres
+#ifdef PROCOR
+ if (itype(i).eq.21 .or. itype(i+1).eq.21) then
+#else
+ if (itype(i).eq.21) then
+#endif
+ itel(i)=0
+#ifdef PROCOR
+ else if (itype(i+1).ne.20) then
+#else
+ else if (itype(i).ne.20) then
+#endif
+ itel(i)=1
+ else
+ itel(i)=2
+ endif
+ enddo
+ if(me.eq.king.or..not.out1file)then
+ write (iout,*) "ITEL"
+ do i=1,nres-1
+ write (iout,*) i,itype(i),itel(i)
+ enddo
+ print *,'Call Read_Bridge.'
+ endif
+ call read_bridge
+C 8/13/98 Set limits to generating the dihedral angles
+ do i=1,nres
+ phibound(1,i)=-pi
+ phibound(2,i)=pi
+ enddo
+ read (inp,*) ndih_constr
+ if (ndih_constr.gt.0) then
+ read (inp,*) ftors
+ read (inp,*) (idih_constr(i),phi0(i),drange(i),i=1,ndih_constr)
+ if(me.eq.king.or..not.out1file)then
+ write (iout,*)
+ & 'There are',ndih_constr,' constraints on phi angles.'
+ do i=1,ndih_constr
+ write (iout,'(i5,2f8.3)') idih_constr(i),phi0(i),drange(i)
+ enddo
+ endif
+ do i=1,ndih_constr
+ phi0(i)=deg2rad*phi0(i)
+ drange(i)=deg2rad*drange(i)
+ enddo
+ if(me.eq.king.or..not.out1file)
+ & write (iout,*) 'FTORS',ftors
+ do i=1,ndih_constr
+ ii = idih_constr(i)
+ phibound(1,ii) = phi0(i)-drange(i)
+ phibound(2,ii) = phi0(i)+drange(i)
+ enddo
+ endif
+ nnt=1
+#ifdef MPI
+ if (me.eq.king) then
+#endif
+ write (iout,'(a)') 'Boundaries in phi angle sampling:'
+ do i=1,nres
+ write (iout,'(a3,i5,2f10.1)')
+ & restyp(itype(i)),i,phibound(1,i)*rad2deg,phibound(2,i)*rad2deg
+ enddo
+#ifdef MP
+ endif
+#endif
+ nct=nres
+cd print *,'NNT=',NNT,' NCT=',NCT
+ if (itype(1).eq.21) nnt=2
+ if (itype(nres).eq.21) nct=nct-1
+ if (pdbref) then
+ if(me.eq.king.or..not.out1file)
+ & write (iout,'(a,i3)') 'nsup=',nsup
+ 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
+ nstart_seq=nnt+i
+ goto 111
+ endif
+ enddo
+ write (iout,'(a)')
+ & 'Error - sequences to be superposed do not match.'
+ stop
+ 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
+ if (nsup.eq.0) nsup=nct-nnt
+ if (nstart_sup.eq.0) nstart_sup=nnt
+ if (nstart_seq.eq.0) nstart_seq=nnt
+ if(me.eq.king.or..not.out1file)
+ & write (iout,*) 'nsup=',nsup,' nstart_sup=',nstart_sup,
+ & ' nstart_seq=',nstart_seq
+ endif
+c--- Zscore rms -------
+ if (nz_start.eq.0) nz_start=nnt
+ if (nz_end.eq.0 .and. nsup.gt.0) then
+ nz_end=nnt+nsup-1
+ else if (nz_end.eq.0) then
+ nz_end=nct
+ endif
+ if(me.eq.king.or..not.out1file)then
+ write (iout,*) 'NZ_START=',nz_start,' NZ_END=',nz_end
+ write (iout,*) 'IZ_SC=',iz_sc
+ endif
+c----------------------
+ call init_int_table
+ if (refstr) then
+ if (.not.pdbref) then
+ call read_angles(inp,*38)
+ goto 39
+ 38 write (iout,'(a)') 'Error reading reference structure.'
+#ifdef MPI
+ call MPI_Finalize(MPI_COMM_WORLD,IERROR)
+ stop 'Error reading reference structure'
+#endif
+ 39 call chainbuild
+ call setup_var
+czscore call geom_to_var(nvar,coord_exp_zs(1,1))
+ nstart_sup=nnt
+ nstart_seq=nnt
+ nsup=nct-nnt+1
+ do i=1,2*nres
+ do j=1,3
+ cref(j,i)=c(j,i)
+ enddo
+ enddo
+ call contact(.true.,ncont_ref,icont_ref,co)
+ endif
+ if(me.eq.king.or..not.out1file)
+ & write (iout,*) 'Contact order:',co
+ if (pdbref) then
+ if(me.eq.king.or..not.out1file)
+ & write (2,*) 'Shifting contacts:',nstart_seq,nstart_sup
+ do i=1,ncont_ref
+ do j=1,2
+ icont_ref(j,i)=icont_ref(j,i)+nstart_seq-nstart_sup
+ enddo
+ if(me.eq.king.or..not.out1file)
+ & write (2,*) i,' ',restyp(itype(icont_ref(1,i))),' ',
+ & icont_ref(1,i),' ',
+ & restyp(itype(icont_ref(2,i))),' ',icont_ref(2,i)
+ enddo
+ endif
+ endif
+c write (iout,*) "constr_dist",constr_dist,nstart_sup,nsup
+ if (constr_dist.gt.0) then
+ call read_dist_constr
+ call hpb_partition
+ endif
+c write (iout,*) "After read_dist_constr nhpb",nhpb
+c call flush(iout)
+ if (indpdb.eq.0 .and. modecalc.ne.2 .and. modecalc.ne.4
+ & .and. modecalc.ne.8 .and. modecalc.ne.9 .and.
+ & modecalc.ne.10) then
+C If input structure hasn't been supplied from the PDB file read or generate
+C initial geometry.
+ if (iranconf.eq.0 .and. .not. extconf) then
+ if(me.eq.king.or..not.out1file .and.fg_rank.eq.0)
+ & write (iout,'(a)') 'Initial geometry will be read in.'
+ if (read_cart) then
+ read(inp,'(8f10.5)',end=36,err=36)
+ & ((c(l,k),l=1,3),k=1,nres),
+ & ((c(l,k+nres),l=1,3),k=nnt,nct)
+ call int_from_cart1(.false.)
+ do i=1,nres-1
+ do j=1,3
+ dc(j,i)=c(j,i+1)-c(j,i)
+ dc_norm(j,i)=dc_norm(j,i)*vbld_inv(i+1)
+ enddo
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ do j=1,3
+ dc(j,i+nres)=c(j,i+nres)-c(j,i)
+ dc_norm(j,i+nres)=dc_norm(j,i+nres)*vbld_inv(i+nres)
+ enddo
+ endif
+ enddo
+ return
+ else
+ call read_angles(inp,*36)
+ endif
+ goto 37
+ 36 write (iout,'(a)') 'Error reading angle file.'
+#ifdef MPI
+ call mpi_finalize( MPI_COMM_WORLD,IERR )
+#endif
+ stop 'Error reading angle file.'
+ 37 continue
+ else if (extconf) then
+ if(me.eq.king.or..not.out1file .and. fg_rank.eq.0)
+ & write (iout,'(a)') 'Extended chain initial geometry.'
+ do i=3,nres
+ theta(i)=90d0*deg2rad
+ enddo
+ do i=4,nres
+ phi(i)=180d0*deg2rad
+ enddo
+ do i=2,nres-1
+ alph(i)=110d0*deg2rad
+ enddo
+ do i=2,nres-1
+ omeg(i)=-120d0*deg2rad
+ enddo
+ else
+ if(me.eq.king.or..not.out1file)
+ & write (iout,'(a)') 'Random-generated initial geometry.'
+
+
+#ifdef MPI
+ if (me.eq.king .or. fg_rank.eq.0 .and. (
+ & modecalc.eq.12 .or. modecalc.eq.14) ) then
+#endif
+ do itrial=1,100
+ itmp=1
+ call gen_rand_conf(itmp,*30)
+ goto 40
+ 30 write (iout,*) 'Failed to generate random conformation',
+ & ', itrial=',itrial
+ write (*,*) 'Processor:',me,
+ & ' Failed to generate random conformation',
+ & ' itrial=',itrial
+ call intout
+
+#ifdef AIX
+ call flush_(iout)
+#else
+ call flush(iout)
+#endif
+ enddo
+ write (iout,'(a,i3,a)') 'Processor:',me,
+ & ' error in generating random conformation.'
+ write (*,'(a,i3,a)') 'Processor:',me,
+ & ' error in generating random conformation.'
+ call flush(iout)
+#ifdef MPI
+ call MPI_Abort(mpi_comm_world,error_msg,ierrcode)
+ 40 continue
+ endif
+#else
+ 40 continue
+#endif
+ endif
+ elseif (modecalc.eq.4) then
+ read (inp,'(a)') intinname
+ open (intin,file=intinname,status='old',err=333)
+ if (me.eq.king .or. .not.out1file.and.fg_rank.eq.0)
+ & write (iout,'(a)') 'intinname',intinname
+ write (*,'(a)') 'Processor',myrank,' intinname',intinname
+ goto 334
+ 333 write (iout,'(2a)') 'Error opening angle file ',intinname
+#ifdef MPI
+ call MPI_Finalize(MPI_COMM_WORLD,IERR)
+#endif
+ stop 'Error opening angle file.'
+ 334 continue
+
+ endif
+C Generate distance constraints, if the PDB structure is to be regularized.
+ if (nthread.gt.0) then
+ call read_threadbase
+ endif
+ call setup_var
+ if (me.eq.king .or. .not. out1file)
+ & call intout
+ if (ns.gt.0 .and. (me.eq.king .or. .not.out1file) ) then
+ write (iout,'(/a,i3,a)')
+ & 'The chain contains',ns,' disulfide-bridging cysteines.'
+ write (iout,'(20i4)') (iss(i),i=1,ns)
+ write (iout,'(/a/)') 'Pre-formed links are:'
+ do i=1,nss
+ i1=ihpb(i)-nres
+ i2=jhpb(i)-nres
+ it1=itype(i1)
+ it2=itype(i2)
+ if (me.eq.king.or..not.out1file)
+ & 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
+ if (i2ndstr.gt.0) call secstrp2dihc
+c call geom_to_var(nvar,x)
+c call etotal(energia(0))
+c call enerprint(energia(0))
+c call briefout(0,etot)
+c stop
+cd write (iout,'(2(a,i3))') 'NNT',NNT,' NCT',NCT
+cd write (iout,'(a)') 'Variable list:'
+cd write (iout,'(i4,f10.5)') (i,rad2deg*x(i),i=1,nvar)
+#ifdef MPI
+ if (me.eq.king .or. (fg_rank.eq.0 .and. .not.out1file))
+ & write (iout,'(//80(1h*)/20x,a,i4,a/80(1h*)//)')
+ & 'Processor',myrank,': end reading molecular data.'
+#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 real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ 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.DBASE'
+ include 'COMMON.THREAD'
+ include 'COMMON.TIME1'
+ include 'COMMON.SETUP'
+C Read bridging residues.
+ read (inp,*) ns,(iss(i),i=1,ns)
+ print *,'ns=',ns
+ if(me.eq.king.or..not.out1file)
+ & write (iout,*) 'ns=',ns,' iss:',(iss(i),i=1,ns)
+C Check whether the specified bridging residues are cystines.
+ do i=1,ns
+ if (itype(iss(i)).ne.1) then
+ if (me.eq.king.or..not.out1file) write (iout,'(2a,i3,a)')
+ & 'Do you REALLY think that the residue ',restyp(iss(i)),i,
+ & ' can form a disulfide bridge?!!!'
+ write (*,'(2a,i3,a)')
+ & 'Do you REALLY think that the residue ',restyp(iss(i)),i,
+ & ' can form a disulfide bridge?!!!'
+#ifdef MPI
+ call MPI_Finalize(MPI_COMM_WORLD,ierror)
+ stop
+#endif
+ endif
+ enddo
+C Read preformed bridges.
+ if (ns.gt.0) then
+ read (inp,*) nss,(ihpb(i),jhpb(i),i=1,nss)
+ write (iout,*) 'nss=',nss,' ihpb,jhpb: ',(ihpb(i),jhpb(i),i=1,nss)
+ if (nss.gt.0) then
+ nhpb=nss
+C Check if the residues involved in bridges are in the specified list of
+C bridging residues.
+ do i=1,nss
+ do j=1,i-1
+ if (ihpb(i).eq.ihpb(j).or.ihpb(i).eq.jhpb(j)
+ & .or.jhpb(i).eq.ihpb(j).or.jhpb(i).eq.jhpb(j)) then
+ write (iout,'(a,i3,a)') 'Disulfide pair',i,
+ & ' contains residues present in other pairs.'
+ write (*,'(a,i3,a)') 'Disulfide pair',i,
+ & ' contains residues present in other pairs.'
+#ifdef MPI
+ call MPI_Finalize(MPI_COMM_WORLD,ierror)
+ 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
+ dhpb(i)=dbr
+ forcon(i)=fbr
+ enddo
+ do i=1,nss
+ ihpb(i)=ihpb(i)+nres
+ jhpb(i)=jhpb(i)+nres
+ enddo
+ endif
+ endif
+ return
+ end
+c----------------------------------------------------------------------------
+ subroutine read_x(kanal,*)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.CHAIN'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+c Read coordinates from input
+c
+ read(kanal,'(8f10.5)',end=10,err=10)
+ & ((c(l,k),l=1,3),k=1,nres),
+ & ((c(l,k+nres),l=1,3),k=nnt,nct)
+ do j=1,3
+ c(j,nres+1)=c(j,1)
+ c(j,2*nres)=c(j,nres)
+ enddo
+ call int_from_cart1(.false.)
+ 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=nnt,nct
+ if (itype(i).ne.10) then
+ 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
+ endif
+ enddo
+
+ return
+ 10 return1
+ end
+c----------------------------------------------------------------------------
+ subroutine read_threadbase
+ implicit real*8 (a-h,o-z)
+ 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.DBASE'
+ include 'COMMON.THREAD'
+ include 'COMMON.TIME1'
+C Read pattern database for threading.
+ read (icbase,*) nseq
+ do i=1,nseq
+ read (icbase,'(i5,2x,a8,2i4)') nres_base(1,i),str_nam(i),
+ & nres_base(2,i),nres_base(3,i)
+ read (icbase,'(9f8.3)') ((cart_base(k,j,i),k=1,3),j=1,
+ & nres_base(1,i))
+c write (iout,'(i5,2x,a8,2i4)') nres_base(1,i),str_nam(i),
+c & nres_base(2,i),nres_base(3,i)
+c write (iout,'(9f8.3)') ((cart_base(k,j,i),k=1,3),j=1,
+c & nres_base(1,i))
+ enddo
+ close (icbase)
+ if (weidis.eq.0.0D0) weidis=0.1D0
+ do i=nnt,nct
+ do j=i+2,nct
+ nhpb=nhpb+1
+ ihpb(nhpb)=i
+ jhpb(nhpb)=j
+ forcon(nhpb)=weidis
+ enddo
+ enddo
+ read (inp,*) nexcl,(iexam(1,i),iexam(2,i),i=1,nexcl)
+ write (iout,'(a,i5)') 'nexcl: ',nexcl
+ write (iout,'(2i5)') (iexam(1,i),iexam(2,i),i=1,nexcl)
+ return
+ end
+c------------------------------------------------------------------------------
+ subroutine setup_var
+ implicit real*8 (a-h,o-z)
+ 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.DBASE'
+ include 'COMMON.THREAD'
+ include 'COMMON.TIME1'
+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
+c----------------------------------------------------------------------------
+ subroutine gen_dist_constr
+C Generate CA distance constraints.
+ implicit real*8 (a-h,o-z)
+ 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.DBASE'
+ include 'COMMON.THREAD'
+ include 'COMMON.TIME1'
+ dimension itype_pdb(maxres)
+ common /pizda/ itype_pdb
+ character*2 iden
+cd print *,'gen_dist_constr: nnt=',nnt,' nct=',nct
+cd write (2,*) 'gen_dist_constr: nnt=',nnt,' nct=',nct,
+cd & ' nstart_sup',nstart_sup,' nstart_seq',nstart_seq,
+cd & ' nsup',nsup
+ do i=nstart_sup,nstart_sup+nsup-1
+cd write (2,*) 'i',i,' seq ',restyp(itype(i+nstart_seq-nstart_sup)),
+cd & ' seq_pdb', restyp(itype_pdb(i))
+ do j=i+2,nstart_sup+nsup-1
+ nhpb=nhpb+1
+ ihpb(nhpb)=i+nstart_seq-nstart_sup
+ jhpb(nhpb)=j+nstart_seq-nstart_sup
+ forcon(nhpb)=weidis
+ dhpb(nhpb)=dist(i,j)
+ enddo
+ enddo
+cd write (iout,'(a)') 'Distance constraints:'
+cd do i=nss+1,nhpb
+cd ii=ihpb(i)
+cd jj=jhpb(i)
+cd iden='CA'
+cd if (ii.gt.nres) then
+cd iden='SC'
+cd ii=ii-nres
+cd jj=jj-nres
+cd endif
+cd write (iout,'(a,1x,a,i4,3x,a,1x,a,i4,2f10.3)')
+cd & restyp(itype(ii)),iden,ii,restyp(itype(jj)),iden,jj,
+cd & dhpb(i),forcon(i)
+cd enddo
+ return
+ end
+c----------------------------------------------------------------------------
+ subroutine map_read
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.MAP'
+ include 'COMMON.IOUNITS'
+ character*3 angid(4) /'THE','PHI','ALP','OME'/
+ character*80 mapcard,ucase
+ do imap=1,nmap
+ read (inp,'(a)') mapcard
+ mapcard=ucase(mapcard)
+ if (index(mapcard,'PHI').gt.0) then
+ kang(imap)=1
+ else if (index(mapcard,'THE').gt.0) then
+ kang(imap)=2
+ else if (index(mapcard,'ALP').gt.0) then
+ kang(imap)=3
+ else if (index(mapcard,'OME').gt.0) then
+ kang(imap)=4
+ else
+ write(iout,'(a)')'Error - illegal variable spec in MAP card.'
+ stop 'Error - illegal variable spec in MAP card.'
+ endif
+ call readi (mapcard,'RES1',res1(imap),0)
+ call readi (mapcard,'RES2',res2(imap),0)
+ if (res1(imap).eq.0) then
+ res1(imap)=res2(imap)
+ else if (res2(imap).eq.0) then
+ res2(imap)=res1(imap)
+ endif
+ if(res1(imap)*res2(imap).eq.0 .or. res1(imap).gt.res2(imap))then
+ write (iout,'(a)')
+ & 'Error - illegal definition of variable group in MAP.'
+ stop 'Error - illegal definition of variable group in MAP.'
+ endif
+ call reada(mapcard,'FROM',ang_from(imap),0.0D0)
+ call reada(mapcard,'TO',ang_to(imap),0.0D0)
+ call readi(mapcard,'NSTEP',nstep(imap),0)
+ if (ang_from(imap).eq.ang_to(imap) .or. nstep(imap).eq.0) then
+ write (iout,'(a)')
+ & 'Illegal boundary and/or step size specification in MAP.'
+ stop 'Illegal boundary and/or step size specification in MAP.'
+ endif
+ enddo ! imap
+ return
+ end
+c----------------------------------------------------------------------------
+csa subroutine csaread
+csa implicit real*8 (a-h,o-z)
+csa include 'DIMENSIONS'
+csa include 'COMMON.IOUNITS'
+csa include 'COMMON.GEO'
+csa include 'COMMON.CSA'
+csa include 'COMMON.BANK'
+csa include 'COMMON.CONTROL'
+csa character*80 ucase
+csa character*620 mcmcard
+csa call card_concat(mcmcard)
+csa
+csa call readi(mcmcard,'NCONF',nconf,50)
+csa call readi(mcmcard,'NADD',nadd,0)
+csa call readi(mcmcard,'JSTART',jstart,1)
+csa call readi(mcmcard,'JEND',jend,1)
+csa call readi(mcmcard,'NSTMAX',nstmax,500000)
+csa call readi(mcmcard,'N0',n0,1)
+csa call readi(mcmcard,'N1',n1,6)
+csa call readi(mcmcard,'N2',n2,4)
+csa call readi(mcmcard,'N3',n3,0)
+csa call readi(mcmcard,'N4',n4,0)
+csa call readi(mcmcard,'N5',n5,0)
+csa call readi(mcmcard,'N6',n6,10)
+csa call readi(mcmcard,'N7',n7,0)
+csa call readi(mcmcard,'N8',n8,0)
+csa call readi(mcmcard,'N9',n9,0)
+csa call readi(mcmcard,'N14',n14,0)
+csa call readi(mcmcard,'N15',n15,0)
+csa call readi(mcmcard,'N16',n16,0)
+csa call readi(mcmcard,'N17',n17,0)
+csa call readi(mcmcard,'N18',n18,0)
+csa
+csa vdisulf=(index(mcmcard,'DYNSS').gt.0)
+csa
+csa call readi(mcmcard,'NDIFF',ndiff,2)
+csa call reada(mcmcard,'DIFFCUT',diffcut,0.0d0)
+csa call readi(mcmcard,'IS1',is1,1)
+csa call readi(mcmcard,'IS2',is2,8)
+csa call readi(mcmcard,'NRAN0',nran0,4)
+csa call readi(mcmcard,'NRAN1',nran1,2)
+csa call readi(mcmcard,'IRR',irr,1)
+csa call readi(mcmcard,'NSEED',nseed,20)
+csa call readi(mcmcard,'NTOTAL',ntotal,10000)
+csa call reada(mcmcard,'CUT1',cut1,2.0d0)
+csa call reada(mcmcard,'CUT2',cut2,5.0d0)
+csa call reada(mcmcard,'ESTOP',estop,-3000.0d0)
+csa call readi(mcmcard,'ICMAX',icmax,3)
+csa call readi(mcmcard,'IRESTART',irestart,0)
+csac!bankt call readi(mcmcard,'NBANKTM',ntbankm,0)
+csa ntbankm=0
+csac!bankt
+csa call reada(mcmcard,'DELE',dele,20.0d0)
+csa call reada(mcmcard,'DIFCUT',difcut,720.0d0)
+csa call readi(mcmcard,'IREF',iref,0)
+csa call reada(mcmcard,'RMSCUT',rmscut,4.0d0)
+csa call reada(mcmcard,'PNCCUT',pnccut,0.5d0)
+csa call readi(mcmcard,'NCONF_IN',nconf_in,0)
+csa call reada(mcmcard,'RDIH_BIAS',rdih_bias,0.5d0)
+csa write (iout,*) "NCONF_IN",nconf_in
+csa return
+csa end
+c----------------------------------------------------------------------------
+cfmc subroutine mcmfread
+cfmc implicit real*8 (a-h,o-z)
+cfmc include 'DIMENSIONS'
+cfmc include 'COMMON.MCMF'
+cfmc include 'COMMON.IOUNITS'
+cfmc include 'COMMON.GEO'
+cfmc character*80 ucase
+cfmc character*620 mcmcard
+cfmc call card_concat(mcmcard)
+cfmc
+cfmc call readi(mcmcard,'MAXRANT',maxrant,1000)
+cfmc write(iout,*)'MAXRANT=',maxrant
+cfmc call readi(mcmcard,'MAXFAM',maxfam,maxfam_p)
+cfmc write(iout,*)'MAXFAM=',maxfam
+cfmc call readi(mcmcard,'NNET1',nnet1,5)
+cfmc write(iout,*)'NNET1=',nnet1
+cfmc call readi(mcmcard,'NNET2',nnet2,4)
+cfmc write(iout,*)'NNET2=',nnet2
+cfmc call readi(mcmcard,'NNET3',nnet3,4)
+cfmc write(iout,*)'NNET3=',nnet3
+cfmc call readi(mcmcard,'ILASTT',ilastt,0)
+cfmc write(iout,*)'ILASTT=',ilastt
+cfmc call readi(mcmcard,'MAXSTR',maxstr,maxstr_mcmf)
+cfmc write(iout,*)'MAXSTR=',maxstr
+cfmc maxstr_f=maxstr/maxfam
+cfmc write(iout,*)'MAXSTR_F=',maxstr_f
+cfmc call readi(mcmcard,'NMCMF',nmcmf,10)
+cfmc write(iout,*)'NMCMF=',nmcmf
+cfmc call readi(mcmcard,'IFOCUS',ifocus,nmcmf)
+cfmc write(iout,*)'IFOCUS=',ifocus
+cfmc call readi(mcmcard,'NLOCMCMF',nlocmcmf,1000)
+cfmc write(iout,*)'NLOCMCMF=',nlocmcmf
+cfmc call readi(mcmcard,'INTPRT',intprt,1000)
+cfmc write(iout,*)'INTPRT=',intprt
+cfmc call readi(mcmcard,'IPRT',iprt,100)
+cfmc write(iout,*)'IPRT=',iprt
+cfmc call readi(mcmcard,'IMAXTR',imaxtr,100)
+cfmc write(iout,*)'IMAXTR=',imaxtr
+cfmc call readi(mcmcard,'MAXEVEN',maxeven,1000)
+cfmc write(iout,*)'MAXEVEN=',maxeven
+cfmc call readi(mcmcard,'MAXEVEN1',maxeven1,3)
+cfmc write(iout,*)'MAXEVEN1=',maxeven1
+cfmc call readi(mcmcard,'INIMIN',inimin,200)
+cfmc write(iout,*)'INIMIN=',inimin
+cfmc call readi(mcmcard,'NSTEPMCMF',nstepmcmf,10)
+cfmc write(iout,*)'NSTEPMCMF=',nstepmcmf
+cfmc call readi(mcmcard,'NTHREAD',nthread,5)
+cfmc write(iout,*)'NTHREAD=',nthread
+cfmc call readi(mcmcard,'MAXSTEPMCMF',maxstepmcmf,2500)
+cfmc write(iout,*)'MAXSTEPMCMF=',maxstepmcmf
+cfmc call readi(mcmcard,'MAXPERT',maxpert,9)
+cfmc write(iout,*)'MAXPERT=',maxpert
+cfmc call readi(mcmcard,'IRMSD',irmsd,1)
+cfmc write(iout,*)'IRMSD=',irmsd
+cfmc call reada(mcmcard,'DENEMIN',denemin,0.01D0)
+cfmc write(iout,*)'DENEMIN=',denemin
+cfmc call reada(mcmcard,'RCUT1S',rcut1s,3.5D0)
+cfmc write(iout,*)'RCUT1S=',rcut1s
+cfmc call reada(mcmcard,'RCUT1E',rcut1e,2.0D0)
+cfmc write(iout,*)'RCUT1E=',rcut1e
+cfmc call reada(mcmcard,'RCUT2S',rcut2s,0.5D0)
+cfmc write(iout,*)'RCUT2S=',rcut2s
+cfmc call reada(mcmcard,'RCUT2E',rcut2e,0.1D0)
+cfmc write(iout,*)'RCUT2E=',rcut2e
+cfmc call reada(mcmcard,'DPERT1',d_pert1,180.0D0)
+cfmc write(iout,*)'DPERT1=',d_pert1
+cfmc call reada(mcmcard,'DPERT1A',d_pert1a,180.0D0)
+cfmc write(iout,*)'DPERT1A=',d_pert1a
+cfmc call reada(mcmcard,'DPERT2',d_pert2,90.0D0)
+cfmc write(iout,*)'DPERT2=',d_pert2
+cfmc call reada(mcmcard,'DPERT2A',d_pert2a,45.0D0)
+cfmc write(iout,*)'DPERT2A=',d_pert2a
+cfmc call reada(mcmcard,'DPERT2B',d_pert2b,90.0D0)
+cfmc write(iout,*)'DPERT2B=',d_pert2b
+cfmc call reada(mcmcard,'DPERT2C',d_pert2c,60.0D0)
+cfmc write(iout,*)'DPERT2C=',d_pert2c
+cfmc d_pert1=deg2rad*d_pert1
+cfmc d_pert1a=deg2rad*d_pert1a
+cfmc d_pert2=deg2rad*d_pert2
+cfmc d_pert2a=deg2rad*d_pert2a
+cfmc d_pert2b=deg2rad*d_pert2b
+cfmc d_pert2c=deg2rad*d_pert2c
+cfmc call reada(mcmcard,'KT_MCMF1',kt_mcmf1,1.0D0)
+cfmc write(iout,*)'KT_MCMF1=',kt_mcmf1
+cfmc call reada(mcmcard,'KT_MCMF2',kt_mcmf2,1.0D0)
+cfmc write(iout,*)'KT_MCMF2=',kt_mcmf2
+cfmc call reada(mcmcard,'DKT_MCMF1',dkt_mcmf1,10.0D0)
+cfmc write(iout,*)'DKT_MCMF1=',dkt_mcmf1
+cfmc call reada(mcmcard,'DKT_MCMF2',dkt_mcmf2,1.0D0)
+cfmc write(iout,*)'DKT_MCMF2=',dkt_mcmf2
+cfmc call reada(mcmcard,'RCUTINI',rcutini,3.5D0)
+cfmc write(iout,*)'RCUTINI=',rcutini
+cfmc call reada(mcmcard,'GRAT',grat,0.5D0)
+cfmc write(iout,*)'GRAT=',grat
+cfmc call reada(mcmcard,'BIAS_MCMF',bias_mcmf,0.0D0)
+cfmc write(iout,*)'BIAS_MCMF=',bias_mcmf
+cfmc
+cfmc return
+cfmc end
+c----------------------------------------------------------------------------
+ subroutine mcmread
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.MCM'
+ include 'COMMON.MCE'
+ include 'COMMON.IOUNITS'
+ character*80 ucase
+ character*320 mcmcard
+ call card_concat(mcmcard)
+ call readi(mcmcard,'MAXACC',maxacc,100)
+ call readi(mcmcard,'MAX_MCM_IT',max_mcm_it,10000)
+ call readi(mcmcard,'MAXTRIAL',maxtrial,100)
+ call readi(mcmcard,'MAXTRIAL_ITER',maxtrial_iter,1000)
+ call readi(mcmcard,'MAXREPM',maxrepm,200)
+ call reada(mcmcard,'RANFRACT',RanFract,0.5D0)
+ call reada(mcmcard,'POOL_FRACT',pool_fraction,0.01D0)
+ call reada(mcmcard,'OVERLAP',overlap_cut,1.0D3)
+ call reada(mcmcard,'E_UP',e_up,5.0D0)
+ call reada(mcmcard,'DELTE',delte,0.1D0)
+ call readi(mcmcard,'NSWEEP',nsweep,5)
+ call readi(mcmcard,'NSTEPH',nsteph,0)
+ call readi(mcmcard,'NSTEPC',nstepc,0)
+ call reada(mcmcard,'TMIN',tmin,298.0D0)
+ call reada(mcmcard,'TMAX',tmax,298.0D0)
+ call readi(mcmcard,'NWINDOW',nwindow,0)
+ call readi(mcmcard,'PRINT_MC',print_mc,0)
+ print_stat=(index(mcmcard,'NO_PRINT_STAT').le.0)
+ print_int=(index(mcmcard,'NO_PRINT_INT').le.0)
+ ent_read=(index(mcmcard,'ENT_READ').gt.0)
+ call readi(mcmcard,'SAVE_FREQ',save_frequency,1000)
+ call readi(mcmcard,'MESSAGE_FREQ',message_frequency,1000)
+ call readi(mcmcard,'POOL_READ_FREQ',pool_read_freq,5000)
+ call readi(mcmcard,'POOL_SAVE_FREQ',pool_save_freq,1000)
+ call readi(mcmcard,'PRINT_FREQ',print_freq,1000)
+ if (nwindow.gt.0) then
+ read (inp,*) (winstart(i),winend(i),i=1,nwindow)
+ do i=1,nwindow
+ winlen(i)=winend(i)-winstart(i)+1
+ enddo
+ endif
+ if (tmax.lt.tmin) tmax=tmin
+ if (tmax.eq.tmin) then
+ nstepc=0
+ nsteph=0
+ endif
+ if (nstepc.gt.0 .and. nsteph.gt.0) then
+ tsteph=(tmax/tmin)**(1.0D0/(nsteph+0.0D0))
+ tstepc=(tmax/tmin)**(1.0D0/(nstepc+0.0D0))
+ endif
+C Probabilities of different move types
+ sumpro_type(0)=0.0D0
+ call reada(mcmcard,'MULTI_BOND',sumpro_type(1),1.0d0)
+ call reada(mcmcard,'ONE_ANGLE' ,sumpro_type(2),2.0d0)
+ sumpro_type(2)=sumpro_type(1)+sumpro_type(2)
+ call reada(mcmcard,'THETA' ,sumpro_type(3),0.0d0)
+ sumpro_type(3)=sumpro_type(2)+sumpro_type(3)
+ call reada(mcmcard,'SIDE_CHAIN',sumpro_type(4),0.5d0)
+ sumpro_type(4)=sumpro_type(3)+sumpro_type(4)
+ do i=1,MaxMoveType
+ print *,'i',i,' sumprotype',sumpro_type(i)
+ sumpro_type(i)=sumpro_type(i)/sumpro_type(MaxMoveType)
+ print *,'i',i,' sumprotype',sumpro_type(i)
+ enddo
+ return
+ end
+c----------------------------------------------------------------------------
+ subroutine read_minim
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.MINIM'
+ include 'COMMON.IOUNITS'
+ character*80 ucase
+ character*320 minimcard
+ call card_concat(minimcard)
+ call readi(minimcard,'MAXMIN',maxmin,2000)
+ call readi(minimcard,'MAXFUN',maxfun,5000)
+ call readi(minimcard,'MINMIN',minmin,maxmin)
+ call readi(minimcard,'MINFUN',minfun,maxmin)
+ call reada(minimcard,'TOLF',tolf,1.0D-2)
+ call reada(minimcard,'RTOLF',rtolf,1.0D-4)
+ print_min_stat=min0(index(minimcard,'PRINT_MIN_STAT'),1)
+ print_min_res=min0(index(minimcard,'PRINT_MIN_RES'),1)
+ print_min_ini=min0(index(minimcard,'PRINT_MIN_INI'),1)
+ write (iout,'(/80(1h*)/20x,a/80(1h*))')
+ & 'Options in energy minimization:'
+ write (iout,'(4(a,i5),a,1pe14.5,a,1pe14.5)')
+ & 'MaxMin:',MaxMin,' MaxFun:',MaxFun,
+ & 'MinMin:',MinMin,' MinFun:',MinFun,
+ & ' TolF:',TolF,' RTolF:',RTolF
+ return
+ end
+c----------------------------------------------------------------------------
+ subroutine read_angles(kanal,*)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.CHAIN'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CONTROL'
+c Read angles from input
+c
+ 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
+c 9/7/01 avoid 180 deg valence angle
+ if (theta(i).gt.179.99d0) theta(i)=179.99d0
+c
+ 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:),*,err=10,end=10) wartosc
+ return
+ 10 wartosc=default
+ 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:),*,err=10,end=10) wartosc
+ return
+ 10 wartosc=default
+ return
+ end
+c----------------------------------------------------------------------------
+ subroutine multreadi(rekord,lancuch,tablica,dim,default)
+ implicit none
+ integer dim,i
+ integer tablica(dim),default
+ character*(*) rekord,lancuch
+ character*80 aux
+ integer ilen,iread
+ external ilen
+ do i=1,dim
+ tablica(i)=default
+ enddo
+ iread=index(rekord,lancuch(:ilen(lancuch))//"=")
+ if (iread.eq.0) return
+ iread=iread+ilen(lancuch)+1
+ read (rekord(iread:),*,end=10,err=10) (tablica(i),i=1,dim)
+ 10 return
+ end
+c----------------------------------------------------------------------------
+ subroutine multreada(rekord,lancuch,tablica,dim,default)
+ implicit none
+ integer dim,i
+ double precision tablica(dim),default
+ character*(*) rekord,lancuch
+ character*80 aux
+ integer ilen,iread
+ external ilen
+ do i=1,dim
+ tablica(i)=default
+ enddo
+ iread=index(rekord,lancuch(:ilen(lancuch))//"=")
+ if (iread.eq.0) return
+ iread=iread+ilen(lancuch)+1
+ read (rekord(iread:),*,end=10,err=10) (tablica(i),i=1,dim)
+ 10 return
+ end
+c----------------------------------------------------------------------------
+ subroutine openunits
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+ character*16 form,nodename
+ integer nodelen
+#endif
+ include 'COMMON.SETUP'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.MD'
+ include 'COMMON.CONTROL'
+ integer lenpre,lenpot,ilen,lentmp
+ external ilen
+ character*3 out1file_text,ucase
+ character*3 ll
+ external ucase
+c print *,"Processor",myrank,"fg_rank",fg_rank," entered openunits"
+ call getenv_loc("PREFIX",prefix)
+ pref_orig = prefix
+ call getenv_loc("POT",pot)
+ call getenv_loc("DIRTMP",tmpdir)
+ call getenv_loc("CURDIR",curdir)
+ call getenv_loc("OUT1FILE",out1file_text)
+c print *,"Processor",myrank,"fg_rank",fg_rank," did GETENV"
+ out1file_text=ucase(out1file_text)
+ if (out1file_text(1:1).eq."Y") then
+ out1file=.true.
+ else
+ out1file=fg_rank.gt.0
+ endif
+ lenpre=ilen(prefix)
+ lenpot=ilen(pot)
+ lentmp=ilen(tmpdir)
+ if (lentmp.gt.0) then
+ write (*,'(80(1h!))')
+ write (*,'(a,19x,a,19x,a)') "!"," A T T E N T I O N ","!"
+ write (*,'(80(1h!))')
+ write (*,*)"All output files will be on node /tmp directory."
+#ifdef MPI
+ call MPI_GET_PROCESSOR_NAME( nodename, nodelen, IERROR )
+ if (me.eq.king) then
+ write (*,*) "The master node is ",nodename
+ else if (fg_rank.eq.0) then
+ write (*,*) "I am the CG slave node ",nodename
+ else
+ write (*,*) "I am the FG slave node ",nodename
+ endif
+#endif
+ PREFIX = tmpdir(:lentmp)//'/'//prefix(:lenpre)
+ lenpre = lentmp+lenpre+1
+ endif
+ entname=prefix(:lenpre)//'_'//pot(:lenpot)//'.entr'
+C Get the names and open the input files
+#if defined(WINIFL) || defined(WINPGI)
+ open(1,file=pref_orig(:ilen(pref_orig))//
+ & '.inp',status='old',readonly,shared)
+ open (9,file=prefix(:ilen(prefix))//'.intin',status='unknown')
+C open (18,file=prefix(:ilen(prefix))//'.entin',status='unknown')
+C Get parameter filenames and open the parameter files.
+ call getenv_loc('BONDPAR',bondname)
+ open (ibond,file=bondname,status='old',readonly,shared)
+ call getenv_loc('THETPAR',thetname)
+ open (ithep,file=thetname,status='old',readonly,shared)
+#ifndef CRYST_THETA
+ call getenv_loc('THETPARPDB',thetname_pdb)
+ open (ithep_pdb,file=thetname_pdb,status='old',readonly,shared)
+#endif
+ call getenv_loc('ROTPAR',rotname)
+ open (irotam,file=rotname,status='old',readonly,shared)
+#ifndef CRYST_SC
+ call getenv_loc('ROTPARPDB',rotname_pdb)
+ open (irotam_pdb,file=rotname_pdb,status='old',readonly,shared)
+#endif
+ call getenv_loc('TORPAR',torname)
+ open (itorp,file=torname,status='old',readonly,shared)
+ call getenv_loc('TORDPAR',tordname)
+ open (itordp,file=tordname,status='old',readonly,shared)
+ call getenv_loc('FOURIER',fouriername)
+ open (ifourier,file=fouriername,status='old',readonly,shared)
+ call getenv_loc('ELEPAR',elename)
+ open (ielep,file=elename,status='old',readonly,shared)
+ call getenv_loc('SIDEPAR',sidename)
+ open (isidep,file=sidename,status='old',readonly,shared)
+#elif (defined CRAY) || (defined AIX)
+ open(1,file=pref_orig(:ilen(pref_orig))//'.inp',status='old',
+ & action='read')
+c print *,"Processor",myrank," opened file 1"
+ open (9,file=prefix(:ilen(prefix))//'.intin',status='unknown')
+c print *,"Processor",myrank," opened file 9"
+C open (18,file=prefix(:ilen(prefix))//'.entin',status='unknown')
+C Get parameter filenames and open the parameter files.
+ call getenv_loc('BONDPAR',bondname)
+ open (ibond,file=bondname,status='old',action='read')
+c print *,"Processor",myrank," opened file IBOND"
+ call getenv_loc('THETPAR',thetname)
+ open (ithep,file=thetname,status='old',action='read')
+c print *,"Processor",myrank," opened file ITHEP"
+#ifndef CRYST_THETA
+ call getenv_loc('THETPARPDB',thetname_pdb)
+ open (ithep_pdb,file=thetname_pdb,status='old',action='read')
+#endif
+ call getenv_loc('ROTPAR',rotname)
+ open (irotam,file=rotname,status='old',action='read')
+c print *,"Processor",myrank," opened file IROTAM"
+#ifndef CRYST_SC
+ call getenv_loc('ROTPARPDB',rotname_pdb)
+ open (irotam_pdb,file=rotname_pdb,status='old',action='read')
+#endif
+ call getenv_loc('TORPAR',torname)
+ open (itorp,file=torname,status='old',action='read')
+c print *,"Processor",myrank," opened file ITORP"
+ call getenv_loc('TORDPAR',tordname)
+ open (itordp,file=tordname,status='old',action='read')
+c print *,"Processor",myrank," opened file ITORDP"
+ call getenv_loc('SCCORPAR',sccorname)
+ open (isccor,file=sccorname,status='old',action='read')
+c print *,"Processor",myrank," opened file ISCCOR"
+ call getenv_loc('FOURIER',fouriername)
+ open (ifourier,file=fouriername,status='old',action='read')
+c print *,"Processor",myrank," opened file IFOURIER"
+ call getenv_loc('ELEPAR',elename)
+ open (ielep,file=elename,status='old',action='read')
+c print *,"Processor",myrank," opened file IELEP"
+ call getenv_loc('SIDEPAR',sidename)
+ open (isidep,file=sidename,status='old',action='read')
+c print *,"Processor",myrank," opened file ISIDEP"
+c print *,"Processor",myrank," opened parameter files"
+#elif (defined G77)
+ open(1,file=pref_orig(:ilen(pref_orig))//'.inp',status='old')
+ open (9,file=prefix(:ilen(prefix))//'.intin',status='unknown')
+C open (18,file=prefix(:ilen(prefix))//'.entin',status='unknown')
+C Get parameter filenames and open the parameter files.
+ call getenv_loc('BONDPAR',bondname)
+ open (ibond,file=bondname,status='old')
+ call getenv_loc('THETPAR',thetname)
+ open (ithep,file=thetname,status='old')
+#ifndef CRYST_THETA
+ call getenv_loc('THETPARPDB',thetname_pdb)
+ open (ithep_pdb,file=thetname_pdb,status='old')
+#endif
+ call getenv_loc('ROTPAR',rotname)
+ open (irotam,file=rotname,status='old')
+#ifndef CRYST_SC
+ call getenv_loc('ROTPARPDB',rotname_pdb)
+ open (irotam_pdb,file=rotname_pdb,status='old')
+#endif
+ call getenv_loc('TORPAR',torname)
+ open (itorp,file=torname,status='old')
+ call getenv_loc('TORDPAR',tordname)
+ open (itordp,file=tordname,status='old')
+ call getenv_loc('SCCORPAR',sccorname)
+ open (isccor,file=sccorname,status='old')
+ call getenv_loc('FOURIER',fouriername)
+ open (ifourier,file=fouriername,status='old')
+ call getenv_loc('ELEPAR',elename)
+ open (ielep,file=elename,status='old')
+ call getenv_loc('SIDEPAR',sidename)
+ open (isidep,file=sidename,status='old')
+#else
+ open(1,file=pref_orig(:ilen(pref_orig))//'.inp',status='old',
+ &action='read')
+ open (9,file=prefix(:ilen(prefix))//'.intin',status='unknown')
+C open (18,file=prefix(:ilen(prefix))//'.entin',status='unknown')
+C Get parameter filenames and open the parameter files.
+ call getenv_loc('BONDPAR',bondname)
+ open (ibond,file=bondname,status='old',action='read')
+ call getenv_loc('THETPAR',thetname)
+ open (ithep,file=thetname,status='old',action='read')
+#ifndef CRYST_THETA
+ call getenv_loc('THETPARPDB',thetname_pdb)
+ print *,"thetname_pdb ",thetname_pdb
+ open (ithep_pdb,file=thetname_pdb,status='old',action='read')
+ print *,ithep_pdb," opened"
+#endif
+ call getenv_loc('ROTPAR',rotname)
+ open (irotam,file=rotname,status='old',action='read')
+#ifndef CRYST_SC
+ call getenv_loc('ROTPARPDB',rotname_pdb)
+ open (irotam_pdb,file=rotname_pdb,status='old',action='read')
+#endif
+ call getenv_loc('TORPAR',torname)
+ open (itorp,file=torname,status='old',action='read')
+ call getenv_loc('TORDPAR',tordname)
+ open (itordp,file=tordname,status='old',action='read')
+ call getenv_loc('SCCORPAR',sccorname)
+ open (isccor,file=sccorname,status='old',action='read')
+ call getenv_loc('FOURIER',fouriername)
+ open (ifourier,file=fouriername,status='old',action='read')
+ call getenv_loc('ELEPAR',elename)
+ open (ielep,file=elename,status='old',action='read')
+ call getenv_loc('SIDEPAR',sidename)
+ open (isidep,file=sidename,status='old',action='read')
+#endif
+#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_loc('SCPPAR',scpname)
+#if defined(WINIFL) || defined(WINPGI)
+ open (iscpp,file=scpname,status='old',readonly,shared)
+#elif (defined CRAY) || (defined AIX)
+ open (iscpp,file=scpname,status='old',action='read')
+#elif (defined G77)
+ open (iscpp,file=scpname,status='old')
+#else
+ open (iscpp,file=scpname,status='old',action='read')
+#endif
+#endif
+ call getenv_loc('PATTERN',patname)
+#if defined(WINIFL) || defined(WINPGI)
+ open (icbase,file=patname,status='old',readonly,shared)
+#elif (defined CRAY) || (defined AIX)
+ open (icbase,file=patname,status='old',action='read')
+#elif (defined G77)
+ open (icbase,file=patname,status='old')
+#else
+ open (icbase,file=patname,status='old',action='read')
+#endif
+#ifdef MPI
+C Open output file only for CG processes
+c print *,"Processor",myrank," fg_rank",fg_rank
+ if (fg_rank.eq.0) then
+
+ if (nodes.eq.1) then
+ npos=3
+ else
+ npos = dlog10(dfloat(nodes-1))+1
+ endif
+ if (npos.lt.3) npos=3
+ write (liczba,'(i1)') npos
+ form = '(bz,i'//liczba(:ilen(liczba))//'.'//liczba(:ilen(liczba))
+ & //')'
+ write (liczba,form) me
+ outname=prefix(:lenpre)//'.out_'//pot(:lenpot)//
+ & liczba(:ilen(liczba))
+ intname=prefix(:lenpre)//'_'//pot(:lenpot)//liczba(:ilen(liczba))
+ & //'.int'
+ pdbname=prefix(:lenpre)//'_'//pot(:lenpot)//liczba(:ilen(liczba))
+ & //'.pdb'
+ mol2name=prefix(:lenpre)//'_'//pot(:lenpot)//
+ & liczba(:ilen(liczba))//'.mol2'
+ statname=prefix(:lenpre)//'_'//pot(:lenpot)//
+ & liczba(:ilen(liczba))//'.stat'
+ if (lentmp.gt.0)
+ & call copy_to_tmp(pref_orig(:ilen(pref_orig))//'_'//pot(:lenpot)
+ & //liczba(:ilen(liczba))//'.stat')
+ rest2name=prefix(:ilen(prefix))//"_"//liczba(:ilen(liczba))
+ & //'.rst'
+ if(usampl) then
+ qname=prefix(:lenpre)//'_'//pot(:lenpot)//
+ & liczba(:ilen(liczba))//'.const'
+ endif
+
+ endif
+#else
+ outname=prefix(:lenpre)//'.out_'//pot(:lenpot)
+ intname=prefix(:lenpre)//'_'//pot(:lenpot)//'.int'
+ pdbname=prefix(:lenpre)//'_'//pot(:lenpot)//'.pdb'
+ mol2name=prefix(:lenpre)//'_'//pot(:lenpot)//'.mol2'
+ statname=prefix(:lenpre)//'_'//pot(:lenpot)//'.stat'
+ if (lentmp.gt.0)
+ & call copy_to_tmp(pref_orig(:ilen(pref_orig))//'_'//pot(:lenpot)
+ & //'.stat')
+ rest2name=prefix(:ilen(prefix))//'.rst'
+ if(usampl) then
+ qname=prefix(:lenpre)//'_'//pot(:lenpot)//'.const'
+ endif
+#endif
+#if defined(AIX) || defined(PGI)
+ if (me.eq.king .or. .not. out1file)
+ & open(iout,file=outname,status='unknown')
+c#define DEBUG
+#ifdef DEBUG
+ if (fg_rank.gt.0) then
+ write (liczba,'(i3.3)') myrank/nfgtasks
+ write (ll,'(bz,i3.3)') fg_rank
+ open(iout,file="debug"//liczba(:ilen(liczba))//"."//ll,
+ & status='unknown')
+ endif
+#endif
+c#undef DEBUG
+ if(me.eq.king) then
+ open(igeom,file=intname,status='unknown',position='append')
+ open(ipdb,file=pdbname,status='unknown')
+ open(imol2,file=mol2name,status='unknown')
+ open(istat,file=statname,status='unknown',position='append')
+ else
+c1out open(iout,file=outname,status='unknown')
+ endif
+#else
+ if (me.eq.king .or. .not.out1file)
+ & open(iout,file=outname,status='unknown')
+c#define DEBUG
+#ifdef DEBUG
+ if (fg_rank.gt.0) then
+ print "Processor",fg_rank," opening output file"
+ write (liczba,'(i3.3)') myrank/nfgtasks
+ write (ll,'(bz,i3.3)') fg_rank
+ open(iout,file="debug"//liczba(:ilen(liczba))//"."//ll,
+ & status='unknown')
+ endif
+#endif
+c#undef DEBUG
+ if(me.eq.king) then
+ open(igeom,file=intname,status='unknown',access='append')
+ open(ipdb,file=pdbname,status='unknown')
+ open(imol2,file=mol2name,status='unknown')
+ open(istat,file=statname,status='unknown',access='append')
+ else
+c1out open(iout,file=outname,status='unknown')
+ endif
+#endif
+csa csa_rbank=prefix(:lenpre)//'.CSA.rbank'
+csa csa_seed=prefix(:lenpre)//'.CSA.seed'
+csa csa_history=prefix(:lenpre)//'.CSA.history'
+csa csa_bank=prefix(:lenpre)//'.CSA.bank'
+csa csa_bank1=prefix(:lenpre)//'.CSA.bank1'
+csa csa_alpha=prefix(:lenpre)//'.CSA.alpha'
+csa csa_alpha1=prefix(:lenpre)//'.CSA.alpha1'
+csac!bankt csa_bankt=prefix(:lenpre)//'.CSA.bankt'
+csa csa_int=prefix(:lenpre)//'.int'
+csa csa_bank_reminimized=prefix(:lenpre)//'.CSA.bank_reminimized'
+csa csa_native_int=prefix(:lenpre)//'.CSA.native.int'
+csa csa_in=prefix(:lenpre)//'.CSA.in'
+c print *,"Processor",myrank,"fg_rank",fg_rank," opened files"
+C Write file names
+ if (me.eq.king)then
+ write (iout,'(80(1h-))')
+ write (iout,'(30x,a)') "FILE ASSIGNMENT"
+ write (iout,'(80(1h-))')
+ write (iout,*) "Input file : ",
+ & pref_orig(:ilen(pref_orig))//'.inp'
+ write (iout,*) "Output file : ",
+ & outname(:ilen(outname))
+ write (iout,*)
+ write (iout,*) "Sidechain potential file : ",
+ & sidename(:ilen(sidename))
+#ifndef OLDSCP
+ write (iout,*) "SCp potential file : ",
+ & scpname(:ilen(scpname))
+#endif
+ write (iout,*) "Electrostatic potential file : ",
+ & elename(:ilen(elename))
+ write (iout,*) "Cumulant coefficient file : ",
+ & fouriername(:ilen(fouriername))
+ write (iout,*) "Torsional parameter file : ",
+ & torname(:ilen(torname))
+ write (iout,*) "Double torsional parameter file : ",
+ & tordname(:ilen(tordname))
+ write (iout,*) "SCCOR parameter file : ",
+ & sccorname(:ilen(sccorname))
+ write (iout,*) "Bond & inertia constant file : ",
+ & bondname(:ilen(bondname))
+ write (iout,*) "Bending parameter file : ",
+ & thetname(:ilen(thetname))
+ write (iout,*) "Rotamer parameter file : ",
+ & rotname(:ilen(rotname))
+ write (iout,*) "Threading database : ",
+ & patname(:ilen(patname))
+ if (lentmp.ne.0)
+ &write (iout,*)" DIRTMP : ",
+ & tmpdir(:lentmp)
+ write (iout,'(80(1h-))')
+ endif
+ return
+ end
+c----------------------------------------------------------------------------
+ subroutine card_concat(card)
+ implicit real*8 (a-h,o-z)
+ 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 readrst
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.MD'
+ open(irest2,file=rest2name,status='unknown')
+ read(irest2,*) totT,EK,potE,totE,t_bath
+ do i=1,2*nres
+ read(irest2,'(3e15.5)') (d_t(j,i),j=1,3)
+ enddo
+ do i=1,2*nres
+ read(irest2,'(3e15.5)') (dc(j,i),j=1,3)
+ enddo
+ if(usampl) then
+ read (irest2,*) iset
+ endif
+ close(irest2)
+ return
+ end
+c---------------------------------------------------------------------------------
+ subroutine read_fragments
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.SETUP'
+ include 'COMMON.CHAIN'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.MD'
+ include 'COMMON.CONTROL'
+ read(inp,*) nset,nfrag,npair,nfrag_back
+ if(me.eq.king.or..not.out1file)
+ & write(iout,*) "nset",nset," nfrag",nfrag," npair",npair,
+ & " nfrag_back",nfrag_back
+ do iset=1,nset
+ read(inp,*) mset(iset)
+ do i=1,nfrag
+ read(inp,*) wfrag(i,iset),ifrag(1,i,iset),ifrag(2,i,iset),
+ & qinfrag(i,iset)
+ if(me.eq.king.or..not.out1file)
+ & write(iout,*) "R ",i,wfrag(i,iset),ifrag(1,i,iset),
+ & ifrag(2,i,iset), qinfrag(i,iset)
+ enddo
+ do i=1,npair
+ read(inp,*) wpair(i,iset),ipair(1,i,iset),ipair(2,i,iset),
+ & qinpair(i,iset)
+ if(me.eq.king.or..not.out1file)
+ & write(iout,*) "R ",i,wpair(i,iset),ipair(1,i,iset),
+ & ipair(2,i,iset), qinpair(i,iset)
+ enddo
+ do i=1,nfrag_back
+ read(inp,*) wfrag_back(1,i,iset),wfrag_back(2,i,iset),
+ & wfrag_back(3,i,iset),
+ & ifrag_back(1,i,iset),ifrag_back(2,i,iset)
+ if(me.eq.king.or..not.out1file)
+ & write(iout,*) "A",i,wfrag_back(1,i,iset),wfrag_back(2,i,iset),
+ & wfrag_back(3,i,iset),ifrag_back(1,i,iset),ifrag_back(2,i,iset)
+ enddo
+ enddo
+ return
+ end
+c-------------------------------------------------------------------------------
+ subroutine read_dist_constr
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.SETUP'
+ include 'COMMON.CONTROL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.SBRIDGE'
+ integer ifrag_(2,100),ipair_(2,100)
+ double precision wfrag_(100),wpair_(100)
+ character*500 controlcard
+c write (iout,*) "Calling read_dist_constr"
+c write (iout,*) "nres",nres," nstart_sup",nstart_sup," nsup",nsup
+c call flush(iout)
+ call card_concat(controlcard)
+ call readi(controlcard,"NFRAG",nfrag_,0)
+ call readi(controlcard,"NPAIR",npair_,0)
+ call readi(controlcard,"NDIST",ndist_,0)
+ call reada(controlcard,'DIST_CUT',dist_cut,5.0d0)
+ call multreadi(controlcard,"IFRAG",ifrag_(1,1),2*nfrag_,0)
+ call multreadi(controlcard,"IPAIR",ipair_(1,1),2*npair_,0)
+ call multreada(controlcard,"WFRAG",wfrag_(1),nfrag_,0.0d0)
+ call multreada(controlcard,"WPAIR",wpair_(1),npair_,0.0d0)
+c write (iout,*) "NFRAG",nfrag_," NPAIR",npair_," NDIST",ndist_
+c write (iout,*) "IFRAG"
+c do i=1,nfrag_
+c write (iout,*) i,ifrag_(1,i),ifrag_(2,i),wfrag_(i)
+c enddo
+c write (iout,*) "IPAIR"
+c do i=1,npair_
+c write (iout,*) i,ipair_(1,i),ipair_(2,i),wpair_(i)
+c enddo
+ if (.not.refstr .and. nfrag.gt.0) then
+ write (iout,*)
+ & "ERROR: no reference structure to compute distance restraints"
+ write (iout,*)
+ & "Restraints must be specified explicitly (NDIST=number)"
+ stop
+ endif
+ if (nfrag.lt.2 .and. npair.gt.0) then
+ write (iout,*) "ERROR: Less than 2 fragments specified",
+ & " but distance restraints between pairs requested"
+ stop
+ endif
+ call flush(iout)
+ do i=1,nfrag_
+ if (ifrag_(1,i).lt.nstart_sup) ifrag_(1,i)=nstart_sup
+ if (ifrag_(2,i).gt.nstart_sup+nsup-1)
+ & ifrag_(2,i)=nstart_sup+nsup-1
+c write (iout,*) i,ifrag_(1,i),ifrag_(2,i),wfrag_(i)
+ call flush(iout)
+ if (wfrag_(i).gt.0.0d0) then
+ do j=ifrag_(1,i),ifrag_(2,i)-1
+ do k=j+1,ifrag_(2,i)
+ write (iout,*) "j",j," k",k
+ ddjk=dist(j,k)
+ if (constr_dist.eq.1) then
+ nhpb=nhpb+1
+ ihpb(nhpb)=j
+ jhpb(nhpb)=k
+ dhpb(nhpb)=ddjk
+ forcon(nhpb)=wfrag_(i)
+ else if (constr_dist.eq.2) then
+ if (ddjk.le.dist_cut) then
+ nhpb=nhpb+1
+ ihpb(nhpb)=j
+ jhpb(nhpb)=k
+ dhpb(nhpb)=ddjk
+ forcon(nhpb)=wfrag_(i)
+ endif
+ else
+ nhpb=nhpb+1
+ ihpb(nhpb)=j
+ jhpb(nhpb)=k
+ dhpb(nhpb)=ddjk
+ forcon(nhpb)=wfrag_(i)*dexp(-0.5d0*(ddjk/dist_cut)**2)
+ endif
+#ifdef MPI
+ if (.not.out1file .or. me.eq.king)
+ & write (iout,'(a,3i5,f8.2,1pe12.2)') "+dist.constr ",
+ & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb)
+#else
+ write (iout,'(a,3i5,f8.2,1pe12.2)') "+dist.constr ",
+ & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb)
+#endif
+ enddo
+ enddo
+ endif
+ enddo
+ do i=1,npair_
+ if (wpair_(i).gt.0.0d0) then
+ ii = ipair_(1,i)
+ jj = ipair_(2,i)
+ if (ii.gt.jj) then
+ itemp=ii
+ ii=jj
+ jj=itemp
+ endif
+ do j=ifrag_(1,ii),ifrag_(2,ii)
+ do k=ifrag_(1,jj),ifrag_(2,jj)
+ nhpb=nhpb+1
+ ihpb(nhpb)=j
+ jhpb(nhpb)=k
+ forcon(nhpb)=wpair_(i)
+ dhpb(nhpb)=dist(j,k)
+#ifdef MPI
+ if (.not.out1file .or. me.eq.king)
+ & write (iout,'(a,3i5,f8.2,f10.1)') "+dist.constr ",
+ & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb)
+#else
+ write (iout,'(a,3i5,f8.2,f10.1)') "+dist.constr ",
+ & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb)
+#endif
+ enddo
+ enddo
+ endif
+ enddo
+ do i=1,ndist_
+ read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),dhpb(i),dhpb1(i),
+ & ibecarb(i),forcon(nhpb+1)
+ if (forcon(nhpb+1).gt.0.0d0) then
+ nhpb=nhpb+1
+ if (ibecarb(i).gt.0) then
+ ihpb(i)=ihpb(i)+nres
+ jhpb(i)=jhpb(i)+nres
+ endif
+ if (dhpb(nhpb).eq.0.0d0)
+ & dhpb(nhpb)=dist(ihpb(nhpb),jhpb(nhpb))
+ endif
+ enddo
+#ifdef MPI
+ if (.not.out1file .or. me.eq.king) then
+#endif
+ do i=1,nhpb
+ write (iout,'(a,3i5,2f8.2,i2,f10.1)') "+dist.constr ",
+ & i,ihpb(i),jhpb(i),dhpb(i),dhpb1(i),ibecarb(i),forcon(i)
+ enddo
+ call flush(iout)
+#ifdef MPI
+ endif
+#endif
+ return
+ end
+c-------------------------------------------------------------------------------
+#ifdef WINIFL
+ subroutine flush(iu)
+ return
+ end
+#endif
+#ifdef AIX
+ subroutine flush(iu)
+ call flush_(iu)
+ return
+ end
+#endif
+c------------------------------------------------------------------------------
+ subroutine copy_to_tmp(source)
+ include "DIMENSIONS"
+ include "COMMON.IOUNITS"
+ character*(*) source
+ character* 256 tmpfile
+ integer ilen
+ external ilen
+ logical ex
+ tmpfile=curdir(:ilen(curdir))//"/"//source(:ilen(source))
+ inquire(file=tmpfile,exist=ex)
+ if (ex) then
+ write (*,*) "Copying ",tmpfile(:ilen(tmpfile)),
+ & " to temporary directory..."
+ write (*,*) "/bin/cp "//tmpfile(:ilen(tmpfile))//" "//tmpdir
+ call system("/bin/cp "//tmpfile(:ilen(tmpfile))//" "//tmpdir)
+ endif
+ return
+ end
+c------------------------------------------------------------------------------
+ subroutine move_from_tmp(source)
+ include "DIMENSIONS"
+ include "COMMON.IOUNITS"
+ character*(*) source
+ integer ilen
+ external ilen
+ write (*,*) "Moving ",source(:ilen(source)),
+ & " from temporary directory to working directory"
+ write (*,*) "/bin/mv "//source(:ilen(source))//" "//curdir
+ call system("/bin/mv "//source(:ilen(source))//" "//curdir)
+ return
+ end
+c------------------------------------------------------------------------------
+ subroutine random_init(seed)
+C
+C Initialize random number generator
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef AMD64
+ integer*8 iseedi8
+#endif
+#ifdef MPI
+ include 'mpif.h'
+ logical OKRandom, prng_restart
+ real*8 r1
+ integer iseed_array(4)
+#endif
+ include 'COMMON.IOUNITS'
+ include 'COMMON.TIME1'
+ include 'COMMON.THREAD'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.CONTROL'
+ include 'COMMON.MCM'
+ include 'COMMON.MAP'
+ include 'COMMON.HEADER'
+csa include 'COMMON.CSA'
+ include 'COMMON.CHAIN'
+ include 'COMMON.MUCA'
+ include 'COMMON.MD'
+ include 'COMMON.FFIELD'
+ include 'COMMON.SETUP'
+ iseed=-dint(dabs(seed))
+ if (iseed.eq.0) then
+ write (iout,'(/80(1h*)/20x,a/80(1h*))')
+ & 'Random seed undefined. The program will stop.'
+ write (*,'(/80(1h*)/20x,a/80(1h*))')
+ & 'Random seed undefined. The program will stop.'
+#ifdef MPI
+ call mpi_finalize(mpi_comm_world,ierr)
+#endif
+ stop 'Bad random seed.'
+ endif
+#ifdef MPI
+ if (fg_rank.eq.0) then
+ seed=seed*(me+1)+1
+#ifdef AMD64
+ iseedi8=dint(seed)
+ if(me.eq.king .or. .not. out1file)
+ & write (iout,*) 'MPI: node= ', me, ' iseed= ',iseedi8
+ write (*,*) 'MPI: node= ', me, ' iseed= ',iseedi8
+ OKRandom = prng_restart(me,iseedi8)
+#else
+ do i=1,4
+ tmp=65536.0d0**(4-i)
+ iseed_array(i) = dint(seed/tmp)
+ seed=seed-iseed_array(i)*tmp
+ enddo
+ if(me.eq.king .or. .not. out1file)
+ & write (iout,*) 'MPI: node= ', me, ' iseed(4)= ',
+ & (iseed_array(i),i=1,4)
+ write (*,*) 'MPI: node= ',me, ' iseed(4)= ',
+ & (iseed_array(i),i=1,4)
+ OKRandom = prng_restart(me,iseed_array)
+#endif
+ if (OKRandom) then
+ r1=ran_number(0.0D0,1.0D0)
+ if(me.eq.king .or. .not. out1file)
+ & write (iout,*) 'ran_num',r1
+ if (r1.lt.0.0d0) OKRandom=.false.
+ endif
+ if (.not.OKRandom) then
+ write (iout,*) 'PRNG IS NOT WORKING!!!'
+ print *,'PRNG IS NOT WORKING!!!'
+ if (me.eq.0) then
+ call flush(iout)
+ call mpi_abort(mpi_comm_world,error_msg,ierr)
+ stop
+ else
+ write (iout,*) 'too many processors for parallel prng'
+ write (*,*) 'too many processors for parallel prng'
+ call flush(iout)
+ stop
+ endif
+ endif
+ endif
+#else
+ call vrndst(iseed)
+ write (iout,*) 'ran_num',ran_number(0.0d0,1.0d0)
+#endif
+ return
+ end
--- /dev/null
+ subroutine refsys(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
+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.
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ logical fail
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.REFSYS'
+ double precision coinc/1.0D-4/,align /1.0D-7/
+ fail=.false.
+ s1=0.0
+ s2=0.0
+ do 1 i=1,3
+ zi=c(i,i2)-c(i,i3)
+ ui=c(i,i4)-c(i,i3)
+ 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.
+c do 3 i=1,3
+c 3 c(i,i1)=0.0D0
+ return
+ 2 if (s2.gt.coinc) goto 4
+ write(iout,1000) i3,i4,i1
+ fail=.true.
+ do 5 i=1,3
+ 5 c(i,i1)=0.0D0
+ return
+ 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=dsqrt(v1*v1+v2*v2+v3*v3)
+ if (anorm.gt.align) goto 6
+ write (iout,1010) i2,i3,i4,i1
+ fail=.true.
+c do 7 i=1,3
+c 7 c(i,i1)=0.0D0
+ return
+ 6 anorm=1.0D0/anorm
+ e3(1)=v1*anorm
+ e3(2)=v2*anorm
+ e3(3)=v3*anorm
+ e1(1)=z(1)*s1
+ e1(2)=z(2)*s1
+ e1(3)=z(3)*s1
+ e2(1)=e1(3)*e3(2)-e1(2)*e3(3)
+ e2(2)=e1(1)*e3(3)-e1(3)*e3(1)
+ e2(3)=e1(2)*e3(1)-e1(1)*e3(2)
+ 1000 format (/1x,' * * * Error - atoms',i4,' and',i4,' coincide.',
+ 1 'coordinates of atom',i4,' are set to zero.')
+ 1010 format (/1x,' * * * Error - atoms',2(i4,2h, ),i4,' form a linear',
+ 1 ' fragment. coordinates of atom',i4,' are set to zero.')
+ return
+ end
--- /dev/null
+ subroutine regularize(ncart,etot,rms,cref0,iretcode)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.HEADER'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.MINIM'
+ double precision przes(3),obrot(3,3),fhpb0(maxdim),varia(maxvar)
+ double precision cref0(3,ncart)
+ double precision energia(0:n_ene)
+ logical non_conv
+ link_end0=link_end
+ do i=1,nhpb
+ fhpb0(i)=forcon(i)
+ enddo
+ maxit_reg=2
+ print *,'Enter REGULARIZE: nnt=',nnt,' nct=',nct,' nsup=',nsup,
+ & ' nstart_seq=',nstart_seq,' nstart_sup',nstart_sup
+ write (iout,'(/a/)') 'Initial energies:'
+ call geom_to_var(nvar,varia)
+ call chainbuild
+ call etotal(energia(0))
+ etot=energia(0)
+ call enerprint(energia(0))
+ call fitsq(rms,c(1,nstart_seq),cref0(1,nstart_sup-1),
+ & nsup,przes,obrot,non_conv)
+ write (iout,'(a,f10.5)')
+ & 'Enter REGULARIZE: Initial RMS deviation:',dsqrt(dabs(rms))
+ write (*,'(a,f10.5)')
+ & 'Enter REGULARIZE: Initial RMS deviation:',dsqrt(dabs(rms))
+ maxit0=maxit
+ maxfun0=maxfun
+ rtolf0=rtolf
+ maxit=100
+ maxfun=200
+ rtolf=1.0D-2
+ do it=1,maxit_reg
+ print *,'Regularization: pass:',it
+C Minimize with distance constraints, gradually relieving the weight.
+ call minimize(etot,varia,iretcode,nfun)
+ print *,'Etot=',Etot
+ if (iretcode.eq.11) return
+ call fitsq(rms,c(1,nstart_seq),cref0(1,nstart_sup-1),
+ & nsup,przes,obrot,non_conv)
+ rms=dsqrt(rms)
+ write (iout,'(a,i2,a,f10.5,a,1pe14.5,a,i3/)')
+ & 'Finish pass',it,', RMS deviation:',rms,', energy',etot,
+ & ' SUMSL convergence',iretcode
+ do i=nss+1,nhpb
+ forcon(i)=0.1D0*forcon(i)
+ enddo
+ enddo
+C Turn off the distance constraints and re-minimize energy.
+ print *,'Final minimization ... '
+ maxit=maxit0
+ maxfun=maxfun0
+ rtolf=rtolf0
+ link_end=min0(link_end,nss)
+ call minimize(etot,varia,iretcode,nfun)
+ print *,'Etot=',Etot
+ call fitsq(rms,c(1,nstart_seq),cref0(1,nstart_sup-1),nsup,
+ & przes,obrot,non_conv)
+ rms=dsqrt(rms)
+ write (iout,'(a,f10.5,a,1pe14.5,a,i3/)')
+ & 'Final RMS deviation:',rms,' energy',etot,' SUMSL convergence',
+ & iretcode
+ link_end=link_end0
+ do i=nss+1,nhpb
+ forcon(i)=fhpb0(i)
+ enddo
+ call var_to_geom(nvar,varia)
+ call chainbuild
+ return
+ end
--- /dev/null
+ integer function rescode(iseq,nam,itype)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.NAMES'
+ include 'COMMON.IOUNITS'
+ character*3 nam,ucase
+
+ if (itype.eq.0) then
+
+ do i=1,ntyp1
+ if (ucase(nam).eq.restyp(i)) then
+ rescode=i
+ return
+ endif
+ enddo
+
+ else
+
+ do i=1,ntyp1
+ if (nam(1:1).eq.onelet(i)) then
+ rescode=i
+ return
+ endif
+ enddo
+
+ endif
+
+ write (iout,10) iseq,nam
+ stop
+ 10 format ('**** Error - residue',i4,' has an unresolved name ',a3)
+ end
+
--- /dev/null
+c algorithm 611, collected algorithms from acm.
+c algorithm appeared in acm-trans. math. software, vol.9, no. 4,
+c dec., 1983, p. 503-524.
+ integer function imdcon(k)
+c
+ integer k
+c
+c *** return integer machine-dependent constants ***
+c
+c *** k = 1 means return standard output unit number. ***
+c *** k = 2 means return alternate output unit number. ***
+c *** k = 3 means return input unit number. ***
+c (note -- k = 2, 3 are used only by test programs.)
+c
+c +++ port version follows...
+c external i1mach
+c integer i1mach
+c integer mdperm(3)
+c data mdperm(1)/2/, mdperm(2)/4/, mdperm(3)/1/
+c imdcon = i1mach(mdperm(k))
+c +++ end of port version +++
+c
+c +++ non-port version follows...
+ integer mdcon(3)
+ data mdcon(1)/6/, mdcon(2)/8/, mdcon(3)/5/
+ imdcon = mdcon(k)
+c +++ end of non-port version +++
+c
+ 999 return
+c *** last card of imdcon follows ***
+ end
+ double precision function rmdcon(k)
+c
+c *** return machine dependent constants used by nl2sol ***
+c
+c +++ comments below contain data statements for various machines. +++
+c +++ to convert to another machine, place a c in column 1 of the +++
+c +++ data statement line(s) that correspond to the current machine +++
+c +++ and remove the c from column 1 of the data statement line(s) +++
+c +++ that correspond to the new machine. +++
+c
+ integer k
+c
+c *** the constant returned depends on k...
+c
+c *** k = 1... smallest pos. eta such that -eta exists.
+c *** k = 2... square root of eta.
+c *** k = 3... unit roundoff = smallest pos. no. machep such
+c *** that 1 + machep .gt. 1 .and. 1 - machep .lt. 1.
+c *** k = 4... square root of machep.
+c *** k = 5... square root of big (see k = 6).
+c *** k = 6... largest machine no. big such that -big exists.
+c
+ double precision big, eta, machep
+ integer bigi(4), etai(4), machei(4)
+c/+
+ double precision dsqrt
+c/
+ equivalence (big,bigi(1)), (eta,etai(1)), (machep,machei(1))
+c
+c +++ ibm 360, ibm 370, or xerox +++
+c
+c data big/z7fffffffffffffff/, eta/z0010000000000000/,
+c 1 machep/z3410000000000000/
+c
+c +++ data general +++
+c
+c data big/0.7237005577d+76/, eta/0.5397605347d-78/,
+c 1 machep/2.22044605d-16/
+c
+c +++ dec 11 +++
+c
+c data big/1.7d+38/, eta/2.938735878d-39/, machep/2.775557562d-17/
+c
+c +++ hp3000 +++
+c
+c data big/1.157920892d+77/, eta/8.636168556d-78/,
+c 1 machep/5.551115124d-17/
+c
+c +++ honeywell +++
+c
+c data big/1.69d+38/, eta/5.9d-39/, machep/2.1680435d-19/
+c
+c +++ dec10 +++
+c
+c data big/"377777100000000000000000/,
+c 1 eta/"002400400000000000000000/,
+c 2 machep/"104400000000000000000000/
+c
+c +++ burroughs +++
+c
+c data big/o0777777777777777,o7777777777777777/,
+c 1 eta/o1771000000000000,o7770000000000000/,
+c 2 machep/o1451000000000000,o0000000000000000/
+c
+c +++ control data +++
+c
+c data big/37767777777777777777b,37167777777777777777b/,
+c 1 eta/00014000000000000000b,00000000000000000000b/,
+c 2 machep/15614000000000000000b,15010000000000000000b/
+c
+c +++ prime +++
+c
+c data big/1.0d+9786/, eta/1.0d-9860/, machep/1.4210855d-14/
+c
+c +++ univac +++
+c
+c data big/8.988d+307/, eta/1.2d-308/, machep/1.734723476d-18/
+c
+c +++ vax +++
+c
+ data big/1.7d+38/, eta/2.939d-39/, machep/1.3877788d-17/
+c
+c +++ cray 1 +++
+c
+c data bigi(1)/577767777777777777777b/,
+c 1 bigi(2)/000007777777777777776b/,
+c 2 etai(1)/200004000000000000000b/,
+c 3 etai(2)/000000000000000000000b/,
+c 4 machei(1)/377224000000000000000b/,
+c 5 machei(2)/000000000000000000000b/
+c
+c +++ port library -- requires more than just a data statement... +++
+c
+c external d1mach
+c double precision d1mach, zero
+c data big/0.d+0/, eta/0.d+0/, machep/0.d+0/, zero/0.d+0/
+c if (big .gt. zero) go to 1
+c big = d1mach(2)
+c eta = d1mach(1)
+c machep = d1mach(4)
+c1 continue
+c
+c +++ end of port +++
+c
+c------------------------------- body --------------------------------
+c
+ go to (10, 20, 30, 40, 50, 60), k
+c
+ 10 rmdcon = eta
+ go to 999
+c
+ 20 rmdcon = dsqrt(256.d+0*eta)/16.d+0
+ go to 999
+c
+ 30 rmdcon = machep
+ go to 999
+c
+ 40 rmdcon = dsqrt(machep)
+ go to 999
+c
+ 50 rmdcon = dsqrt(big/256.d+0)*16.d+0
+ go to 999
+c
+ 60 rmdcon = big
+c
+ 999 return
+c *** last card of rmdcon follows ***
+ end
--- /dev/null
+ subroutine rms_nac_nnc(rms,frac,frac_nn,co,lprn)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.IOUNITS'
+ double precision przes(3),obr(3,3)
+ logical non_conv,lprn
+c call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup),nsup,przes,
+c & obr,non_conv)
+c rms=dsqrt(rms)
+ call rmsd(rms)
+ call contact(.false.,ncont,icont,co)
+ frac=contact_fract(ncont,ncont_ref,icont,icont_ref)
+ frac_nn=contact_fract_nn(ncont,ncont_ref,icont,icont_ref)
+ if (lprn) write (iout,'(a,f8.3/a,f8.3/a,f8.3/a,f8.3)')
+ & 'RMS deviation from the reference structure:',rms,
+ & ' % of native contacts:',frac*100,
+ & ' % of nonnative contacts:',frac_nn*100,
+ & ' contact order:',co
+
+ return
+ end
+c---------------------------------------------------------------------------
+ subroutine rmsd(drms)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.CHAIN'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.INTERACT'
+ logical non_conv
+ double precision przes(3),obrot(3,3)
+ double precision ccopy(3,maxres2+2),crefcopy(3,maxres2+2)
+
+ iatom=0
+c print *,"nz_start",nz_start," nz_end",nz_end
+ do i=nz_start,nz_end
+ iatom=iatom+1
+ iti=itype(i)
+ do k=1,3
+ ccopy(k,iatom)=c(k,i+nstart_seq-nstart_sup)
+ crefcopy(k,iatom)=cref(k,i)
+ enddo
+ if (iz_sc.eq.1.and.iti.ne.10) then
+ iatom=iatom+1
+ do k=1,3
+ ccopy(k,iatom)=c(k,nres+i+nstart_seq-nstart_sup)
+ crefcopy(k,iatom)=cref(k,nres+i)
+ enddo
+ endif
+ enddo
+
+c ----- diagnostics
+c write (iout,*) 'Ccopy and CREFcopy'
+c print '(i5,3f10.5,5x,3f10.5)',(k,(ccopy(j,k),j=1,3),
+c & (crefcopy(j,k),j=1,3),k=1,iatom)
+c write (iout,'(i5,3f10.5,5x,3f10.5)') (k,(ccopy(j,k),j=1,3),
+c & (crefcopy(j,k),j=1,3),k=1,iatom)
+c ----- end diagnostics
+
+ call fitsq(roznica,ccopy(1,1),crefcopy(1,1),iatom,
+ & przes,obrot,non_conv)
+ if (non_conv) then
+ print *,'Problems in FITSQ!!! rmsd'
+ write (iout,*) 'Problems in FITSQ!!! rmsd'
+ print *,'Ccopy and CREFcopy'
+ write (iout,*) 'Ccopy and CREFcopy'
+ print '(i5,3f10.5,5x,3f10.5)',(k,(ccopy(j,k),j=1,3),
+ & (crefcopy(j,k),j=1,3),k=1,iatom)
+ write (iout,'(i5,3f10.5,5x,3f10.5)') (k,(ccopy(j,k),j=1,3),
+ & (crefcopy(j,k),j=1,3),k=1,iatom)
+#ifdef MPI
+c call mpi_abort(mpi_comm_world,ierror,ierrcode)
+ roznica=100.0
+#else
+ stop
+#endif
+ endif
+ drms=dsqrt(dabs(roznica))
+c ---- diagnostics
+c write (iout,*) "rms",drms
+c ---- end diagnostics
+ return
+ end
+
+c--------------------------------------------
+ subroutine rmsd_csa(drms)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.CHAIN'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.INTERACT'
+ logical non_conv
+ double precision przes(3),obrot(3,3)
+ double precision ccopy(3,maxres2+2),crefcopy(3,maxres2+2)
+
+ iatom=0
+ do i=nz_start,nz_end
+ iatom=iatom+1
+ iti=itype(i)
+ do k=1,3
+ ccopy(k,iatom)=c(k,i)
+ crefcopy(k,iatom)=crefjlee(k,i)
+ enddo
+ if (iz_sc.eq.1.and.iti.ne.10) then
+ iatom=iatom+1
+ do k=1,3
+ ccopy(k,iatom)=c(k,nres+i)
+ crefcopy(k,iatom)=crefjlee(k,nres+i)
+ enddo
+ endif
+ enddo
+
+ call fitsq(roznica,ccopy(1,1),crefcopy(1,1),iatom,
+ & przes,obrot,non_conv)
+ if (non_conv) then
+ print *,'Problems in FITSQ!!! rmsd_csa'
+ write (iout,*) 'Problems in FITSQ!!! rmsd_csa'
+ print *,'Ccopy and CREFcopy'
+ write (iout,*) 'Ccopy and CREFcopy'
+ print '(i5,3f10.5,5x,3f10.5)',(k,(ccopy(j,k),j=1,3),
+ & (crefcopy(j,k),j=1,3),k=1,iatom)
+ write (iout,'(i5,3f10.5,5x,3f10.5)') (k,(ccopy(j,k),j=1,3),
+ & (crefcopy(j,k),j=1,3),k=1,iatom)
+#ifdef MPI
+ call mpi_abort(mpi_comm_world,ierror,ierrcode)
+#else
+ stop
+#endif
+ endif
+ drms=dsqrt(dabs(roznica))
+ return
+ end
+
--- /dev/null
+ subroutine sc_move(n_start,n_end,n_maxtry,e_drop,
+ + n_fun,etot)
+c Perform a quick search over side-chain arrangments (over
+c residues n_start to n_end) for a given (frozen) CA trace
+c Only side-chains are minimized (at most n_maxtry times each),
+c not CA positions
+c Stops if energy drops by e_drop, otherwise tries all residues
+c in the given range
+c If there is an energy drop, full minimization may be useful
+c n_start, n_end CAN be modified by this routine, but only if
+c out of bounds (n_start <= 1, n_end >= nres, n_start < n_end)
+c NOTE: this move should never increase the energy
+crc implicit none
+
+c Includes
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.HEADER'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.FFIELD'
+
+c External functions
+ integer iran_num
+ external iran_num
+
+c Input arguments
+ integer n_start,n_end,n_maxtry
+ double precision e_drop
+
+c Output arguments
+ integer n_fun
+ double precision etot
+
+c Local variables
+ double precision energy(0:n_ene)
+ double precision cur_alph(2:nres-1),cur_omeg(2:nres-1)
+ double precision orig_e,cur_e
+ integer n,n_steps,n_first,n_cur,n_tot,i
+ double precision orig_w(n_ene)
+ double precision wtime
+
+
+c Set non side-chain weights to zero (minimization is faster)
+c NOTE: e(2) does not actually depend on the side-chain, only CA
+ orig_w(2)=wscp
+ orig_w(3)=welec
+ orig_w(4)=wcorr
+ orig_w(5)=wcorr5
+ orig_w(6)=wcorr6
+ orig_w(7)=wel_loc
+ orig_w(8)=wturn3
+ orig_w(9)=wturn4
+ orig_w(10)=wturn6
+ orig_w(11)=wang
+ orig_w(13)=wtor
+ orig_w(14)=wtor_d
+ orig_w(15)=wvdwpp
+
+ wscp=0.D0
+ welec=0.D0
+ wcorr=0.D0
+ wcorr5=0.D0
+ wcorr6=0.D0
+ wel_loc=0.D0
+ wturn3=0.D0
+ wturn4=0.D0
+ wturn6=0.D0
+ wang=0.D0
+ wtor=0.D0
+ wtor_d=0.D0
+ wvdwpp=0.D0
+
+c Make sure n_start, n_end are within proper range
+ if (n_start.lt.2) n_start=2
+ if (n_end.gt.nres-1) n_end=nres-1
+crc if (n_start.lt.n_end) then
+ if (n_start.gt.n_end) then
+ n_start=2
+ n_end=nres-1
+ endif
+
+c Save the initial values of energy and coordinates
+cd call chainbuild
+cd call etotal(energy)
+cd write (iout,*) 'start sc ene',energy(0)
+cd call enerprint(energy(0))
+crc etot=energy(0)
+ n_fun=0
+crc orig_e=etot
+crc cur_e=orig_e
+crc do i=2,nres-1
+crc cur_alph(i)=alph(i)
+crc cur_omeg(i)=omeg(i)
+crc enddo
+
+ct wtime=MPI_WTIME()
+c Try (one by one) all specified residues, starting from a
+c random position in sequence
+c Stop early if the energy has decreased by at least e_drop
+ n_tot=n_end-n_start+1
+ n_first=iran_num(0,n_tot-1)
+ n_steps=0
+ n=0
+crc do while (n.lt.n_tot .and. orig_e-etot.lt.e_drop)
+ do while (n.lt.n_tot)
+ n_cur=n_start+mod(n_first+n,n_tot)
+ call single_sc_move(n_cur,n_maxtry,e_drop,
+ + n_steps,n_fun,etot)
+c If a lower energy was found, update the current structure...
+crc if (etot.lt.cur_e) then
+crc cur_e=etot
+crc do i=2,nres-1
+crc cur_alph(i)=alph(i)
+crc cur_omeg(i)=omeg(i)
+crc enddo
+crc else
+c ...else revert to the previous one
+crc etot=cur_e
+crc do i=2,nres-1
+crc alph(i)=cur_alph(i)
+crc omeg(i)=cur_omeg(i)
+crc enddo
+crc endif
+ n=n+1
+cd
+cd call chainbuild
+cd call etotal(energy)
+cd print *,'running',n,energy(0)
+ enddo
+
+cd call chainbuild
+cd call etotal(energy)
+cd write (iout,*) 'end sc ene',energy(0)
+
+c Put the original weights back to calculate the full energy
+ wscp=orig_w(2)
+ welec=orig_w(3)
+ wcorr=orig_w(4)
+ wcorr5=orig_w(5)
+ wcorr6=orig_w(6)
+ wel_loc=orig_w(7)
+ wturn3=orig_w(8)
+ wturn4=orig_w(9)
+ wturn6=orig_w(10)
+ wang=orig_w(11)
+ wtor=orig_w(13)
+ wtor_d=orig_w(14)
+ wvdwpp=orig_w(15)
+
+crc n_fun=n_fun+1
+ct write (iout,*) 'sc_local time= ',MPI_WTIME()-wtime
+ return
+ end
+
+c-------------------------------------------------------------
+
+ subroutine single_sc_move(res_pick,n_maxtry,e_drop,
+ + n_steps,n_fun,e_sc)
+c Perturb one side-chain (res_pick) and minimize the
+c neighbouring region, keeping all CA's and non-neighbouring
+c side-chains fixed
+c Try until e_drop energy improvement is achieved, or n_maxtry
+c attempts have been made
+c At the start, e_sc should contain the side-chain-only energy(0)
+c nsteps and nfun for this move are ADDED to n_steps and n_fun
+crc implicit none
+
+c Includes
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.VAR'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CHAIN'
+ include 'COMMON.MINIM'
+ include 'COMMON.FFIELD'
+ include 'COMMON.IOUNITS'
+
+c External functions
+ double precision dist
+ external dist
+
+c Input arguments
+ integer res_pick,n_maxtry
+ double precision e_drop
+
+c Input/Output arguments
+ integer n_steps,n_fun
+ double precision e_sc
+
+c Local variables
+ logical fail
+ integer i,j
+ integer nres_moved
+ integer iretcode,loc_nfun,orig_maxfun,n_try
+ double precision sc_dist,sc_dist_cutoff
+ double precision energy(0:n_ene),orig_e,cur_e
+ double precision evdw,escloc
+ double precision cur_alph(2:nres-1),cur_omeg(2:nres-1)
+ double precision var(maxvar)
+
+ double precision orig_theta(1:nres),orig_phi(1:nres),
+ + orig_alph(1:nres),orig_omeg(1:nres)
+
+
+c Define what is meant by "neighbouring side-chain"
+ sc_dist_cutoff=5.0D0
+
+c Don't do glycine or ends
+ i=itype(res_pick)
+ if (i.eq.10 .or. i.eq.21) return
+
+c Freeze everything (later will relax only selected side-chains)
+ mask_r=.true.
+ do i=1,nres
+ mask_phi(i)=0
+ mask_theta(i)=0
+ mask_side(i)=0
+ enddo
+
+c Find the neighbours of the side-chain to move
+c and save initial variables
+crc orig_e=e_sc
+crc cur_e=orig_e
+ nres_moved=0
+ do i=2,nres-1
+c Don't do glycine (itype(j)==10)
+ if (itype(i).ne.10) then
+ sc_dist=dist(nres+i,nres+res_pick)
+ else
+ sc_dist=sc_dist_cutoff
+ endif
+ if (sc_dist.lt.sc_dist_cutoff) then
+ nres_moved=nres_moved+1
+ mask_side(i)=1
+ cur_alph(i)=alph(i)
+ cur_omeg(i)=omeg(i)
+ endif
+ enddo
+
+ call chainbuild
+ call egb1(evdw)
+ call esc(escloc)
+ e_sc=wsc*evdw+wscloc*escloc
+cd call etotal(energy)
+cd print *,'new ',(energy(k),k=0,n_ene)
+ orig_e=e_sc
+ cur_e=orig_e
+
+ n_try=0
+ do while (n_try.lt.n_maxtry .and. orig_e-cur_e.lt.e_drop)
+c Move the selected residue (don't worry if it fails)
+ call gen_side(itype(res_pick),theta(res_pick+1),
+ + alph(res_pick),omeg(res_pick),fail)
+
+c Minimize the side-chains starting from the new arrangement
+ call geom_to_var(nvar,var)
+ orig_maxfun=maxfun
+ maxfun=7
+
+crc do i=1,nres
+crc orig_theta(i)=theta(i)
+crc orig_phi(i)=phi(i)
+crc orig_alph(i)=alph(i)
+crc orig_omeg(i)=omeg(i)
+crc enddo
+
+ call minimize_sc1(e_sc,var,iretcode,loc_nfun)
+
+cv write(*,'(2i3,2f12.5,2i3)')
+cv & res_pick,nres_moved,orig_e,e_sc-cur_e,
+cv & iretcode,loc_nfun
+
+c$$$ if (iretcode.eq.8) then
+c$$$ write(iout,*)'Coordinates just after code 8'
+c$$$ call chainbuild
+c$$$ call all_varout
+c$$$ call flush(iout)
+c$$$ do i=1,nres
+c$$$ theta(i)=orig_theta(i)
+c$$$ phi(i)=orig_phi(i)
+c$$$ alph(i)=orig_alph(i)
+c$$$ omeg(i)=orig_omeg(i)
+c$$$ enddo
+c$$$ write(iout,*)'Coordinates just before code 8'
+c$$$ call chainbuild
+c$$$ call all_varout
+c$$$ call flush(iout)
+c$$$ endif
+
+ n_fun=n_fun+loc_nfun
+ maxfun=orig_maxfun
+ call var_to_geom(nvar,var)
+
+c If a lower energy was found, update the current structure...
+ if (e_sc.lt.cur_e) then
+cv call chainbuild
+cv call etotal(energy)
+cd call egb1(evdw)
+cd call esc(escloc)
+cd e_sc1=wsc*evdw+wscloc*escloc
+cd print *,' new',e_sc1,energy(0)
+cv print *,'new ',energy(0)
+cd call enerprint(energy(0))
+ cur_e=e_sc
+ do i=2,nres-1
+ if (mask_side(i).eq.1) then
+ cur_alph(i)=alph(i)
+ cur_omeg(i)=omeg(i)
+ endif
+ enddo
+ else
+c ...else revert to the previous one
+ e_sc=cur_e
+ do i=2,nres-1
+ if (mask_side(i).eq.1) then
+ alph(i)=cur_alph(i)
+ omeg(i)=cur_omeg(i)
+ endif
+ enddo
+ endif
+ n_try=n_try+1
+
+ enddo
+ n_steps=n_steps+n_try
+
+c Reset the minimization mask_r to false
+ mask_r=.false.
+
+ return
+ end
+
+c-------------------------------------------------------------
+
+ subroutine sc_minimize(etot,iretcode,nfun)
+c Minimizes side-chains only, leaving backbone frozen
+crc implicit none
+
+c Includes
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.VAR'
+ include 'COMMON.CHAIN'
+ include 'COMMON.FFIELD'
+
+c Output arguments
+ double precision etot
+ integer iretcode,nfun
+
+c Local variables
+ integer i
+ double precision orig_w(n_ene),energy(0:n_ene)
+ double precision var(maxvar)
+
+
+c Set non side-chain weights to zero (minimization is faster)
+c NOTE: e(2) does not actually depend on the side-chain, only CA
+ orig_w(2)=wscp
+ orig_w(3)=welec
+ orig_w(4)=wcorr
+ orig_w(5)=wcorr5
+ orig_w(6)=wcorr6
+ orig_w(7)=wel_loc
+ orig_w(8)=wturn3
+ orig_w(9)=wturn4
+ orig_w(10)=wturn6
+ orig_w(11)=wang
+ orig_w(13)=wtor
+ orig_w(14)=wtor_d
+
+ wscp=0.D0
+ welec=0.D0
+ wcorr=0.D0
+ wcorr5=0.D0
+ wcorr6=0.D0
+ wel_loc=0.D0
+ wturn3=0.D0
+ wturn4=0.D0
+ wturn6=0.D0
+ wang=0.D0
+ wtor=0.D0
+ wtor_d=0.D0
+
+c Prepare to freeze backbone
+ do i=1,nres
+ mask_phi(i)=0
+ mask_theta(i)=0
+ mask_side(i)=1
+ enddo
+
+c Minimize the side-chains
+ mask_r=.true.
+ call geom_to_var(nvar,var)
+ call minimize(etot,var,iretcode,nfun)
+ call var_to_geom(nvar,var)
+ mask_r=.false.
+
+c Put the original weights back and calculate the full energy
+ wscp=orig_w(2)
+ welec=orig_w(3)
+ wcorr=orig_w(4)
+ wcorr5=orig_w(5)
+ wcorr6=orig_w(6)
+ wel_loc=orig_w(7)
+ wturn3=orig_w(8)
+ wturn4=orig_w(9)
+ wturn6=orig_w(10)
+ wang=orig_w(11)
+ wtor=orig_w(13)
+ wtor_d=orig_w(14)
+
+ call chainbuild
+ call etotal(energy)
+ etot=energy(0)
+
+ return
+ end
+
+c-------------------------------------------------------------
+ subroutine minimize_sc1(etot,x,iretcode,nfun)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2))
+ include 'COMMON.IOUNITS'
+ include 'COMMON.VAR'
+ include 'COMMON.GEO'
+ include 'COMMON.MINIM'
+ common /srutu/ icall
+ dimension iv(liv)
+ double precision minval,x(maxvar),d(maxvar),v(1:lv),xx(maxvar)
+ double precision energia(0:n_ene)
+ external func,gradient,fdum
+ external func_restr1,grad_restr1
+ logical not_done,change,reduce
+ common /przechowalnia/ v
+
+ call deflt(2,iv,liv,lv,v)
+* 12 means fresh start, dont call deflt
+ iv(1)=12
+* max num of fun calls
+ if (maxfun.eq.0) maxfun=500
+ iv(17)=maxfun
+* max num of iterations
+ if (maxmin.eq.0) maxmin=1000
+ iv(18)=maxmin
+* controls output
+ iv(19)=2
+* selects output unit
+c iv(21)=iout
+ iv(21)=0
+* 1 means to print out result
+ iv(22)=0
+* 1 means to print out summary stats
+ iv(23)=0
+* 1 means to print initial x and d
+ iv(24)=0
+* min val for v(radfac) default is 0.1
+ v(24)=0.1D0
+* max val for v(radfac) default is 4.0
+ v(25)=2.0D0
+c v(25)=4.0D0
+* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease)
+* the sumsl default is 0.1
+ v(26)=0.1D0
+* false conv if (act fnctn decrease) .lt. v(34)
+* the sumsl default is 100*machep
+ v(34)=v(34)/100.0D0
+* absolute convergence
+ if (tolf.eq.0.0D0) tolf=1.0D-4
+ v(31)=tolf
+* relative convergence
+ if (rtolf.eq.0.0D0) rtolf=1.0D-4
+ v(32)=rtolf
+* controls initial step size
+ v(35)=1.0D-1
+* large vals of d correspond to small components of step
+ do i=1,nphi
+ d(i)=1.0D-1
+ enddo
+ do i=nphi+1,nvar
+ d(i)=1.0D-1
+ enddo
+ IF (mask_r) THEN
+ call x2xx(x,xx,nvar_restr)
+ call sumsl(nvar_restr,d,xx,func_restr1,grad_restr1,
+ & iv,liv,lv,v,idum,rdum,fdum)
+ call xx2x(x,xx)
+ ELSE
+ call sumsl(nvar,d,x,func,gradient,iv,liv,lv,v,idum,rdum,fdum)
+ ENDIF
+ etot=v(10)
+ iretcode=iv(1)
+ nfun=iv(6)
+
+ return
+ end
+************************************************************************
+ subroutine func_restr1(n,x,nf,f,uiparm,urparm,ufparm)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.DERIV'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.FFIELD'
+ include 'COMMON.INTERACT'
+ include 'COMMON.TIME1'
+ common /chuju/ jjj
+ double precision energia(0:n_ene),evdw,escloc
+ integer jjj
+ double precision ufparm,e1,e2
+ external ufparm
+ integer uiparm(1)
+ real*8 urparm(1)
+ dimension x(maxvar)
+ nfl=nf
+ icg=mod(nf,2)+1
+
+#ifdef OSF
+c Intercept NaNs in the coordinates, before calling etotal
+ x_sum=0.D0
+ do i=1,n
+ x_sum=x_sum+x(i)
+ enddo
+ FOUND_NAN=.false.
+ if (x_sum.ne.x_sum) then
+ write(iout,*)" *** func_restr1 : Found NaN in coordinates"
+ f=1.0D+73
+ FOUND_NAN=.true.
+ return
+ endif
+#endif
+
+ call var_to_geom_restr(n,x)
+ call zerograd
+ call chainbuild
+cd write (iout,*) 'ETOTAL called from FUNC'
+ call egb1(evdw)
+ call esc(escloc)
+ f=wsc*evdw+wscloc*escloc
+cd call etotal(energia(0))
+cd f=wsc*energia(1)+wscloc*energia(12)
+cd print *,f,evdw,escloc,energia(0)
+C
+C Sum up the components of the Cartesian gradient.
+C
+ do i=1,nct
+ do j=1,3
+ gradx(j,i,icg)=wsc*gvdwx(j,i)
+ enddo
+ enddo
+
+ return
+ end
+c-------------------------------------------------------
+ subroutine grad_restr1(n,x,nf,g,uiparm,urparm,ufparm)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.VAR'
+ include 'COMMON.INTERACT'
+ include 'COMMON.FFIELD'
+ include 'COMMON.IOUNITS'
+ external ufparm
+ integer uiparm(1)
+ double precision urparm(1)
+ dimension x(maxvar),g(maxvar)
+
+ icg=mod(nf,2)+1
+ if (nf-nfl+1) 20,30,40
+ 20 call func_restr1(n,x,nf,f,uiparm,urparm,ufparm)
+c write (iout,*) 'grad 20'
+ if (nf.eq.0) return
+ goto 40
+ 30 call var_to_geom_restr(n,x)
+ call chainbuild
+C
+C Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
+C
+ 40 call cartder
+C
+C Convert the Cartesian gradient into internal-coordinate gradient.
+C
+
+ ig=0
+ ind=nres-2
+ do i=2,nres-2
+ IF (mask_phi(i+2).eq.1) THEN
+ gphii=0.0D0
+ do j=i+1,nres-1
+ ind=ind+1
+ do k=1,3
+ gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
+ gphii=gphii+dxdv(k+3,ind)*gradx(k,j,icg)
+ enddo
+ enddo
+ ig=ig+1
+ g(ig)=gphii
+ ELSE
+ ind=ind+nres-1-i
+ ENDIF
+ enddo
+
+
+ ind=0
+ do i=1,nres-2
+ IF (mask_theta(i+2).eq.1) THEN
+ ig=ig+1
+ gthetai=0.0D0
+ do j=i+1,nres-1
+ ind=ind+1
+ do k=1,3
+ gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
+ gthetai=gthetai+dxdv(k,ind)*gradx(k,j,icg)
+ enddo
+ enddo
+ g(ig)=gthetai
+ ELSE
+ ind=ind+nres-1-i
+ ENDIF
+ enddo
+
+ do i=2,nres-1
+ if (itype(i).ne.10) then
+ IF (mask_side(i).eq.1) THEN
+ ig=ig+1
+ galphai=0.0D0
+ do k=1,3
+ galphai=galphai+dxds(k,i)*gradx(k,i,icg)
+ enddo
+ g(ig)=galphai
+ ENDIF
+ endif
+ enddo
+
+
+ do i=2,nres-1
+ if (itype(i).ne.10) then
+ IF (mask_side(i).eq.1) THEN
+ ig=ig+1
+ gomegai=0.0D0
+ do k=1,3
+ gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
+ enddo
+ g(ig)=gomegai
+ ENDIF
+ endif
+ enddo
+
+C
+C Add the components corresponding to local energy terms.
+C
+
+ ig=0
+ igall=0
+ do i=4,nres
+ igall=igall+1
+ if (mask_phi(i).eq.1) then
+ ig=ig+1
+ g(ig)=g(ig)+gloc(igall,icg)
+ endif
+ enddo
+
+ do i=3,nres
+ igall=igall+1
+ if (mask_theta(i).eq.1) then
+ ig=ig+1
+ g(ig)=g(ig)+gloc(igall,icg)
+ endif
+ enddo
+
+ do ij=1,2
+ do i=2,nres-1
+ if (itype(i).ne.10) then
+ igall=igall+1
+ if (mask_side(i).eq.1) then
+ ig=ig+1
+ g(ig)=g(ig)+gloc(igall,icg)
+ endif
+ endif
+ enddo
+ enddo
+
+cd do i=1,ig
+cd write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i)
+cd enddo
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine egb1(evdw)
+C
+C This subroutine calculates the interaction energy of nonbonded side chains
+C assuming the Gay-Berne potential of interaction.
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.NAMES'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CALC'
+ include 'COMMON.CONTROL'
+ logical lprn
+ evdw=0.0D0
+c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
+ evdw=0.0D0
+ lprn=.false.
+c if (icall.eq.0) lprn=.true.
+ ind=0
+ do i=iatsc_s,iatsc_e
+
+
+ itypi=itype(i)
+ itypi1=itype(i+1)
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+ dxi=dc_norm(1,nres+i)
+ dyi=dc_norm(2,nres+i)
+ dzi=dc_norm(3,nres+i)
+ dsci_inv=dsc_inv(itypi)
+C
+C Calculate SC interaction energy.
+C
+ do iint=1,nint_gr(i)
+ do j=istart(i,iint),iend(i,iint)
+ IF (mask_side(j).eq.1.or.mask_side(i).eq.1) THEN
+ ind=ind+1
+ itypj=itype(j)
+ dscj_inv=dsc_inv(itypj)
+ sig0ij=sigma(itypi,itypj)
+ chi1=chi(itypi,itypj)
+ chi2=chi(itypj,itypi)
+ chi12=chi1*chi2
+ chip1=chip(itypi)
+ chip2=chip(itypj)
+ chip12=chip1*chip2
+ alf1=alp(itypi)
+ alf2=alp(itypj)
+ alf12=0.5D0*(alf1+alf2)
+C For diagnostics only!!!
+c chi1=0.0D0
+c chi2=0.0D0
+c chi12=0.0D0
+c chip1=0.0D0
+c chip2=0.0D0
+c chip12=0.0D0
+c alf1=0.0D0
+c alf2=0.0D0
+c alf12=0.0D0
+ xj=c(1,nres+j)-xi
+ yj=c(2,nres+j)-yi
+ zj=c(3,nres+j)-zi
+ dxj=dc_norm(1,nres+j)
+ dyj=dc_norm(2,nres+j)
+ dzj=dc_norm(3,nres+j)
+ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
+ rij=dsqrt(rrij)
+C Calculate angle-dependent terms of energy and contributions to their
+C derivatives.
+ call sc_angular
+ sigsq=1.0D0/sigsq
+ sig=sig0ij*dsqrt(sigsq)
+ rij_shift=1.0D0/rij-sig+sig0ij
+C I hate to put IF's in the loops, but here don't have another choice!!!!
+ if (rij_shift.le.0.0D0) then
+ evdw=1.0D20
+cd write (iout,'(2(a3,i3,2x),17(0pf7.3))')
+cd & restyp(itypi),i,restyp(itypj),j,
+cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
+ return
+ endif
+ sigder=-sig*sigsq
+c---------------------------------------------------------------
+ rij_shift=1.0D0/rij_shift
+ fac=rij_shift**expon
+ e1=fac*fac*aa(itypi,itypj)
+ e2=fac*bb(itypi,itypj)
+ evdwij=eps1*eps2rt*eps3rt*(e1+e2)
+ eps2der=evdwij*eps3rt
+ eps3der=evdwij*eps2rt
+ evdwij=evdwij*eps2rt*eps3rt
+ evdw=evdw+evdwij
+ if (lprn) then
+ sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
+ epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
+cd write (iout,'(2(a3,i3,2x),17(0pf7.3))')
+cd & restyp(itypi),i,restyp(itypj),j,
+cd & epsi,sigm,chi1,chi2,chip1,chip2,
+cd & eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
+cd & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
+cd & evdwij
+ endif
+
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
+ & 'evdw',i,j,evdwij
+
+C Calculate gradient components.
+ e1=e1*eps1*eps2rt**2*eps3rt**2
+ fac=-expon*(e1+evdwij)*rij_shift
+ sigder=fac*sigder
+ fac=rij*fac
+C Calculate the radial part of the gradient
+ gg(1)=xj*fac
+ gg(2)=yj*fac
+ gg(3)=zj*fac
+C Calculate angular part of the gradient.
+ call sc_grad
+ ENDIF
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+ end
+C-----------------------------------------------------------------------------
--- /dev/null
+c
+c
+c ###################################################
+c ## COPYRIGHT (C) 1992 by Jay William Ponder ##
+c ## All Rights Reserved ##
+c ###################################################
+c
+c #############################################################
+c ## ##
+c ## sizes.i -- parameter values to set array dimensions ##
+c ## ##
+c #############################################################
+c
+c
+c "sizes.i" sets values for critical array dimensions used
+c throughout the software; these parameters will fix the size
+c of the largest systems that can be handled; values too large
+c for the computer's memory and/or swap space to accomodate
+c will result in poor performance or outright failure
+c
+c parameter: maximum allowed number of:
+c
+c maxatm atoms in the molecular system
+c maxval atoms directly bonded to an atom
+c maxgrp user-defined groups of atoms
+c maxtyp force field atom type definitions
+c maxclass force field atom class definitions
+c maxkey lines in the keyword file
+c maxrot bonds for torsional rotation
+c maxvar optimization variables (vector storage)
+c maxopt optimization variables (matrix storage)
+c maxhess off-diagonal Hessian elements
+c maxlight sites for method of lights neighbors
+c maxvib vibrational frequencies
+c maxgeo distance geometry points
+c maxcell unit cells in replicated crystal
+c maxring 3-, 4-, or 5-membered rings
+c maxfix geometric restraints
+c maxbio biopolymer atom definitions
+c maxres residues in the macromolecule
+c maxamino amino acid residue types
+c maxnuc nucleic acid residue types
+c maxbnd covalent bonds in molecular system
+c maxang bond angles in molecular system
+c maxtors torsional angles in molecular system
+c maxpi atoms in conjugated pisystem
+c maxpib covalent bonds involving pisystem
+c maxpit torsional angles involving pisystem
+c
+c
+ integer maxatm,maxval,maxgrp
+ integer maxtyp,maxclass,maxkey
+ integer maxrot,maxopt
+ integer maxhess,maxlight,maxvib
+ integer maxgeo,maxcell,maxring
+ integer maxfix,maxbio
+ integer maxamino,maxnuc,maxbnd
+ integer maxang,maxtors,maxpi
+ integer maxpib,maxpit
+ parameter (maxatm=maxres2)
+ parameter (maxval=8)
+ parameter (maxgrp=1000)
+ parameter (maxtyp=3000)
+ parameter (maxclass=500)
+ parameter (maxkey=10000)
+ parameter (maxrot=1000)
+ parameter (maxopt=1000)
+ parameter (maxhess=1000000)
+ parameter (maxlight=8*maxatm)
+ parameter (maxvib=1000)
+ parameter (maxgeo=1000)
+ parameter (maxcell=10000)
+ parameter (maxring=10000)
+ parameter (maxfix=10000)
+ parameter (maxbio=10000)
+ parameter (maxamino=31)
+ parameter (maxnuc=12)
+ parameter (maxbnd=2*maxatm)
+ parameter (maxang=3*maxatm)
+ parameter (maxtors=4*maxatm)
+ parameter (maxpi=100)
+ parameter (maxpib=2*maxpi)
+ parameter (maxpit=4*maxpi)
--- /dev/null
+c
+c
+c ###################################################
+c ## COPYRIGHT (C) 1990 by Jay William Ponder ##
+c ## All Rights Reserved ##
+c ###################################################
+c
+c #########################################################
+c ## ##
+c ## subroutine sort -- heapsort of an integer array ##
+c ## ##
+c #########################################################
+c
+c
+c "sort" takes an input list of integers and sorts it
+c into ascending order using the Heapsort algorithm
+c
+c
+ subroutine sort (n,list)
+ implicit none
+ integer i,j,k,n
+ integer index,lists
+ integer list(*)
+c
+c
+c perform the heapsort of the input list
+c
+ k = n/2 + 1
+ index = n
+ dowhile (n .gt. 1)
+ if (k .gt. 1) then
+ k = k - 1
+ lists = list(k)
+ else
+ lists = list(index)
+ list(index) = list(1)
+ index = index - 1
+ if (index .le. 1) then
+ list(1) = lists
+ return
+ end if
+ end if
+ i = k
+ j = k + k
+ dowhile (j .le. index)
+ if (j .lt. index) then
+ if (list(j) .lt. list(j+1)) j = j + 1
+ end if
+ if (lists .lt. list(j)) then
+ list(i) = list(j)
+ i = j
+ j = j + j
+ else
+ j = index + 1
+ end if
+ end do
+ list(i) = lists
+ end do
+ return
+ end
+c
+c
+c ##############################################################
+c ## ##
+c ## subroutine sort2 -- heapsort of real array with keys ##
+c ## ##
+c ##############################################################
+c
+c
+c "sort2" takes an input list of reals and sorts it
+c into ascending order using the Heapsort algorithm;
+c it also returns a key into the original ordering
+c
+c
+ subroutine sort2 (n,list,key)
+ implicit none
+ integer i,j,k,n
+ integer index,keys
+ integer key(*)
+ real*8 lists
+ real*8 list(*)
+c
+c
+c initialize index into the original ordering
+c
+ do i = 1, n
+ key(i) = i
+ end do
+c
+c perform the heapsort of the input list
+c
+ k = n/2 + 1
+ index = n
+ dowhile (n .gt. 1)
+ if (k .gt. 1) then
+ k = k - 1
+ lists = list(k)
+ keys = key(k)
+ else
+ lists = list(index)
+ keys = key(index)
+ list(index) = list(1)
+ key(index) = key(1)
+ index = index - 1
+ if (index .le. 1) then
+ list(1) = lists
+ key(1) = keys
+ return
+ end if
+ end if
+ i = k
+ j = k + k
+ dowhile (j .le. index)
+ if (j .lt. index) then
+ if (list(j) .lt. list(j+1)) j = j + 1
+ end if
+ if (lists .lt. list(j)) then
+ list(i) = list(j)
+ key(i) = key(j)
+ i = j
+ j = j + j
+ else
+ j = index + 1
+ end if
+ end do
+ list(i) = lists
+ key(i) = keys
+ end do
+ return
+ end
+c
+c
+c #################################################################
+c ## ##
+c ## subroutine sort3 -- heapsort of integer array with keys ##
+c ## ##
+c #################################################################
+c
+c
+c "sort3" takes an input list of integers and sorts it
+c into ascending order using the Heapsort algorithm;
+c it also returns a key into the original ordering
+c
+c
+ subroutine sort3 (n,list,key)
+ implicit none
+ integer i,j,k,n
+ integer index
+ integer lists
+ integer keys
+ integer list(*)
+ integer key(*)
+c
+c
+c initialize index into the original ordering
+c
+ do i = 1, n
+ key(i) = i
+ end do
+c
+c perform the heapsort of the input list
+c
+ k = n/2 + 1
+ index = n
+ dowhile (n .gt. 1)
+ if (k .gt. 1) then
+ k = k - 1
+ lists = list(k)
+ keys = key(k)
+ else
+ lists = list(index)
+ keys = key(index)
+ list(index) = list(1)
+ key(index) = key(1)
+ index = index - 1
+ if (index .le. 1) then
+ list(1) = lists
+ key(1) = keys
+ return
+ end if
+ end if
+ i = k
+ j = k + k
+ dowhile (j .le. index)
+ if (j .lt. index) then
+ if (list(j) .lt. list(j+1)) j = j + 1
+ end if
+ if (lists .lt. list(j)) then
+ list(i) = list(j)
+ key(i) = key(j)
+ i = j
+ j = j + j
+ else
+ j = index + 1
+ end if
+ end do
+ list(i) = lists
+ key(i) = keys
+ end do
+ return
+ end
+c
+c
+c #################################################################
+c ## ##
+c ## subroutine sort4 -- heapsort of integer absolute values ##
+c ## ##
+c #################################################################
+c
+c
+c "sort4" takes an input list of integers and sorts it into
+c ascending absolute value using the Heapsort algorithm
+c
+c
+ subroutine sort4 (n,list)
+ implicit none
+ integer i,j,k,n
+ integer index
+ integer lists
+ integer list(*)
+c
+c
+c perform the heapsort of the input list
+c
+ k = n/2 + 1
+ index = n
+ dowhile (n .gt. 1)
+ if (k .gt. 1) then
+ k = k - 1
+ lists = list(k)
+ else
+ lists = list(index)
+ list(index) = list(1)
+ index = index - 1
+ if (index .le. 1) then
+ list(1) = lists
+ return
+ end if
+ end if
+ i = k
+ j = k + k
+ dowhile (j .le. index)
+ if (j .lt. index) then
+ if (abs(list(j)) .lt. abs(list(j+1))) j = j + 1
+ end if
+ if (abs(lists) .lt. abs(list(j))) then
+ list(i) = list(j)
+ i = j
+ j = j + j
+ else
+ j = index + 1
+ end if
+ end do
+ list(i) = lists
+ end do
+ return
+ end
+c
+c
+c ################################################################
+c ## ##
+c ## subroutine sort5 -- heapsort of integer array modulo m ##
+c ## ##
+c ################################################################
+c
+c
+c "sort5" takes an input list of integers and sorts it
+c into ascending order based on each value modulo "m"
+c
+c
+ subroutine sort5 (n,list,m)
+ implicit none
+ integer i,j,k,m,n
+ integer index,smod
+ integer jmod,j1mod
+ integer lists
+ integer list(*)
+c
+c
+c perform the heapsort of the input list
+c
+ k = n/2 + 1
+ index = n
+ dowhile (n .gt. 1)
+ if (k .gt. 1) then
+ k = k - 1
+ lists = list(k)
+ else
+ lists = list(index)
+ list(index) = list(1)
+ index = index - 1
+ if (index .le. 1) then
+ list(1) = lists
+ return
+ end if
+ end if
+ i = k
+ j = k + k
+ dowhile (j .le. index)
+ if (j .lt. index) then
+ jmod = mod(list(j),m)
+ j1mod = mod(list(j+1),m)
+ if (jmod .lt. j1mod) then
+ j = j + 1
+ else if (jmod.eq.j1mod .and. list(j).lt.list(j+1)) then
+ j = j + 1
+ end if
+ end if
+ smod = mod(lists,m)
+ jmod = mod(list(j),m)
+ if (smod .lt. jmod) then
+ list(i) = list(j)
+ i = j
+ j = j + j
+ else if (smod.eq.jmod .and. lists.lt.list(j)) then
+ list(i) = list(j)
+ i = j
+ j = j + j
+ else
+ j = index + 1
+ end if
+ end do
+ list(i) = lists
+ end do
+ return
+ end
+c
+c
+c #############################################################
+c ## ##
+c ## subroutine sort6 -- heapsort of a text string array ##
+c ## ##
+c #############################################################
+c
+c
+c "sort6" takes an input list of character strings and sorts
+c it into alphabetical order using the Heapsort algorithm
+c
+c
+ subroutine sort6 (n,list)
+ implicit none
+ integer i,j,k,n
+ integer index
+ character*256 lists
+ character*(*) list(*)
+c
+c
+c perform the heapsort of the input list
+c
+ k = n/2 + 1
+ index = n
+ dowhile (n .gt. 1)
+ if (k .gt. 1) then
+ k = k - 1
+ lists = list(k)
+ else
+ lists = list(index)
+ list(index) = list(1)
+ index = index - 1
+ if (index .le. 1) then
+ list(1) = lists
+ return
+ end if
+ end if
+ i = k
+ j = k + k
+ dowhile (j .le. index)
+ if (j .lt. index) then
+ if (list(j) .lt. list(j+1)) j = j + 1
+ end if
+ if (lists .lt. list(j)) then
+ list(i) = list(j)
+ i = j
+ j = j + j
+ else
+ j = index + 1
+ end if
+ end do
+ list(i) = lists
+ end do
+ return
+ end
+c
+c
+c ################################################################
+c ## ##
+c ## subroutine sort7 -- heapsort of text strings with keys ##
+c ## ##
+c ################################################################
+c
+c
+c "sort7" takes an input list of character strings and sorts it
+c into alphabetical order using the Heapsort algorithm; it also
+c returns a key into the original ordering
+c
+c
+ subroutine sort7 (n,list,key)
+ implicit none
+ integer i,j,k,n
+ integer index
+ integer keys
+ integer key(*)
+ character*256 lists
+ character*(*) list(*)
+c
+c
+c initialize index into the original ordering
+c
+ do i = 1, n
+ key(i) = i
+ end do
+c
+c perform the heapsort of the input list
+c
+ k = n/2 + 1
+ index = n
+ dowhile (n .gt. 1)
+ if (k .gt. 1) then
+ k = k - 1
+ lists = list(k)
+ keys = key(k)
+ else
+ lists = list(index)
+ keys = key(index)
+ list(index) = list(1)
+ key(index) = key(1)
+ index = index - 1
+ if (index .le. 1) then
+ list(1) = lists
+ key(1) = keys
+ return
+ end if
+ end if
+ i = k
+ j = k + k
+ dowhile (j .le. index)
+ if (j .lt. index) then
+ if (list(j) .lt. list(j+1)) j = j + 1
+ end if
+ if (lists .lt. list(j)) then
+ list(i) = list(j)
+ key(i) = key(j)
+ i = j
+ j = j + j
+ else
+ j = index + 1
+ end if
+ end do
+ list(i) = lists
+ key(i) = keys
+ end do
+ return
+ end
+c
+c
+c #########################################################
+c ## ##
+c ## subroutine sort8 -- heapsort to unique integers ##
+c ## ##
+c #########################################################
+c
+c
+c "sort8" takes an input list of integers and sorts it into
+c ascending order using the Heapsort algorithm, duplicate
+c values are removed from the final sorted list
+c
+c
+ subroutine sort8 (n,list)
+ implicit none
+ integer i,j,k,n
+ integer index
+ integer lists
+ integer list(*)
+c
+c
+c perform the heapsort of the input list
+c
+ k = n/2 + 1
+ index = n
+ dowhile (n .gt. 1)
+ if (k .gt. 1) then
+ k = k - 1
+ lists = list(k)
+ else
+ lists = list(index)
+ list(index) = list(1)
+ index = index - 1
+ if (index .le. 1) then
+ list(1) = lists
+c
+c remove duplicate values from final list
+c
+ j = 1
+ do i = 2, n
+ if (list(i-1) .ne. list(i)) then
+ j = j + 1
+ list(j) = list(i)
+ end if
+ end do
+ if (j .lt. n) n = j
+ return
+ end if
+ end if
+ i = k
+ j = k + k
+ dowhile (j .le. index)
+ if (j .lt. index) then
+ if (list(j) .lt. list(j+1)) j = j + 1
+ end if
+ if (lists .lt. list(j)) then
+ list(i) = list(j)
+ i = j
+ j = j + j
+ else
+ j = index + 1
+ end if
+ end do
+ list(i) = lists
+ end do
+ return
+ end
+c
+c
+c #############################################################
+c ## ##
+c ## subroutine sort9 -- heapsort to unique text strings ##
+c ## ##
+c #############################################################
+c
+c
+c "sort9" takes an input list of character strings and sorts
+c it into alphabetical order using the Heapsort algorithm,
+c duplicate values are removed from the final sorted list
+c
+c
+ subroutine sort9 (n,list)
+ implicit none
+ integer i,j,k,n
+ integer index
+ character*256 lists
+ character*(*) list(*)
+c
+c
+c perform the heapsort of the input list
+c
+ k = n/2 + 1
+ index = n
+ dowhile (n .gt. 1)
+ if (k .gt. 1) then
+ k = k - 1
+ lists = list(k)
+ else
+ lists = list(index)
+ list(index) = list(1)
+ index = index - 1
+ if (index .le. 1) then
+ list(1) = lists
+c
+c remove duplicate values from final list
+c
+ j = 1
+ do i = 2, n
+ if (list(i-1) .ne. list(i)) then
+ j = j + 1
+ list(j) = list(i)
+ end if
+ end do
+ if (j .lt. n) n = j
+ return
+ end if
+ end if
+ i = k
+ j = k + k
+ dowhile (j .le. index)
+ if (j .lt. index) then
+ if (list(j) .lt. list(j+1)) j = j + 1
+ end if
+ if (lists .lt. list(j)) then
+ list(i) = list(j)
+ i = j
+ j = j + j
+ else
+ j = index + 1
+ end if
+ end do
+ list(i) = lists
+ end do
+ return
+ end
--- /dev/null
+ subroutine friction_force
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.VAR'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.MD'
+#ifndef LANG0
+ include 'COMMON.LANGEVIN'
+#else
+ include 'COMMON.LANGEVIN.lang0'
+#endif
+ include 'COMMON.IOUNITS'
+ double precision gamvec(MAXRES6)
+ common /syfek/ gamvec
+ double precision vv(3),vvtot(3,maxres),v_work(MAXRES6),
+ & ginvfric(maxres2,maxres2)
+ common /przechowalnia/ ginvfric
+
+ logical lprn /.false./, checkmode /.false./
+
+ do i=0,MAXRES2
+ do j=1,3
+ friction(j,i)=0.0d0
+ enddo
+ enddo
+
+ do j=1,3
+ d_t_work(j)=d_t(j,0)
+ enddo
+ ind=3
+ do i=nnt,nct-1
+ do j=1,3
+ d_t_work(ind+j)=d_t(j,i)
+ enddo
+ ind=ind+3
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ do j=1,3
+ d_t_work(ind+j)=d_t(j,i+nres)
+ enddo
+ ind=ind+3
+ endif
+ enddo
+
+ call fricmat_mult(d_t_work,fric_work)
+
+ if (.not.checkmode) return
+
+ if (lprn) then
+ write (iout,*) "d_t_work and fric_work"
+ do i=1,3*dimen
+ write (iout,'(i3,2e15.5)') i,d_t_work(i),fric_work(i)
+ enddo
+ endif
+ do j=1,3
+ friction(j,0)=fric_work(j)
+ enddo
+ ind=3
+ do i=nnt,nct-1
+ do j=1,3
+ friction(j,i)=fric_work(ind+j)
+ enddo
+ ind=ind+3
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ do j=1,3
+ friction(j,i+nres)=fric_work(ind+j)
+ enddo
+ ind=ind+3
+ endif
+ enddo
+ if (lprn) then
+ write(iout,*) "Friction backbone"
+ do i=0,nct-1
+ write(iout,'(i5,3e15.5,5x,3e15.5)')
+ & i,(friction(j,i),j=1,3),(d_t(j,i),j=1,3)
+ enddo
+ write(iout,*) "Friction side chain"
+ do i=nnt,nct
+ write(iout,'(i5,3e15.5,5x,3e15.5)')
+ & i,(friction(j,i+nres),j=1,3),(d_t(j,i+nres),j=1,3)
+ enddo
+ endif
+ if (lprn) then
+ do j=1,3
+ vv(j)=d_t(j,0)
+ enddo
+ do i=nnt,nct
+ do j=1,3
+ vvtot(j,i)=vv(j)+0.5d0*d_t(j,i)
+ vvtot(j,i+nres)=vv(j)+d_t(j,i+nres)
+ vv(j)=vv(j)+d_t(j,i)
+ enddo
+ enddo
+ write (iout,*) "vvtot backbone and sidechain"
+ do i=nnt,nct
+ write (iout,'(i5,3e15.5,5x,3e15.5)') i,(vvtot(j,i),j=1,3),
+ & (vvtot(j,i+nres),j=1,3)
+ enddo
+ ind=0
+ do i=nnt,nct-1
+ do j=1,3
+ v_work(ind+j)=vvtot(j,i)
+ enddo
+ ind=ind+3
+ enddo
+ do i=nnt,nct
+ do j=1,3
+ v_work(ind+j)=vvtot(j,i+nres)
+ enddo
+ ind=ind+3
+ enddo
+ write (iout,*) "v_work gamvec and site-based friction forces"
+ do i=1,dimen1
+ write (iout,'(i5,3e15.5)') i,v_work(i),gamvec(i),
+ & gamvec(i)*v_work(i)
+ enddo
+c do i=1,dimen
+c fric_work1(i)=0.0d0
+c do j=1,dimen1
+c fric_work1(i)=fric_work1(i)-A(j,i)*gamvec(j)*v_work(j)
+c enddo
+c enddo
+c write (iout,*) "fric_work and fric_work1"
+c do i=1,dimen
+c write (iout,'(i5,2e15.5)') i,fric_work(i),fric_work1(i)
+c enddo
+ do i=1,dimen
+ do j=1,dimen
+ ginvfric(i,j)=0.0d0
+ do k=1,dimen
+ ginvfric(i,j)=ginvfric(i,j)+ginv(i,k)*fricmat(k,j)
+ enddo
+ enddo
+ enddo
+ write (iout,*) "ginvfric"
+ do i=1,dimen
+ write (iout,'(i5,100f8.3)') i,(ginvfric(i,j),j=1,dimen)
+ enddo
+ write (iout,*) "symmetry check"
+ do i=1,dimen
+ do j=1,i-1
+ write (iout,*) i,j,ginvfric(i,j)-ginvfric(j,i)
+ enddo
+ enddo
+ endif
+ return
+ end
+c-----------------------------------------------------
+ subroutine stochastic_force(stochforcvec)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.VAR'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.MD'
+ include 'COMMON.TIME1'
+#ifndef LANG0
+ include 'COMMON.LANGEVIN'
+#else
+ include 'COMMON.LANGEVIN.lang0'
+#endif
+ include 'COMMON.IOUNITS'
+
+ double precision x,sig,lowb,highb,
+ & ff(3),force(3,0:MAXRES2),zeta2,lowb2,
+ & highb2,sig2,forcvec(MAXRES6),stochforcvec(MAXRES6)
+ logical lprn /.false./
+ do i=0,MAXRES2
+ do j=1,3
+ stochforc(j,i)=0.0d0
+ enddo
+ enddo
+ x=0.0d0
+
+#ifdef MPI
+ time00=MPI_Wtime()
+#else
+ time00=tcpu()
+#endif
+c Compute the stochastic forces acting on bodies. Store in force.
+ do i=nnt,nct-1
+ sig=stdforcp(i)
+ lowb=-5*sig
+ highb=5*sig
+ do j=1,3
+ force(j,i)=anorm_distr(x,sig,lowb,highb)
+ enddo
+ enddo
+ do i=nnt,nct
+ sig2=stdforcsc(i)
+ lowb2=-5*sig2
+ highb2=5*sig2
+ do j=1,3
+ force(j,i+nres)=anorm_distr(x,sig2,lowb2,highb2)
+ enddo
+ enddo
+#ifdef MPI
+ time_fsample=time_fsample+MPI_Wtime()-time00
+#else
+ time_fsample=time_fsample+tcpu()-time00
+#endif
+c Compute the stochastic forces acting on virtual-bond vectors.
+ do j=1,3
+ ff(j)=0.0d0
+ enddo
+ do i=nct-1,nnt,-1
+ do j=1,3
+ stochforc(j,i)=ff(j)+0.5d0*force(j,i)
+ enddo
+ do j=1,3
+ ff(j)=ff(j)+force(j,i)
+ enddo
+ if (itype(i+1).ne.21) then
+ do j=1,3
+ stochforc(j,i)=stochforc(j,i)+force(j,i+nres+1)
+ ff(j)=ff(j)+force(j,i+nres+1)
+ enddo
+ endif
+ enddo
+ do j=1,3
+ stochforc(j,0)=ff(j)+force(j,nnt+nres)
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ do j=1,3
+ stochforc(j,i+nres)=force(j,i+nres)
+ enddo
+ endif
+ enddo
+
+ do j=1,3
+ stochforcvec(j)=stochforc(j,0)
+ enddo
+ ind=3
+ do i=nnt,nct-1
+ do j=1,3
+ stochforcvec(ind+j)=stochforc(j,i)
+ enddo
+ ind=ind+3
+ enddo
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+ do j=1,3
+ stochforcvec(ind+j)=stochforc(j,i+nres)
+ enddo
+ ind=ind+3
+ endif
+ enddo
+ if (lprn) then
+ write (iout,*) "stochforcvec"
+ do i=1,3*dimen
+ write(iout,'(i5,e15.5)') i,stochforcvec(i)
+ enddo
+ write(iout,*) "Stochastic forces backbone"
+ do i=0,nct-1
+ write(iout,'(i5,3e15.5)') i,(stochforc(j,i),j=1,3)
+ enddo
+ write(iout,*) "Stochastic forces side chain"
+ do i=nnt,nct
+ write(iout,'(i5,3e15.5)')
+ & i,(stochforc(j,i+nres),j=1,3)
+ enddo
+ endif
+
+ if (lprn) then
+
+ ind=0
+ do i=nnt,nct-1
+ write (iout,*) i,ind
+ do j=1,3
+ forcvec(ind+j)=force(j,i)
+ enddo
+ ind=ind+3
+ enddo
+ do i=nnt,nct
+ write (iout,*) i,ind
+ do j=1,3
+ forcvec(j+ind)=force(j,i+nres)
+ enddo
+ ind=ind+3
+ enddo
+
+ write (iout,*) "forcvec"
+ ind=0
+ do i=nnt,nct-1
+ do j=1,3
+ write (iout,'(2i3,2f10.5)') i,j,force(j,i),
+ & forcvec(ind+j)
+ enddo
+ ind=ind+3
+ enddo
+ do i=nnt,nct
+ do j=1,3
+ write (iout,'(2i3,2f10.5)') i,j,force(j,i+nres),
+ & forcvec(ind+j)
+ enddo
+ ind=ind+3
+ enddo
+
+ endif
+
+ return
+ end
+c------------------------------------------------------------------
+ subroutine setup_fricmat
+ implicit real*8 (a-h,o-z)
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'DIMENSIONS'
+ include 'COMMON.VAR'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.MD'
+ include 'COMMON.SETUP'
+ include 'COMMON.TIME1'
+c integer licznik /0/
+c save licznik
+#ifndef LANG0
+ include 'COMMON.LANGEVIN'
+#else
+ include 'COMMON.LANGEVIN.lang0'
+#endif
+ include 'COMMON.IOUNITS'
+ integer IERROR
+ integer i,j,ind,ind1,m
+ logical lprn /.false./
+ double precision dtdi,gamvec(MAXRES2),
+ & ginvfric(maxres2,maxres2),Ghalf(mmaxres2),fcopy(maxres2,maxres2)
+ common /syfek/ gamvec
+ double precision work(8*maxres2)
+ integer iwork(maxres2)
+ common /przechowalnia/ ginvfric,Ghalf,fcopy
+#ifdef MPI
+ if (fg_rank.ne.king) goto 10
+#endif
+c Zeroing out fricmat
+ do i=1,dimen
+ do j=1,dimen
+ fricmat(i,j)=0.0d0
+ enddo
+ enddo
+c Load the friction coefficients corresponding to peptide groups
+ ind1=0
+ do i=nnt,nct-1
+ ind1=ind1+1
+ gamvec(ind1)=gamp
+ enddo
+c Load the friction coefficients corresponding to side chains
+ m=nct-nnt
+ ind=0
+ do i=nnt,nct
+ ind=ind+1
+ ii = ind+m
+ iti=itype(i)
+ gamvec(ii)=gamsc(iti)
+ enddo
+ if (surfarea) call sdarea(gamvec)
+c if (lprn) then
+c write (iout,*) "Matrix A and vector gamma"
+c do i=1,dimen1
+c write (iout,'(i2,$)') i
+c do j=1,dimen
+c write (iout,'(f4.1,$)') A(i,j)
+c enddo
+c write (iout,'(f8.3)') gamvec(i)
+c enddo
+c endif
+ if (lprn) then
+ write (iout,*) "Vector gamvec"
+ do i=1,dimen1
+ write (iout,'(i5,f10.5)') i, gamvec(i)
+ enddo
+ endif
+
+c The friction matrix
+ do k=1,dimen
+ do i=1,dimen
+ dtdi=0.0d0
+ do j=1,dimen1
+ dtdi=dtdi+A(j,k)*A(j,i)*gamvec(j)
+ enddo
+ fricmat(k,i)=dtdi
+ enddo
+ enddo
+
+ if (lprn) then
+ write (iout,'(//a)') "Matrix fricmat"
+ call matout2(dimen,dimen,maxres2,maxres2,fricmat)
+ endif
+ if (lang.eq.2 .or. lang.eq.3) then
+c Mass-scale the friction matrix if non-direct integration will be performed
+ do i=1,dimen
+ do j=1,dimen
+ Ginvfric(i,j)=0.0d0
+ do k=1,dimen
+ do l=1,dimen
+ Ginvfric(i,j)=Ginvfric(i,j)+
+ & Gsqrm(i,k)*Gsqrm(l,j)*fricmat(k,l)
+ enddo
+ enddo
+ enddo
+ enddo
+c Diagonalize the friction matrix
+ ind=0
+ do i=1,dimen
+ do j=1,i
+ ind=ind+1
+ Ghalf(ind)=Ginvfric(i,j)
+ enddo
+ enddo
+ call gldiag(maxres2,dimen,dimen,Ghalf,work,fricgam,fricvec,
+ & ierr,iwork)
+ if (lprn) then
+ write (iout,'(//2a)') "Eigenvectors and eigenvalues of the",
+ & " mass-scaled friction matrix"
+ call eigout(dimen,dimen,maxres2,maxres2,fricvec,fricgam)
+ endif
+c Precompute matrices for tinker stochastic integrator
+#ifndef LANG0
+ do i=1,dimen
+ do j=1,dimen
+ mt1(i,j)=0.0d0
+ mt2(i,j)=0.0d0
+ do k=1,dimen
+ mt1(i,j)=mt1(i,j)+fricvec(k,i)*gsqrm(k,j)
+ mt2(i,j)=mt2(i,j)+fricvec(k,i)*gsqrp(k,j)
+ enddo
+ mt3(j,i)=mt1(i,j)
+ enddo
+ enddo
+#endif
+ else if (lang.eq.4) then
+c Diagonalize the friction matrix
+ ind=0
+ do i=1,dimen
+ do j=1,i
+ ind=ind+1
+ Ghalf(ind)=fricmat(i,j)
+ enddo
+ enddo
+ call gldiag(maxres2,dimen,dimen,Ghalf,work,fricgam,fricvec,
+ & ierr,iwork)
+ if (lprn) then
+ write (iout,'(//2a)') "Eigenvectors and eigenvalues of the",
+ & " friction matrix"
+ call eigout(dimen,dimen,maxres2,maxres2,fricvec,fricgam)
+ endif
+c Determine the number of zero eigenvalues of the friction matrix
+ nzero=max0(dimen-dimen1,0)
+c do while (fricgam(nzero+1).le.1.0d-5 .and. nzero.lt.dimen)
+c nzero=nzero+1
+c enddo
+ write (iout,*) "Number of zero eigenvalues:",nzero
+ do i=1,dimen
+ do j=1,dimen
+ fricmat(i,j)=0.0d0
+ do k=nzero+1,dimen
+ fricmat(i,j)=fricmat(i,j)
+ & +fricvec(i,k)*fricvec(j,k)/fricgam(k)
+ enddo
+ enddo
+ enddo
+ if (lprn) then
+ write (iout,'(//a)') "Generalized inverse of fricmat"
+ call matout(dimen,dimen,maxres6,maxres6,fricmat)
+ endif
+ endif
+#ifdef MPI
+ 10 continue
+ if (nfgtasks.gt.1) then
+ if (fg_rank.eq.0) then
+c The matching BROADCAST for fg processors is called in ERGASTULUM
+#ifdef MPI
+ time00=MPI_Wtime()
+#else
+ time00=tcpu()
+#endif
+ call MPI_Bcast(10,1,MPI_INTEGER,king,FG_COMM,IERROR)
+#ifdef MPI
+ time_Bcast=time_Bcast+MPI_Wtime()-time00
+#else
+ time_Bcast=time_Bcast+tcpu()-time00
+#endif
+c print *,"Processor",myrank,
+c & " BROADCAST iorder in SETUP_FRICMAT"
+ endif
+c licznik=licznik+1
+c write (iout,*) "setup_fricmat licznik",licznik
+#ifdef MPI
+ time00=MPI_Wtime()
+#else
+ time00=tcpu()
+#endif
+c Scatter the friction matrix
+ call MPI_Scatterv(fricmat(1,1),nginv_counts(0),
+ & nginv_start(0),MPI_DOUBLE_PRECISION,fcopy(1,1),
+ & myginv_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
+#ifdef TIMING
+#ifdef MPI
+ time_scatter=time_scatter+MPI_Wtime()-time00
+ time_scatter_fmat=time_scatter_fmat+MPI_Wtime()-time00
+#else
+ time_scatter=time_scatter+tcpu()-time00
+ time_scatter_fmat=time_scatter_fmat+tcpu()-time00
+#endif
+#endif
+ do i=1,dimen
+ do j=1,2*my_ng_count
+ fricmat(j,i)=fcopy(i,j)
+ enddo
+ enddo
+c write (iout,*) "My chunk of fricmat"
+c call MATOUT2(my_ng_count,dimen,maxres2,maxres2,fcopy)
+ endif
+#endif
+ return
+ end
+c-------------------------------------------------------------------------------
+ subroutine sdarea(gamvec)
+c
+c Scale the friction coefficients according to solvent accessible surface areas
+c Code adapted from TINKER
+c AL 9/3/04
+c
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+#ifndef LANG0
+ include 'COMMON.LANGEVIN'
+#else
+ include 'COMMON.LANGEVIN.lang0'
+#endif
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ double precision radius(maxres2),gamvec(maxres6)
+ parameter (twosix=1.122462048309372981d0)
+ logical lprn /.false./
+c
+c determine new friction coefficients every few SD steps
+c
+c set the atomic radii to estimates of sigma values
+c
+c print *,"Entered sdarea"
+ probe = 0.0d0
+
+ do i=1,2*nres
+ radius(i)=0.0d0
+ enddo
+c Load peptide group radii
+ do i=nnt,nct-1
+ radius(i)=pstok
+ enddo
+c Load side chain radii
+ do i=nnt,nct
+ iti=itype(i)
+ radius(i+nres)=restok(iti)
+ enddo
+c do i=1,2*nres
+c write (iout,*) "i",i," radius",radius(i)
+c enddo
+ do i = 1, 2*nres
+ radius(i) = radius(i) / twosix
+ if (radius(i) .ne. 0.0d0) radius(i) = radius(i) + probe
+ end do
+c
+c scale atomic friction coefficients by accessible area
+c
+ if (lprn) write (iout,*)
+ & "Original gammas, surface areas, scaling factors, new gammas, ",
+ & "std's of stochastic forces"
+ ind=0
+ do i=nnt,nct-1
+ if (radius(i).gt.0.0d0) then
+ call surfatom (i,area,radius)
+ ratio = dmax1(area/(4.0d0*pi*radius(i)**2),1.0d-1)
+ if (lprn) write (iout,'(i5,3f10.5,$)')
+ & i,gamvec(ind+1),area,ratio
+ do j=1,3
+ ind=ind+1
+ gamvec(ind) = ratio * gamvec(ind)
+ enddo
+ stdforcp(i)=stdfp*dsqrt(gamvec(ind))
+ if (lprn) write (iout,'(2f10.5)') gamvec(ind),stdforcp(i)
+ endif
+ enddo
+ do i=nnt,nct
+ if (radius(i+nres).gt.0.0d0) then
+ call surfatom (i+nres,area,radius)
+ ratio = dmax1(area/(4.0d0*pi*radius(i+nres)**2),1.0d-1)
+ if (lprn) write (iout,'(i5,3f10.5,$)')
+ & i,gamvec(ind+1),area,ratio
+ do j=1,3
+ ind=ind+1
+ gamvec(ind) = ratio * gamvec(ind)
+ enddo
+ stdforcsc(i)=stdfsc(itype(i))*dsqrt(gamvec(ind))
+ if (lprn) write (iout,'(2f10.5)') gamvec(ind),stdforcsc(i)
+ endif
+ enddo
+
+ return
+ end
--- /dev/null
+ subroutine sumsl(n, d, x, calcf, calcg, iv, liv, lv, v,
+ 1 uiparm, urparm, ufparm)
+c
+c *** minimize general unconstrained objective function using ***
+c *** analytic gradient and hessian approx. from secant update ***
+c
+ integer n, liv, lv
+ integer iv(liv), uiparm(1)
+ double precision d(n), x(n), v(lv), urparm(1)
+c dimension v(71 + n*(n+15)/2), uiparm(*), urparm(*)
+ external calcf, calcg, ufparm
+c
+c *** purpose ***
+c
+c this routine interacts with subroutine sumit in an attempt
+c to find an n-vector x* that minimizes the (unconstrained)
+c objective function computed by calcf. (often the x* found is
+c a local minimizer rather than a global one.)
+c
+c-------------------------- parameter usage --------------------------
+c
+c n........ (input) the number of variables on which f depends, i.e.,
+c the number of components in x.
+c d........ (input/output) a scale vector such that d(i)*x(i),
+c i = 1,2,...,n, are all in comparable units.
+c d can strongly affect the behavior of sumsl.
+c finding the best choice of d is generally a trial-
+c and-error process. choosing d so that d(i)*x(i)
+c has about the same value for all i often works well.
+c the defaults provided by subroutine deflt (see i
+c below) require the caller to supply d.
+c x........ (input/output) before (initially) calling sumsl, the call-
+c er should set x to an initial guess at x*. when
+c sumsl returns, x contains the best point so far
+c found, i.e., the one that gives the least value so
+c far seen for f(x).
+c calcf.... (input) a subroutine that, given x, computes f(x). calcf
+c must be declared external in the calling program.
+c it is invoked by
+c call calcf(n, x, nf, f, uiparm, urparm, ufparm)
+c when calcf is called, nf is the invocation
+c count for calcf. nf is included for possible use
+c with calcg. if x is out of bounds (e.g., if it
+c would cause overflow in computing f(x)), then calcf
+c should set nf to 0. this will cause a shorter step
+c to be attempted. (if x is in bounds, then calcf
+c should not change nf.) the other parameters are as
+c described above and below. calcf should not change
+c n, p, or x.
+c calcg.... (input) a subroutine that, given x, computes g(x), the gra-
+c dient of f at x. calcg must be declared external in
+c the calling program. it is invoked by
+c call calcg(n, x, nf, g, uiparm, urparm, ufaprm)
+c when calcg is called, nf is the invocation
+c count for calcf at the time f(x) was evaluated. the
+c x passed to calcg is usually the one passed to calcf
+c on either its most recent invocation or the one
+c prior to it. if calcf saves intermediate results
+c for use by calcg, then it is possible to tell from
+c nf whether they are valid for the current x (or
+c which copy is valid if two copies are kept). if g
+c cannot be computed at x, then calcg should set nf to
+c 0. in this case, sumsl will return with iv(1) = 65.
+c (if g can be computed at x, then calcg should not
+c changed nf.) the other parameters to calcg are as
+c described above and below. calcg should not change
+c n or x.
+c iv....... (input/output) an integer value array of length liv (see
+c below) that helps control the sumsl algorithm and
+c that is used to store various intermediate quanti-
+c ties. of particular interest are the initialization/
+c return code iv(1) and the entries in iv that control
+c printing and limit the number of iterations and func-
+c tion evaluations. see the section on iv input
+c values below.
+c liv...... (input) length of iv array. must be at least 60. if li
+c is too small, then sumsl returns with iv(1) = 15.
+c when sumsl returns, the smallest allowed value of
+c liv is stored in iv(lastiv) -- see the section on
+c iv output values below. (this is intended for use
+c with extensions of sumsl that handle constraints.)
+c lv....... (input) length of v array. must be at least 71+n*(n+15)/2.
+c (at least 77+n*(n+17)/2 for smsno, at least
+c 78+n*(n+12) for humsl). if lv is too small, then
+c sumsl returns with iv(1) = 16. when sumsl returns,
+c the smallest allowed value of lv is stored in
+c iv(lastv) -- see the section on iv output values
+c below.
+c v........ (input/output) a floating-point value array of length l
+c (see below) that helps control the sumsl algorithm
+c and that is used to store various intermediate
+c quantities. of particular interest are the entries
+c in v that limit the length of the first step
+c attempted (lmax0) and specify convergence tolerances
+c (afctol, lmaxs, rfctol, sctol, xctol, xftol).
+c uiparm... (input) user integer parameter array passed without change
+c to calcf and calcg.
+c urparm... (input) user floating-point parameter array passed without
+c change to calcf and calcg.
+c ufparm... (input) user external subroutine or function passed without
+c change to calcf and calcg.
+c
+c *** iv input values (from subroutine deflt) ***
+c
+c iv(1)... on input, iv(1) should have a value between 0 and 14......
+c 0 and 12 mean this is a fresh start. 0 means that
+c deflt(2, iv, liv, lv, v)
+c is to be called to provide all default values to iv and
+c v. 12 (the value that deflt assigns to iv(1)) means the
+c caller has already called deflt and has possibly changed
+c some iv and/or v entries to non-default values.
+c 13 means deflt has been called and that sumsl (and
+c sumit) should only do their storage allocation. that is,
+c they should set the output components of iv that tell
+c where various subarrays arrays of v begin, such as iv(g)
+c (and, for humsl and humit only, iv(dtol)), and return.
+c 14 means that a storage has been allocated (by a call
+c with iv(1) = 13) and that the algorithm should be
+c started. when called with iv(1) = 13, sumsl returns
+c iv(1) = 14 unless liv or lv is too small (or n is not
+c positive). default = 12.
+c iv(inith).... iv(25) tells whether the hessian approximation h should
+c be initialized. 1 (the default) means sumit should
+c initialize h to the diagonal matrix whose i-th diagonal
+c element is d(i)**2. 0 means the caller has supplied a
+c cholesky factor l of the initial hessian approximation
+c h = l*(l**t) in v, starting at v(iv(lmat)) = v(iv(42))
+c (and stored compactly by rows). note that iv(lmat) may
+c be initialized by calling sumsl with iv(1) = 13 (see
+c the iv(1) discussion above). default = 1.
+c iv(mxfcal)... iv(17) gives the maximum number of function evaluations
+c (calls on calcf) allowed. if this number does not suf-
+c fice, then sumsl returns with iv(1) = 9. default = 200.
+c iv(mxiter)... iv(18) gives the maximum number of iterations allowed.
+c it also indirectly limits the number of gradient evalua-
+c tions (calls on calcg) to iv(mxiter) + 1. if iv(mxiter)
+c iterations do not suffice, then sumsl returns with
+c iv(1) = 10. default = 150.
+c iv(outlev)... iv(19) controls the number and length of iteration sum-
+c mary lines printed (by itsum). iv(outlev) = 0 means do
+c not print any summary lines. otherwise, print a summary
+c line after each abs(iv(outlev)) iterations. if iv(outlev)
+c is positive, then summary lines of length 78 (plus carri-
+c age control) are printed, including the following... the
+c iteration and function evaluation counts, f = the current
+c function value, relative difference in function values
+c achieved by the latest step (i.e., reldf = (f0-v(f))/f01,
+c where f01 is the maximum of abs(v(f)) and abs(v(f0)) and
+c v(f0) is the function value from the previous itera-
+c tion), the relative function reduction predicted for the
+c step just taken (i.e., preldf = v(preduc) / f01, where
+c v(preduc) is described below), the scaled relative change
+c in x (see v(reldx) below), the step parameter for the
+c step just taken (stppar = 0 means a full newton step,
+c between 0 and 1 means a relaxed newton step, between 1
+c and 2 means a double dogleg step, greater than 2 means
+c a scaled down cauchy step -- see subroutine dbldog), the
+c 2-norm of the scale vector d times the step just taken
+c (see v(dstnrm) below), and npreldf, i.e.,
+c v(nreduc)/f01, where v(nreduc) is described below -- if
+c npreldf is positive, then it is the relative function
+c reduction predicted for a newton step (one with
+c stppar = 0). if npreldf is negative, then it is the
+c negative of the relative function reduction predicted
+c for a step computed with step bound v(lmaxs) for use in
+c testing for singular convergence.
+c if iv(outlev) is negative, then lines of length 50
+c are printed, including only the first 6 items listed
+c above (through reldx).
+c default = 1.
+c iv(parprt)... iv(20) = 1 means print any nondefault v values on a
+c fresh start or any changed v values on a restart.
+c iv(parprt) = 0 means skip this printing. default = 1.
+c iv(prunit)... iv(21) is the output unit number on which all printing
+c is done. iv(prunit) = 0 means suppress all printing.
+c default = standard output unit (unit 6 on most systems).
+c iv(solprt)... iv(22) = 1 means print out the value of x returned (as
+c well as the gradient and the scale vector d).
+c iv(solprt) = 0 means skip this printing. default = 1.
+c iv(statpr)... iv(23) = 1 means print summary statistics upon return-
+c ing. these consist of the function value, the scaled
+c relative change in x caused by the most recent step (see
+c v(reldx) below), the number of function and gradient
+c evaluations (calls on calcf and calcg), and the relative
+c function reductions predicted for the last step taken and
+c for a newton step (or perhaps a step bounded by v(lmaxs)
+c -- see the descriptions of preldf and npreldf under
+c iv(outlev) above).
+c iv(statpr) = 0 means skip this printing.
+c iv(statpr) = -1 means skip this printing as well as that
+c of the one-line termination reason message. default = 1.
+c iv(x0prt).... iv(24) = 1 means print the initial x and scale vector d
+c (on a fresh start only). iv(x0prt) = 0 means skip this
+c printing. default = 1.
+c
+c *** (selected) iv output values ***
+c
+c iv(1)........ on output, iv(1) is a return code....
+c 3 = x-convergence. the scaled relative difference (see
+c v(reldx)) between the current parameter vector x and
+c a locally optimal parameter vector is very likely at
+c most v(xctol).
+c 4 = relative function convergence. the relative differ-
+c ence between the current function value and its lo-
+c cally optimal value is very likely at most v(rfctol).
+c 5 = both x- and relative function convergence (i.e., the
+c conditions for iv(1) = 3 and iv(1) = 4 both hold).
+c 6 = absolute function convergence. the current function
+c value is at most v(afctol) in absolute value.
+c 7 = singular convergence. the hessian near the current
+c iterate appears to be singular or nearly so, and a
+c step of length at most v(lmaxs) is unlikely to yield
+c a relative function decrease of more than v(sctol).
+c 8 = false convergence. the iterates appear to be converg-
+c ing to a noncritical point. this may mean that the
+c convergence tolerances (v(afctol), v(rfctol),
+c v(xctol)) are too small for the accuracy to which
+c the function and gradient are being computed, that
+c there is an error in computing the gradient, or that
+c the function or gradient is discontinuous near x.
+c 9 = function evaluation limit reached without other con-
+c vergence (see iv(mxfcal)).
+c 10 = iteration limit reached without other convergence
+c (see iv(mxiter)).
+c 11 = stopx returned .true. (external interrupt). see the
+c usage notes below.
+c 14 = storage has been allocated (after a call with
+c iv(1) = 13).
+c 17 = restart attempted with n changed.
+c 18 = d has a negative component and iv(dtype) .le. 0.
+c 19...43 = v(iv(1)) is out of range.
+c 63 = f(x) cannot be computed at the initial x.
+c 64 = bad parameters passed to assess (which should not
+c occur).
+c 65 = the gradient could not be computed at x (see calcg
+c above).
+c 67 = bad first parameter to deflt.
+c 80 = iv(1) was out of range.
+c 81 = n is not positive.
+c iv(g)........ iv(28) is the starting subscript in v of the current
+c gradient vector (the one corresponding to x).
+c iv(lastiv)... iv(44) is the least acceptable value of liv. (it is
+c only set if liv is at least 44.)
+c iv(lastv).... iv(45) is the least acceptable value of lv. (it is
+c only set if liv is large enough, at least iv(lastiv).)
+c iv(nfcall)... iv(6) is the number of calls so far made on calcf (i.e.,
+c function evaluations).
+c iv(ngcall)... iv(30) is the number of gradient evaluations (calls on
+c calcg).
+c iv(niter).... iv(31) is the number of iterations performed.
+c
+c *** (selected) v input values (from subroutine deflt) ***
+c
+c v(bias)..... v(43) is the bias parameter used in subroutine dbldog --
+c see that subroutine for details. default = 0.8.
+c v(afctol)... v(31) is the absolute function convergence tolerance.
+c if sumsl finds a point where the function value is less
+c than v(afctol) in absolute value, and if sumsl does not
+c return with iv(1) = 3, 4, or 5, then it returns with
+c iv(1) = 6. this test can be turned off by setting
+c v(afctol) to zero. default = max(10**-20, machep**2),
+c where machep is the unit roundoff.
+c v(dinit).... v(38), if nonnegative, is the value to which the scale
+c vector d is initialized. default = -1.
+c v(lmax0).... v(35) gives the maximum 2-norm allowed for d times the
+c very first step that sumsl attempts. this parameter can
+c markedly affect the performance of sumsl.
+c v(lmaxs).... v(36) is used in testing for singular convergence -- if
+c the function reduction predicted for a step of length
+c bounded by v(lmaxs) is at most v(sctol) * abs(f0), where
+c f0 is the function value at the start of the current
+c iteration, and if sumsl does not return with iv(1) = 3,
+c 4, 5, or 6, then it returns with iv(1) = 7. default = 1.
+c v(rfctol)... v(32) is the relative function convergence tolerance.
+c if the current model predicts a maximum possible function
+c reduction (see v(nreduc)) of at most v(rfctol)*abs(f0)
+c at the start of the current iteration, where f0 is the
+c then current function value, and if the last step attempt-
+c ed achieved no more than twice the predicted function
+c decrease, then sumsl returns with iv(1) = 4 (or 5).
+c default = max(10**-10, machep**(2/3)), where machep is
+c the unit roundoff.
+c v(sctol).... v(37) is the singular convergence tolerance -- see the
+c description of v(lmaxs) above.
+c v(tuner1)... v(26) helps decide when to check for false convergence.
+c this is done if the actual function decrease from the
+c current step is no more than v(tuner1) times its predict-
+c ed value. default = 0.1.
+c v(xctol).... v(33) is the x-convergence tolerance. if a newton step
+c (see v(nreduc)) is tried that has v(reldx) .le. v(xctol)
+c and if this step yields at most twice the predicted func-
+c tion decrease, then sumsl returns with iv(1) = 3 (or 5).
+c (see the description of v(reldx) below.)
+c default = machep**0.5, where machep is the unit roundoff.
+c v(xftol).... v(34) is the false convergence tolerance. if a step is
+c tried that gives no more than v(tuner1) times the predict-
+c ed function decrease and that has v(reldx) .le. v(xftol),
+c and if sumsl does not return with iv(1) = 3, 4, 5, 6, or
+c 7, then it returns with iv(1) = 8. (see the description
+c of v(reldx) below.) default = 100*machep, where
+c machep is the unit roundoff.
+c v(*)........ deflt supplies to v a number of tuning constants, with
+c which it should ordinarily be unnecessary to tinker. see
+c section 17 of version 2.2 of the nl2sol usage summary
+c (i.e., the appendix to ref. 1) for details on v(i),
+c i = decfac, incfac, phmnfc, phmxfc, rdfcmn, rdfcmx,
+c tuner2, tuner3, tuner4, tuner5.
+c
+c *** (selected) v output values ***
+c
+c v(dgnorm)... v(1) is the 2-norm of (diag(d)**-1)*g, where g is the
+c most recently computed gradient.
+c v(dstnrm)... v(2) is the 2-norm of diag(d)*step, where step is the
+c current step.
+c v(f)........ v(10) is the current function value.
+c v(f0)....... v(13) is the function value at the start of the current
+c iteration.
+c v(nreduc)... v(6), if positive, is the maximum function reduction
+c possible according to the current model, i.e., the func-
+c tion reduction predicted for a newton step (i.e.,
+c step = -h**-1 * g, where g is the current gradient and
+c h is the current hessian approximation).
+c if v(nreduc) is negative, then it is the negative of
+c the function reduction predicted for a step computed with
+c a step bound of v(lmaxs) for use in testing for singular
+c convergence.
+c v(preduc)... v(7) is the function reduction predicted (by the current
+c quadratic model) for the current step. this (divided by
+c v(f0)) is used in testing for relative function
+c convergence.
+c v(reldx).... v(17) is the scaled relative change in x caused by the
+c current step, computed as
+c max(abs(d(i)*(x(i)-x0(i)), 1 .le. i .le. p) /
+c max(d(i)*(abs(x(i))+abs(x0(i))), 1 .le. i .le. p),
+c where x = x0 + step.
+c
+c------------------------------- notes -------------------------------
+c
+c *** algorithm notes ***
+c
+c this routine uses a hessian approximation computed from the
+c bfgs update (see ref 3). only a cholesky factor of the hessian
+c approximation is stored, and this is updated using ideas from
+c ref. 4. steps are computed by the double dogleg scheme described
+c in ref. 2. the steps are assessed as in ref. 1.
+c
+c *** usage notes ***
+c
+c after a return with iv(1) .le. 11, it is possible to restart,
+c i.e., to change some of the iv and v input values described above
+c and continue the algorithm from the point where it was interrupt-
+c ed. iv(1) should not be changed, nor should any entries of i
+c and v other than the input values (those supplied by deflt).
+c those who do not wish to write a calcg which computes the
+c gradient analytically should call smsno rather than sumsl.
+c smsno uses finite differences to compute an approximate gradient.
+c those who would prefer to provide f and g (the function and
+c gradient) by reverse communication rather than by writing subrou-
+c tines calcf and calcg may call on sumit directly. see the com-
+c ments at the beginning of sumit.
+c those who use sumsl interactively may wish to supply their
+c own stopx function, which should return .true. if the break key
+c has been pressed since stopx was last invoked. this makes it
+c possible to externally interrupt sumsl (which will return with
+c iv(1) = 11 if stopx returns .true.).
+c storage for g is allocated at the end of v. thus the caller
+c may make v longer than specified above and may allow calcg to use
+c elements of g beyond the first n as scratch storage.
+c
+c *** portability notes ***
+c
+c the sumsl distribution tape contains both single- and double-
+c precision versions of the sumsl source code, so it should be un-
+c necessary to change precisions.
+c only the functions imdcon and rmdcon contain machine-dependent
+c constants. to change from one machine to another, it should
+c suffice to change the (few) relevant lines in these functions.
+c intrinsic functions are explicitly declared. on certain com-
+c puters (e.g. univac), it may be necessary to comment out these
+c declarations. so that this may be done automatically by a simple
+c program, such declarations are preceded by a comment having c/+
+c in columns 1-3 and blanks in columns 4-72 and are followed by
+c a comment having c/ in columns 1 and 2 and blanks in columns 3-72.
+c the sumsl source code is expressed in 1966 ansi standard
+c fortran. it may be converted to fortran 77 by commenting out all
+c lines that fall between a line having c/6 in columns 1-3 and a
+c line having c/7 in columns 1-3 and by removing (i.e., replacing
+c by a blank) the c in column 1 of the lines that follow the c/7
+c line and precede a line having c/ in columns 1-2 and blanks in
+c columns 3-72. these changes convert some data statements into
+c parameter statements, convert some variables from real to
+c character*4, and make the data statements that initialize these
+c variables use character strings delimited by primes instead
+c of hollerith constants. (such variables and data statements
+c appear only in modules itsum and parck. parameter statements
+c appear nearly everywhere.) these changes also add save state-
+c ments for variables given machine-dependent constants by rmdcon.
+c
+c *** references ***
+c
+c 1. dennis, j.e., gay, d.m., and welsch, r.e. (1981), algorithm 573 --
+c an adaptive nonlinear least-squares algorithm, acm trans.
+c math. software 7, pp. 369-383.
+c
+c 2. dennis, j.e., and mei, h.h.w. (1979), two new unconstrained opti-
+c mization algorithms which use function and gradient
+c values, j. optim. theory applic. 28, pp. 453-482.
+c
+c 3. dennis, j.e., and more, j.j. (1977), quasi-newton methods, motiva-
+c tion and theory, siam rev. 19, pp. 46-89.
+c
+c 4. goldfarb, d. (1976), factorized variable metric methods for uncon-
+c strained optimization, math. comput. 30, pp. 796-811.
+c
+c *** general ***
+c
+c coded by david m. gay (winter 1980). revised summer 1982.
+c this subroutine was written in connection with research
+c supported in part by the national science foundation under
+c grants mcs-7600324, dcr75-10143, 76-14311dss, mcs76-11989,
+c and mcs-7906671.
+c.
+c
+c---------------------------- declarations ---------------------------
+c
+ external deflt, sumit
+c
+c deflt... supplies default iv and v input components.
+c sumit... reverse-communication routine that carries out sumsl algo-
+c rithm.
+c
+ integer g1, iv1, nf
+ double precision f
+c
+c *** subscripts for iv ***
+c
+ integer nextv, nfcall, nfgcal, g, toobig, vneed
+c
+c/6
+c data nextv/47/, nfcall/6/, nfgcal/7/, g/28/, toobig/2/, vneed/4/
+c/7
+ parameter (nextv=47, nfcall=6, nfgcal=7, g=28, toobig=2, vneed=4)
+c/
+c
+c+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++
+c
+ if (iv(1) .eq. 0) call deflt(2, iv, liv, lv, v)
+ iv1 = iv(1)
+ if (iv1 .eq. 12 .or. iv1 .eq. 13) iv(vneed) = iv(vneed) + n
+ if (iv1 .eq. 14) go to 10
+ if (iv1 .gt. 2 .and. iv1 .lt. 12) go to 10
+ g1 = 1
+ if (iv1 .eq. 12) iv(1) = 13
+ go to 20
+c
+ 10 g1 = iv(g)
+c
+ 20 call sumit(d, f, v(g1), iv, liv, lv, n, v, x)
+ if (iv(1) - 2) 30, 40, 50
+c
+ 30 nf = iv(nfcall)
+ call calcf(n, x, nf, f, uiparm, urparm, ufparm)
+ if (nf .le. 0) iv(toobig) = 1
+ go to 20
+c
+ 40 call calcg(n, x, iv(nfgcal), v(g1), uiparm, urparm, ufparm)
+ go to 20
+c
+ 50 if (iv(1) .ne. 14) go to 999
+c
+c *** storage allocation
+c
+ iv(g) = iv(nextv)
+ iv(nextv) = iv(g) + n
+ if (iv1 .ne. 13) go to 10
+c
+ 999 return
+c *** last card of sumsl follows ***
+ end
+ subroutine sumit(d, fx, g, iv, liv, lv, n, v, x)
+c
+c *** carry out sumsl (unconstrained minimization) iterations, using
+c *** double-dogleg/bfgs steps.
+c
+c *** parameter declarations ***
+c
+ integer liv, lv, n
+ integer iv(liv)
+ double precision d(n), fx, g(n), v(lv), x(n)
+c
+c-------------------------- parameter usage --------------------------
+c
+c d.... scale vector.
+c fx... function value.
+c g.... gradient vector.
+c iv... integer value array.
+c liv.. length of iv (at least 60).
+c lv... length of v (at least 71 + n*(n+13)/2).
+c n.... number of variables (components in x and g).
+c v.... floating-point value array.
+c x.... vector of parameters to be optimized.
+c
+c *** discussion ***
+c
+c parameters iv, n, v, and x are the same as the corresponding
+c ones to sumsl (which see), except that v can be shorter (since
+c the part of v that sumsl uses for storing g is not needed).
+c moreover, compared with sumsl, iv(1) may have the two additional
+c output values 1 and 2, which are explained below, as is the use
+c of iv(toobig) and iv(nfgcal). the value iv(g), which is an
+c output value from sumsl (and smsno), is not referenced by
+c sumit or the subroutines it calls.
+c fx and g need not have been initialized when sumit is called
+c with iv(1) = 12, 13, or 14.
+c
+c iv(1) = 1 means the caller should set fx to f(x), the function value
+c at x, and call sumit again, having changed none of the
+c other parameters. an exception occurs if f(x) cannot be
+c (e.g. if overflow would occur), which may happen because
+c of an oversized step. in this case the caller should set
+c iv(toobig) = iv(2) to 1, which will cause sumit to ig-
+c nore fx and try a smaller step. the parameter nf that
+c sumsl passes to calcf (for possible use by calcg) is a
+c copy of iv(nfcall) = iv(6).
+c iv(1) = 2 means the caller should set g to g(x), the gradient vector
+c of f at x, and call sumit again, having changed none of
+c the other parameters except possibly the scale vector d
+c when iv(dtype) = 0. the parameter nf that sumsl passes
+c to calcg is iv(nfgcal) = iv(7). if g(x) cannot be
+c evaluated, then the caller may set iv(nfgcal) to 0, in
+c which case sumit will return with iv(1) = 65.
+c.
+c *** general ***
+c
+c coded by david m. gay (december 1979). revised sept. 1982.
+c this subroutine was written in connection with research supported
+c in part by the national science foundation under grants
+c mcs-7600324 and mcs-7906671.
+c
+c (see sumsl for references.)
+c
+c+++++++++++++++++++++++++++ declarations ++++++++++++++++++++++++++++
+c
+c *** local variables ***
+c
+ integer dg1, dummy, g01, i, k, l, lstgst, nwtst1, step1,
+ 1 temp1, w, x01, z
+ double precision t
+c
+c *** constants ***
+c
+ double precision half, negone, one, onep2, zero
+c
+c *** no intrinsic functions ***
+c
+c *** external functions and subroutines ***
+c
+ external assst, dbdog, deflt, dotprd, itsum, litvmu, livmul,
+ 1 ltvmul, lupdat, lvmul, parck, reldst, stopx, vaxpy,
+ 2 vcopy, vscopy, vvmulp, v2norm, wzbfgs
+ logical stopx
+ double precision dotprd, reldst, v2norm
+c
+c assst.... assesses candidate step.
+c dbdog.... computes double-dogleg (candidate) step.
+c deflt.... supplies default iv and v input components.
+c dotprd... returns inner product of two vectors.
+c itsum.... prints iteration summary and info on initial and final x.
+c litvmu... multiplies inverse transpose of lower triangle times vector.
+c livmul... multiplies inverse of lower triangle times vector.
+c ltvmul... multiplies transpose of lower triangle times vector.
+c lupdt.... updates cholesky factor of hessian approximation.
+c lvmul.... multiplies lower triangle times vector.
+c parck.... checks validity of input iv and v values.
+c reldst... computes v(reldx) = relative step size.
+c stopx.... returns .true. if the break key has been pressed.
+c vaxpy.... computes scalar times one vector plus another.
+c vcopy.... copies one vector to another.
+c vscopy... sets all elements of a vector to a scalar.
+c vvmulp... multiplies vector by vector raised to power (componentwise).
+c v2norm... returns the 2-norm of a vector.
+c wzbfgs... computes w and z for lupdat corresponding to bfgs update.
+c
+c *** subscripts for iv and v ***
+c
+ integer afctol
+ integer cnvcod, dg, dgnorm, dinit, dstnrm, dst0, f, f0, fdif,
+ 1 gthg, gtstep, g0, incfac, inith, irc, kagqt, lmat, lmax0,
+ 2 lmaxs, mode, model, mxfcal, mxiter, nextv, nfcall, nfgcal,
+ 3 ngcall, niter, nreduc, nwtstp, preduc, radfac, radinc,
+ 4 radius, rad0, reldx, restor, step, stglim, stlstg, toobig,
+ 5 tuner4, tuner5, vneed, xirc, x0
+c
+c *** iv subscript values ***
+c
+c/6
+c data cnvcod/55/, dg/37/, g0/48/, inith/25/, irc/29/, kagqt/33/,
+c 1 mode/35/, model/5/, mxfcal/17/, mxiter/18/, nfcall/6/,
+c 2 nfgcal/7/, ngcall/30/, niter/31/, nwtstp/34/, radinc/8/,
+c 3 restor/9/, step/40/, stglim/11/, stlstg/41/, toobig/2/,
+c 4 vneed/4/, xirc/13/, x0/43/
+c/7
+ parameter (cnvcod=55, dg=37, g0=48, inith=25, irc=29, kagqt=33,
+ 1 mode=35, model=5, mxfcal=17, mxiter=18, nfcall=6,
+ 2 nfgcal=7, ngcall=30, niter=31, nwtstp=34, radinc=8,
+ 3 restor=9, step=40, stglim=11, stlstg=41, toobig=2,
+ 4 vneed=4, xirc=13, x0=43)
+c/
+c
+c *** v subscript values ***
+c
+c/6
+c data afctol/31/
+c data dgnorm/1/, dinit/38/, dstnrm/2/, dst0/3/, f/10/, f0/13/,
+c 1 fdif/11/, gthg/44/, gtstep/4/, incfac/23/, lmat/42/,
+c 2 lmax0/35/, lmaxs/36/, nextv/47/, nreduc/6/, preduc/7/,
+c 3 radfac/16/, radius/8/, rad0/9/, reldx/17/, tuner4/29/,
+c 4 tuner5/30/
+c/7
+ parameter (afctol=31)
+ parameter (dgnorm=1, dinit=38, dstnrm=2, dst0=3, f=10, f0=13,
+ 1 fdif=11, gthg=44, gtstep=4, incfac=23, lmat=42,
+ 2 lmax0=35, lmaxs=36, nextv=47, nreduc=6, preduc=7,
+ 3 radfac=16, radius=8, rad0=9, reldx=17, tuner4=29,
+ 4 tuner5=30)
+c/
+c
+c/6
+c data half/0.5d+0/, negone/-1.d+0/, one/1.d+0/, onep2/1.2d+0/,
+c 1 zero/0.d+0/
+c/7
+ parameter (half=0.5d+0, negone=-1.d+0, one=1.d+0, onep2=1.2d+0,
+ 1 zero=0.d+0)
+c/
+c
+c+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++
+c
+C Following SAVE statement inserted.
+ save l
+ i = iv(1)
+ if (i .eq. 1) go to 50
+ if (i .eq. 2) go to 60
+c
+c *** check validity of iv and v input values ***
+c
+ if (iv(1) .eq. 0) call deflt(2, iv, liv, lv, v)
+ if (iv(1) .eq. 12 .or. iv(1) .eq. 13)
+ 1 iv(vneed) = iv(vneed) + n*(n+13)/2
+ call parck(2, d, iv, liv, lv, n, v)
+ i = iv(1) - 2
+ if (i .gt. 12) go to 999
+ go to (180, 180, 180, 180, 180, 180, 120, 90, 120, 10, 10, 20), i
+c
+c *** storage allocation ***
+c
+10 l = iv(lmat)
+ iv(x0) = l + n*(n+1)/2
+ iv(step) = iv(x0) + n
+ iv(stlstg) = iv(step) + n
+ iv(g0) = iv(stlstg) + n
+ iv(nwtstp) = iv(g0) + n
+ iv(dg) = iv(nwtstp) + n
+ iv(nextv) = iv(dg) + n
+ if (iv(1) .ne. 13) go to 20
+ iv(1) = 14
+ go to 999
+c
+c *** initialization ***
+c
+ 20 iv(niter) = 0
+ iv(nfcall) = 1
+ iv(ngcall) = 1
+ iv(nfgcal) = 1
+ iv(mode) = -1
+ iv(model) = 1
+ iv(stglim) = 1
+ iv(toobig) = 0
+ iv(cnvcod) = 0
+ iv(radinc) = 0
+ v(rad0) = zero
+ if (v(dinit) .ge. zero) call vscopy(n, d, v(dinit))
+ if (iv(inith) .ne. 1) go to 40
+c
+c *** set the initial hessian approximation to diag(d)**-2 ***
+c
+ l = iv(lmat)
+ call vscopy(n*(n+1)/2, v(l), zero)
+ k = l - 1
+ do 30 i = 1, n
+ k = k + i
+ t = d(i)
+ if (t .le. zero) t = one
+ v(k) = t
+ 30 continue
+c
+c *** compute initial function value ***
+c
+ 40 iv(1) = 1
+ go to 999
+c
+ 50 v(f) = fx
+ if (iv(mode) .ge. 0) go to 180
+ iv(1) = 2
+ if (iv(toobig) .eq. 0) go to 999
+ iv(1) = 63
+ go to 300
+c
+c *** make sure gradient could be computed ***
+c
+ 60 if (iv(nfgcal) .ne. 0) go to 70
+ iv(1) = 65
+ go to 300
+c
+ 70 dg1 = iv(dg)
+ call vvmulp(n, v(dg1), g, d, -1)
+ v(dgnorm) = v2norm(n, v(dg1))
+c
+c *** test norm of gradient ***
+c
+ if (v(dgnorm) .gt. v(afctol)) go to 75
+ iv(irc) = 10
+ iv(cnvcod) = iv(irc) - 4
+c
+ 75 if (iv(cnvcod) .ne. 0) go to 290
+ if (iv(mode) .eq. 0) go to 250
+c
+c *** allow first step to have scaled 2-norm at most v(lmax0) ***
+c
+ v(radius) = v(lmax0)
+c
+ iv(mode) = 0
+c
+c
+c----------------------------- main loop -----------------------------
+c
+c
+c *** print iteration summary, check iteration limit ***
+c
+ 80 call itsum(d, g, iv, liv, lv, n, v, x)
+ 90 k = iv(niter)
+ if (k .lt. iv(mxiter)) go to 100
+ iv(1) = 10
+ go to 300
+c
+c *** update radius ***
+c
+ 100 iv(niter) = k + 1
+ if(k.gt.0)v(radius) = v(radfac) * v(dstnrm)
+c
+c *** initialize for start of next iteration ***
+c
+ g01 = iv(g0)
+ x01 = iv(x0)
+ v(f0) = v(f)
+ iv(irc) = 4
+ iv(kagqt) = -1
+c
+c *** copy x to x0, g to g0 ***
+c
+ call vcopy(n, v(x01), x)
+ call vcopy(n, v(g01), g)
+c
+c *** check stopx and function evaluation limit ***
+c
+C AL 4/30/95
+ dummy=iv(nfcall)
+ 110 if (.not. stopx(dummy)) go to 130
+ iv(1) = 11
+ go to 140
+c
+c *** come here when restarting after func. eval. limit or stopx.
+c
+ 120 if (v(f) .ge. v(f0)) go to 130
+ v(radfac) = one
+ k = iv(niter)
+ go to 100
+c
+ 130 if (iv(nfcall) .lt. iv(mxfcal)) go to 150
+ iv(1) = 9
+ 140 if (v(f) .ge. v(f0)) go to 300
+c
+c *** in case of stopx or function evaluation limit with
+c *** improved v(f), evaluate the gradient at x.
+c
+ iv(cnvcod) = iv(1)
+ go to 240
+c
+c. . . . . . . . . . . . . compute candidate step . . . . . . . . . .
+c
+ 150 step1 = iv(step)
+ dg1 = iv(dg)
+ nwtst1 = iv(nwtstp)
+ if (iv(kagqt) .ge. 0) go to 160
+ l = iv(lmat)
+ call livmul(n, v(nwtst1), v(l), g)
+ v(nreduc) = half * dotprd(n, v(nwtst1), v(nwtst1))
+ call litvmu(n, v(nwtst1), v(l), v(nwtst1))
+ call vvmulp(n, v(step1), v(nwtst1), d, 1)
+ v(dst0) = v2norm(n, v(step1))
+ call vvmulp(n, v(dg1), v(dg1), d, -1)
+ call ltvmul(n, v(step1), v(l), v(dg1))
+ v(gthg) = v2norm(n, v(step1))
+ iv(kagqt) = 0
+ 160 call dbdog(v(dg1), lv, n, v(nwtst1), v(step1), v)
+ if (iv(irc) .eq. 6) go to 180
+c
+c *** check whether evaluating f(x0 + step) looks worthwhile ***
+c
+ if (v(dstnrm) .le. zero) go to 180
+ if (iv(irc) .ne. 5) go to 170
+ if (v(radfac) .le. one) go to 170
+ if (v(preduc) .le. onep2 * v(fdif)) go to 180
+c
+c *** compute f(x0 + step) ***
+c
+ 170 x01 = iv(x0)
+ step1 = iv(step)
+ call vaxpy(n, x, one, v(step1), v(x01))
+ iv(nfcall) = iv(nfcall) + 1
+ iv(1) = 1
+ iv(toobig) = 0
+ go to 999
+c
+c. . . . . . . . . . . . . assess candidate step . . . . . . . . . . .
+c
+ 180 x01 = iv(x0)
+ v(reldx) = reldst(n, d, x, v(x01))
+ call assst(iv, liv, lv, v)
+ step1 = iv(step)
+ lstgst = iv(stlstg)
+ if (iv(restor) .eq. 1) call vcopy(n, x, v(x01))
+ if (iv(restor) .eq. 2) call vcopy(n, v(lstgst), v(step1))
+ if (iv(restor) .ne. 3) go to 190
+ call vcopy(n, v(step1), v(lstgst))
+ call vaxpy(n, x, one, v(step1), v(x01))
+ v(reldx) = reldst(n, d, x, v(x01))
+c
+ 190 k = iv(irc)
+ go to (200,230,230,230,200,210,220,220,220,220,220,220,280,250), k
+c
+c *** recompute step with changed radius ***
+c
+ 200 v(radius) = v(radfac) * v(dstnrm)
+ go to 110
+c
+c *** compute step of length v(lmaxs) for singular convergence test.
+c
+ 210 v(radius) = v(lmaxs)
+ go to 150
+c
+c *** convergence or false convergence ***
+c
+ 220 iv(cnvcod) = k - 4
+ if (v(f) .ge. v(f0)) go to 290
+ if (iv(xirc) .eq. 14) go to 290
+ iv(xirc) = 14
+c
+c. . . . . . . . . . . . process acceptable step . . . . . . . . . . .
+c
+ 230 if (iv(irc) .ne. 3) go to 240
+ step1 = iv(step)
+ temp1 = iv(stlstg)
+c
+c *** set temp1 = hessian * step for use in gradient tests ***
+c
+ l = iv(lmat)
+ call ltvmul(n, v(temp1), v(l), v(step1))
+ call lvmul(n, v(temp1), v(l), v(temp1))
+c
+c *** compute gradient ***
+c
+ 240 iv(ngcall) = iv(ngcall) + 1
+ iv(1) = 2
+ go to 999
+c
+c *** initializations -- g0 = g - g0, etc. ***
+c
+ 250 g01 = iv(g0)
+ call vaxpy(n, v(g01), negone, v(g01), g)
+ step1 = iv(step)
+ temp1 = iv(stlstg)
+ if (iv(irc) .ne. 3) go to 270
+c
+c *** set v(radfac) by gradient tests ***
+c
+c *** set temp1 = diag(d)**-1 * (hessian*step + (g(x0)-g(x))) ***
+c
+ call vaxpy(n, v(temp1), negone, v(g01), v(temp1))
+ call vvmulp(n, v(temp1), v(temp1), d, -1)
+c
+c *** do gradient tests ***
+c
+ if (v2norm(n, v(temp1)) .le. v(dgnorm) * v(tuner4))
+ 1 go to 260
+ if (dotprd(n, g, v(step1))
+ 1 .ge. v(gtstep) * v(tuner5)) go to 270
+ 260 v(radfac) = v(incfac)
+c
+c *** update h, loop ***
+c
+ 270 w = iv(nwtstp)
+ z = iv(x0)
+ l = iv(lmat)
+ call wzbfgs(v(l), n, v(step1), v(w), v(g01), v(z))
+c
+c ** use the n-vectors starting at v(step1) and v(g01) for scratch..
+ call lupdat(v(temp1), v(step1), v(l), v(g01), v(l), n, v(w), v(z))
+ iv(1) = 2
+ go to 80
+c
+c. . . . . . . . . . . . . . misc. details . . . . . . . . . . . . . .
+c
+c *** bad parameters to assess ***
+c
+ 280 iv(1) = 64
+ go to 300
+c
+c *** print summary of final iteration and other requested items ***
+c
+ 290 iv(1) = iv(cnvcod)
+ iv(cnvcod) = 0
+ 300 call itsum(d, g, iv, liv, lv, n, v, x)
+c
+ 999 return
+c
+c *** last line of sumit follows ***
+ end
+ subroutine dbdog(dig, lv, n, nwtstp, step, v)
+c
+c *** compute double dogleg step ***
+c
+c *** parameter declarations ***
+c
+ integer lv, n
+ double precision dig(n), nwtstp(n), step(n), v(lv)
+c
+c *** purpose ***
+c
+c this subroutine computes a candidate step (for use in an uncon-
+c strained minimization code) by the double dogleg algorithm of
+c dennis and mei (ref. 1), which is a variation on powell*s dogleg
+c scheme (ref. 2, p. 95).
+c
+c-------------------------- parameter usage --------------------------
+c
+c dig (input) diag(d)**-2 * g -- see algorithm notes.
+c g (input) the current gradient vector.
+c lv (input) length of v.
+c n (input) number of components in dig, g, nwtstp, and step.
+c nwtstp (input) negative newton step -- see algorithm notes.
+c step (output) the computed step.
+c v (i/o) values array, the following components of which are
+c used here...
+c v(bias) (input) bias for relaxed newton step, which is v(bias) of
+c the way from the full newton to the fully relaxed newton
+c step. recommended value = 0.8 .
+c v(dgnorm) (input) 2-norm of diag(d)**-1 * g -- see algorithm notes.
+c v(dstnrm) (output) 2-norm of diag(d) * step, which is v(radius)
+c unless v(stppar) = 0 -- see algorithm notes.
+c v(dst0) (input) 2-norm of diag(d) * nwtstp -- see algorithm notes.
+c v(grdfac) (output) the coefficient of dig in the step returned --
+c step(i) = v(grdfac)*dig(i) + v(nwtfac)*nwtstp(i).
+c v(gthg) (input) square-root of (dig**t) * (hessian) * dig -- see
+c algorithm notes.
+c v(gtstep) (output) inner product between g and step.
+c v(nreduc) (output) function reduction predicted for the full newton
+c step.
+c v(nwtfac) (output) the coefficient of nwtstp in the step returned --
+c see v(grdfac) above.
+c v(preduc) (output) function reduction predicted for the step returned.
+c v(radius) (input) the trust region radius. d times the step returned
+c has 2-norm v(radius) unless v(stppar) = 0.
+c v(stppar) (output) code telling how step was computed... 0 means a
+c full newton step. between 0 and 1 means v(stppar) of the
+c way from the newton to the relaxed newton step. between
+c 1 and 2 means a true double dogleg step, v(stppar) - 1 of
+c the way from the relaxed newton to the cauchy step.
+c greater than 2 means 1 / (v(stppar) - 1) times the cauchy
+c step.
+c
+c------------------------------- notes -------------------------------
+c
+c *** algorithm notes ***
+c
+c let g and h be the current gradient and hessian approxima-
+c tion respectively and let d be the current scale vector. this
+c routine assumes dig = diag(d)**-2 * g and nwtstp = h**-1 * g.
+c the step computed is the same one would get by replacing g and h
+c by diag(d)**-1 * g and diag(d)**-1 * h * diag(d)**-1,
+c computing step, and translating step back to the original
+c variables, i.e., premultiplying it by diag(d)**-1.
+c
+c *** references ***
+c
+c 1. dennis, j.e., and mei, h.h.w. (1979), two new unconstrained opti-
+c mization algorithms which use function and gradient
+c values, j. optim. theory applic. 28, pp. 453-482.
+c 2. powell, m.j.d. (1970), a hybrid method for non-linear equations,
+c in numerical methods for non-linear equations, edited by
+c p. rabinowitz, gordon and breach, london.
+c
+c *** general ***
+c
+c coded by david m. gay.
+c this subroutine was written in connection with research supported
+c by the national science foundation under grants mcs-7600324 and
+c mcs-7906671.
+c
+c------------------------ external quantities ------------------------
+c
+c *** functions and subroutines called ***
+c
+ external dotprd, v2norm
+ double precision dotprd, v2norm
+c
+c dotprd... returns inner product of two vectors.
+c v2norm... returns 2-norm of a vector.
+c
+c *** intrinsic functions ***
+c/+
+ double precision dsqrt
+c/
+c-------------------------- local variables --------------------------
+c
+ integer i
+ double precision cfact, cnorm, ctrnwt, ghinvg, femnsq, gnorm,
+ 1 nwtnrm, relax, rlambd, t, t1, t2
+ double precision half, one, two, zero
+c
+c *** v subscripts ***
+c
+ integer bias, dgnorm, dstnrm, dst0, grdfac, gthg, gtstep,
+ 1 nreduc, nwtfac, preduc, radius, stppar
+c
+c *** data initializations ***
+c
+c/6
+c data half/0.5d+0/, one/1.d+0/, two/2.d+0/, zero/0.d+0/
+c/7
+ parameter (half=0.5d+0, one=1.d+0, two=2.d+0, zero=0.d+0)
+c/
+c
+c/6
+c data bias/43/, dgnorm/1/, dstnrm/2/, dst0/3/, grdfac/45/,
+c 1 gthg/44/, gtstep/4/, nreduc/6/, nwtfac/46/, preduc/7/,
+c 2 radius/8/, stppar/5/
+c/7
+ parameter (bias=43, dgnorm=1, dstnrm=2, dst0=3, grdfac=45,
+ 1 gthg=44, gtstep=4, nreduc=6, nwtfac=46, preduc=7,
+ 2 radius=8, stppar=5)
+c/
+c
+c+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++
+c
+ nwtnrm = v(dst0)
+ rlambd = one
+ if (nwtnrm .gt. zero) rlambd = v(radius) / nwtnrm
+ gnorm = v(dgnorm)
+ ghinvg = two * v(nreduc)
+ v(grdfac) = zero
+ v(nwtfac) = zero
+ if (rlambd .lt. one) go to 30
+c
+c *** the newton step is inside the trust region ***
+c
+ v(stppar) = zero
+ v(dstnrm) = nwtnrm
+ v(gtstep) = -ghinvg
+ v(preduc) = v(nreduc)
+ v(nwtfac) = -one
+ do 20 i = 1, n
+ 20 step(i) = -nwtstp(i)
+ go to 999
+c
+ 30 v(dstnrm) = v(radius)
+ cfact = (gnorm / v(gthg))**2
+c *** cauchy step = -cfact * g.
+ cnorm = gnorm * cfact
+ relax = one - v(bias) * (one - gnorm*cnorm/ghinvg)
+ if (rlambd .lt. relax) go to 50
+c
+c *** step is between relaxed newton and full newton steps ***
+c
+ v(stppar) = one - (rlambd - relax) / (one - relax)
+ t = -rlambd
+ v(gtstep) = t * ghinvg
+ v(preduc) = rlambd * (one - half*rlambd) * ghinvg
+ v(nwtfac) = t
+ do 40 i = 1, n
+ 40 step(i) = t * nwtstp(i)
+ go to 999
+c
+ 50 if (cnorm .lt. v(radius)) go to 70
+c
+c *** the cauchy step lies outside the trust region --
+c *** step = scaled cauchy step ***
+c
+ t = -v(radius) / gnorm
+ v(grdfac) = t
+ v(stppar) = one + cnorm / v(radius)
+ v(gtstep) = -v(radius) * gnorm
+ v(preduc) = v(radius)*(gnorm - half*v(radius)*(v(gthg)/gnorm)**2)
+ do 60 i = 1, n
+ 60 step(i) = t * dig(i)
+ go to 999
+c
+c *** compute dogleg step between cauchy and relaxed newton ***
+c *** femur = relaxed newton step minus cauchy step ***
+c
+ 70 ctrnwt = cfact * relax * ghinvg / gnorm
+c *** ctrnwt = inner prod. of cauchy and relaxed newton steps,
+c *** scaled by gnorm**-1.
+ t1 = ctrnwt - gnorm*cfact**2
+c *** t1 = inner prod. of femur and cauchy step, scaled by
+c *** gnorm**-1.
+ t2 = v(radius)*(v(radius)/gnorm) - gnorm*cfact**2
+ t = relax * nwtnrm
+ femnsq = (t/gnorm)*t - ctrnwt - t1
+c *** femnsq = square of 2-norm of femur, scaled by gnorm**-1.
+ t = t2 / (t1 + dsqrt(t1**2 + femnsq*t2))
+c *** dogleg step = cauchy step + t * femur.
+ t1 = (t - one) * cfact
+ v(grdfac) = t1
+ t2 = -t * relax
+ v(nwtfac) = t2
+ v(stppar) = two - t
+ v(gtstep) = t1*gnorm**2 + t2*ghinvg
+ v(preduc) = -t1*gnorm * ((t2 + one)*gnorm)
+ 1 - t2 * (one + half*t2)*ghinvg
+ 2 - half * (v(gthg)*t1)**2
+ do 80 i = 1, n
+ 80 step(i) = t1*dig(i) + t2*nwtstp(i)
+c
+ 999 return
+c *** last line of dbdog follows ***
+ end
+ subroutine ltvmul(n, x, l, y)
+c
+c *** compute x = (l**t)*y, where l is an n x n lower
+c *** triangular matrix stored compactly by rows. x and y may
+c *** occupy the same storage. ***
+c
+ integer n
+cal double precision x(n), l(1), y(n)
+ double precision x(n), l(n*(n+1)/2), y(n)
+c dimension l(n*(n+1)/2)
+ integer i, ij, i0, j
+ double precision yi, zero
+c/6
+c data zero/0.d+0/
+c/7
+ parameter (zero=0.d+0)
+c/
+c
+ i0 = 0
+ do 20 i = 1, n
+ yi = y(i)
+ x(i) = zero
+ do 10 j = 1, i
+ ij = i0 + j
+ x(j) = x(j) + yi*l(ij)
+ 10 continue
+ i0 = i0 + i
+ 20 continue
+ 999 return
+c *** last card of ltvmul follows ***
+ end
+ subroutine lupdat(beta, gamma, l, lambda, lplus, n, w, z)
+c
+c *** compute lplus = secant update of l ***
+c
+c *** parameter declarations ***
+c
+ integer n
+cal double precision beta(n), gamma(n), l(1), lambda(n), lplus(1),
+ double precision beta(n), gamma(n), l(n*(n+1)/2), lambda(n),
+ 1 lplus(n*(n+1)/2),w(n), z(n)
+c dimension l(n*(n+1)/2), lplus(n*(n+1)/2)
+c
+c-------------------------- parameter usage --------------------------
+c
+c beta = scratch vector.
+c gamma = scratch vector.
+c l (input) lower triangular matrix, stored rowwise.
+c lambda = scratch vector.
+c lplus (output) lower triangular matrix, stored rowwise, which may
+c occupy the same storage as l.
+c n (input) length of vector parameters and order of matrices.
+c w (input, destroyed on output) right singular vector of rank 1
+c correction to l.
+c z (input, destroyed on output) left singular vector of rank 1
+c correction to l.
+c
+c------------------------------- notes -------------------------------
+c
+c *** application and usage restrictions ***
+c
+c this routine updates the cholesky factor l of a symmetric
+c positive definite matrix to which a secant update is being
+c applied -- it computes a cholesky factor lplus of
+c l * (i + z*w**t) * (i + w*z**t) * l**t. it is assumed that w
+c and z have been chosen so that the updated matrix is strictly
+c positive definite.
+c
+c *** algorithm notes ***
+c
+c this code uses recurrence 3 of ref. 1 (with d(j) = 1 for all j)
+c to compute lplus of the form l * (i + z*w**t) * q, where q
+c is an orthogonal matrix that makes the result lower triangular.
+c lplus may have some negative diagonal elements.
+c
+c *** references ***
+c
+c 1. goldfarb, d. (1976), factorized variable metric methods for uncon-
+c strained optimization, math. comput. 30, pp. 796-811.
+c
+c *** general ***
+c
+c coded by david m. gay (fall 1979).
+c this subroutine was written in connection with research supported
+c by the national science foundation under grants mcs-7600324 and
+c mcs-7906671.
+c
+c------------------------ external quantities ------------------------
+c
+c *** intrinsic functions ***
+c/+
+ double precision dsqrt
+c/
+c-------------------------- local variables --------------------------
+c
+ integer i, ij, j, jj, jp1, k, nm1, np1
+ double precision a, b, bj, eta, gj, lj, lij, ljj, nu, s, theta,
+ 1 wj, zj
+ double precision one, zero
+c
+c *** data initializations ***
+c
+c/6
+c data one/1.d+0/, zero/0.d+0/
+c/7
+ parameter (one=1.d+0, zero=0.d+0)
+c/
+c
+c+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++
+c
+ nu = one
+ eta = zero
+ if (n .le. 1) go to 30
+ nm1 = n - 1
+c
+c *** temporarily store s(j) = sum over k = j+1 to n of w(k)**2 in
+c *** lambda(j).
+c
+ s = zero
+ do 10 i = 1, nm1
+ j = n - i
+ s = s + w(j+1)**2
+ lambda(j) = s
+ 10 continue
+c
+c *** compute lambda, gamma, and beta by goldfarb*s recurrence 3.
+c
+ do 20 j = 1, nm1
+ wj = w(j)
+ a = nu*z(j) - eta*wj
+ theta = one + a*wj
+ s = a*lambda(j)
+ lj = dsqrt(theta**2 + a*s)
+ if (theta .gt. zero) lj = -lj
+ lambda(j) = lj
+ b = theta*wj + s
+ gamma(j) = b * nu / lj
+ beta(j) = (a - b*eta) / lj
+ nu = -nu / lj
+ eta = -(eta + (a**2)/(theta - lj)) / lj
+ 20 continue
+ 30 lambda(n) = one + (nu*z(n) - eta*w(n))*w(n)
+c
+c *** update l, gradually overwriting w and z with l*w and l*z.
+c
+ np1 = n + 1
+ jj = n * (n + 1) / 2
+ do 60 k = 1, n
+ j = np1 - k
+ lj = lambda(j)
+ ljj = l(jj)
+ lplus(jj) = lj * ljj
+ wj = w(j)
+ w(j) = ljj * wj
+ zj = z(j)
+ z(j) = ljj * zj
+ if (k .eq. 1) go to 50
+ bj = beta(j)
+ gj = gamma(j)
+ ij = jj + j
+ jp1 = j + 1
+ do 40 i = jp1, n
+ lij = l(ij)
+ lplus(ij) = lj*lij + bj*w(i) + gj*z(i)
+ w(i) = w(i) + lij*wj
+ z(i) = z(i) + lij*zj
+ ij = ij + i
+ 40 continue
+ 50 jj = jj - j
+ 60 continue
+c
+ 999 return
+c *** last card of lupdat follows ***
+ end
+ subroutine lvmul(n, x, l, y)
+c
+c *** compute x = l*y, where l is an n x n lower triangular
+c *** matrix stored compactly by rows. x and y may occupy the same
+c *** storage. ***
+c
+ integer n
+cal double precision x(n), l(1), y(n)
+ double precision x(n), l(n*(n+1)/2), y(n)
+c dimension l(n*(n+1)/2)
+ integer i, ii, ij, i0, j, np1
+ double precision t, zero
+c/6
+c data zero/0.d+0/
+c/7
+ parameter (zero=0.d+0)
+c/
+c
+ np1 = n + 1
+ i0 = n*(n+1)/2
+ do 20 ii = 1, n
+ i = np1 - ii
+ i0 = i0 - i
+ t = zero
+ do 10 j = 1, i
+ ij = i0 + j
+ t = t + l(ij)*y(j)
+ 10 continue
+ x(i) = t
+ 20 continue
+ 999 return
+c *** last card of lvmul follows ***
+ end
+ subroutine vvmulp(n, x, y, z, k)
+c
+c *** set x(i) = y(i) * z(i)**k, 1 .le. i .le. n (for k = 1 or -1) ***
+c
+ integer n, k
+ double precision x(n), y(n), z(n)
+ integer i
+c
+ if (k .ge. 0) go to 20
+ do 10 i = 1, n
+ 10 x(i) = y(i) / z(i)
+ go to 999
+c
+ 20 do 30 i = 1, n
+ 30 x(i) = y(i) * z(i)
+ 999 return
+c *** last card of vvmulp follows ***
+ end
+ subroutine wzbfgs (l, n, s, w, y, z)
+c
+c *** compute y and z for lupdat corresponding to bfgs update.
+c
+ integer n
+cal double precision l(1), s(n), w(n), y(n), z(n)
+ double precision l(n*(n+1)/2), s(n), w(n), y(n), z(n)
+c dimension l(n*(n+1)/2)
+c
+c-------------------------- parameter usage --------------------------
+c
+c l (i/o) cholesky factor of hessian, a lower triang. matrix stored
+c compactly by rows.
+c n (input) order of l and length of s, w, y, z.
+c s (input) the step just taken.
+c w (output) right singular vector of rank 1 correction to l.
+c y (input) change in gradients corresponding to s.
+c z (output) left singular vector of rank 1 correction to l.
+c
+c------------------------------- notes -------------------------------
+c
+c *** algorithm notes ***
+c
+c when s is computed in certain ways, e.g. by gqtstp or
+c dbldog, it is possible to save n**2/2 operations since (l**t)*s
+c or l*(l**t)*s is then known.
+c if the bfgs update to l*(l**t) would reduce its determinant to
+c less than eps times its old value, then this routine in effect
+c replaces y by theta*y + (1 - theta)*l*(l**t)*s, where theta
+c (between 0 and 1) is chosen to make the reduction factor = eps.
+c
+c *** general ***
+c
+c coded by david m. gay (fall 1979).
+c this subroutine was written in connection with research supported
+c by the national science foundation under grants mcs-7600324 and
+c mcs-7906671.
+c
+c------------------------ external quantities ------------------------
+c
+c *** functions and subroutines called ***
+c
+ external dotprd, livmul, ltvmul
+ double precision dotprd
+c dotprd returns inner product of two vectors.
+c livmul multiplies l**-1 times a vector.
+c ltvmul multiplies l**t times a vector.
+c
+c *** intrinsic functions ***
+c/+
+ double precision dsqrt
+c/
+c-------------------------- local variables --------------------------
+c
+ integer i
+ double precision cs, cy, eps, epsrt, one, shs, ys, theta
+c
+c *** data initializations ***
+c
+c/6
+c data eps/0.1d+0/, one/1.d+0/
+c/7
+ parameter (eps=0.1d+0, one=1.d+0)
+c/
+c
+c+++++++++++++++++++++++++++++++ body ++++++++++++++++++++++++++++++++
+c
+ call ltvmul(n, w, l, s)
+ shs = dotprd(n, w, w)
+ ys = dotprd(n, y, s)
+ if (ys .ge. eps*shs) go to 10
+ theta = (one - eps) * shs / (shs - ys)
+ epsrt = dsqrt(eps)
+ cy = theta / (shs * epsrt)
+ cs = (one + (theta-one)/epsrt) / shs
+ go to 20
+ 10 cy = one / (dsqrt(ys) * dsqrt(shs))
+ cs = one / shs
+ 20 call livmul(n, z, l, y)
+ do 30 i = 1, n
+ 30 z(i) = cy * z(i) - cs * w(i)
+c
+ 999 return
+c *** last card of wzbfgs follows ***
+ end
--- /dev/null
+c
+c
+c ###################################################
+c ## COPYRIGHT (C) 1996 by Jay William Ponder ##
+c ## All Rights Reserved ##
+c ###################################################
+c
+c ################################################################
+c ## ##
+c ## subroutine surfatom -- exposed surface area of an atom ##
+c ## ##
+c ################################################################
+c
+c
+c "surfatom" performs an analytical computation of the surface
+c area of a specified atom; a simplified version of "surface"
+c
+c literature references:
+c
+c T. J. Richmond, "Solvent Accessible Surface Area and
+c Excluded Volume in Proteins", Journal of Molecular Biology,
+c 178, 63-89 (1984)
+c
+c L. Wesson and D. Eisenberg, "Atomic Solvation Parameters
+c Applied to Molecular Dynamics of Proteins in Solution",
+c Protein Science, 1, 227-235 (1992)
+c
+c variables and parameters:
+c
+c ir number of atom for which area is desired
+c area accessible surface area of the atom
+c radius radii of each of the individual atoms
+c
+c
+ subroutine surfatom (ir,area,radius)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'sizes.i'
+ include 'COMMON.GEO'
+ include 'COMMON.IOUNITS'
+ integer nres,nsup,nstart_sup
+ double precision c,dc,dc_old,d_c_work,xloc,xrot,dc_norm
+ common /chain/ c(3,maxres2+2),dc(3,0:maxres2),dc_old(3,0:maxres2),
+ & xloc(3,maxres),xrot(3,maxres),dc_norm(3,0:maxres2),
+ & dc_work(MAXRES6),nres,nres0
+ integer maxarc
+ parameter (maxarc=300)
+ integer i,j,k,m
+ integer ii,ib,jb
+ integer io,ir
+ integer mi,ni,narc
+ integer key(maxarc)
+ integer intag(maxarc)
+ integer intag1(maxarc)
+ real*8 area,arcsum
+ real*8 arclen,exang
+ real*8 delta,delta2
+ real*8 eps,rmove
+ real*8 xr,yr,zr
+ real*8 rr,rrsq
+ real*8 rplus,rminus
+ real*8 axx,axy,axz
+ real*8 ayx,ayy
+ real*8 azx,azy,azz
+ real*8 uxj,uyj,uzj
+ real*8 tx,ty,tz
+ real*8 txb,tyb,td
+ real*8 tr2,tr,txr,tyr
+ real*8 tk1,tk2
+ real*8 thec,the,t,tb
+ real*8 txk,tyk,tzk
+ real*8 t1,ti,tf,tt
+ real*8 txj,tyj,tzj
+ real*8 ccsq,cc,xysq
+ real*8 bsqk,bk,cosine
+ real*8 dsqj,gi,pix2
+ real*8 therk,dk,gk
+ real*8 risqk,rik
+ real*8 radius(maxatm)
+ real*8 ri(maxarc),risq(maxarc)
+ real*8 ux(maxarc),uy(maxarc),uz(maxarc)
+ real*8 xc(maxarc),yc(maxarc),zc(maxarc)
+ real*8 xc1(maxarc),yc1(maxarc),zc1(maxarc)
+ real*8 dsq(maxarc),bsq(maxarc)
+ real*8 dsq1(maxarc),bsq1(maxarc)
+ real*8 arci(maxarc),arcf(maxarc)
+ real*8 ex(maxarc),lt(maxarc),gr(maxarc)
+ real*8 b(maxarc),b1(maxarc),bg(maxarc)
+ real*8 kent(maxarc),kout(maxarc)
+ real*8 ther(maxarc)
+ logical moved,top
+ logical omit(maxarc)
+c
+c
+c zero out the surface area for the sphere of interest
+c
+ area = 0.0d0
+c write (2,*) "ir",ir," radius",radius(ir)
+ if (radius(ir) .eq. 0.0d0) return
+c
+c set the overlap significance and connectivity shift
+c
+ pix2 = 2.0d0 * pi
+ delta = 1.0d-8
+ delta2 = delta * delta
+ eps = 1.0d-8
+ moved = .false.
+ rmove = 1.0d-8
+c
+c store coordinates and radius of the sphere of interest
+c
+ xr = c(1,ir)
+ yr = c(2,ir)
+ zr = c(3,ir)
+ rr = radius(ir)
+ rrsq = rr * rr
+c
+c initialize values of some counters and summations
+c
+ 10 continue
+ io = 0
+ jb = 0
+ ib = 0
+ arclen = 0.0d0
+ exang = 0.0d0
+c
+c test each sphere to see if it overlaps the sphere of interest
+c
+ do i = 1, 2*nres
+ if (i.eq.ir .or. radius(i).eq.0.0d0) goto 30
+ rplus = rr + radius(i)
+ tx = c(1,i) - xr
+ if (abs(tx) .ge. rplus) goto 30
+ ty = c(2,i) - yr
+ if (abs(ty) .ge. rplus) goto 30
+ tz = c(3,i) - zr
+ if (abs(tz) .ge. rplus) goto 30
+c
+c check for sphere overlap by testing distance against radii
+c
+ xysq = tx*tx + ty*ty
+ if (xysq .lt. delta2) then
+ tx = delta
+ ty = 0.0d0
+ xysq = delta2
+ end if
+ ccsq = xysq + tz*tz
+ cc = sqrt(ccsq)
+ if (rplus-cc .le. delta) goto 30
+ rminus = rr - radius(i)
+c
+c check to see if sphere of interest is completely buried
+c
+ if (cc-abs(rminus) .le. delta) then
+ if (rminus .le. 0.0d0) goto 170
+ goto 30
+ end if
+c
+c check for too many overlaps with sphere of interest
+c
+ if (io .ge. maxarc) then
+ write (iout,20)
+ 20 format (/,' SURFATOM -- Increase the Value of MAXARC')
+ stop
+ end if
+c
+c get overlap between current sphere and sphere of interest
+c
+ io = io + 1
+ xc1(io) = tx
+ yc1(io) = ty
+ zc1(io) = tz
+ dsq1(io) = xysq
+ bsq1(io) = ccsq
+ b1(io) = cc
+ gr(io) = (ccsq+rplus*rminus) / (2.0d0*rr*b1(io))
+ intag1(io) = i
+ omit(io) = .false.
+ 30 continue
+ end do
+c
+c case where no other spheres overlap the sphere of interest
+c
+ if (io .eq. 0) then
+ area = 4.0d0 * pi * rrsq
+ return
+ end if
+c
+c case where only one sphere overlaps the sphere of interest
+c
+ if (io .eq. 1) then
+ area = pix2 * (1.0d0 + gr(1))
+ area = mod(area,4.0d0*pi) * rrsq
+ return
+ end if
+c
+c case where many spheres intersect the sphere of interest;
+c sort the intersecting spheres by their degree of overlap
+c
+ call sort2 (io,gr,key)
+ do i = 1, io
+ k = key(i)
+ intag(i) = intag1(k)
+ xc(i) = xc1(k)
+ yc(i) = yc1(k)
+ zc(i) = zc1(k)
+ dsq(i) = dsq1(k)
+ b(i) = b1(k)
+ bsq(i) = bsq1(k)
+ end do
+c
+c get radius of each overlap circle on surface of the sphere
+c
+ do i = 1, io
+ gi = gr(i) * rr
+ bg(i) = b(i) * gi
+ risq(i) = rrsq - gi*gi
+ ri(i) = sqrt(risq(i))
+ ther(i) = 0.5d0*pi - asin(min(1.0d0,max(-1.0d0,gr(i))))
+ end do
+c
+c find boundary of inaccessible area on sphere of interest
+c
+ do k = 1, io-1
+ if (.not. omit(k)) then
+ txk = xc(k)
+ tyk = yc(k)
+ tzk = zc(k)
+ bk = b(k)
+ therk = ther(k)
+c
+c check to see if J circle is intersecting K circle;
+c get distance between circle centers and sum of radii
+c
+ do j = k+1, io
+ if (omit(j)) goto 60
+ cc = (txk*xc(j)+tyk*yc(j)+tzk*zc(j))/(bk*b(j))
+ cc = acos(min(1.0d0,max(-1.0d0,cc)))
+ td = therk + ther(j)
+c
+c check to see if circles enclose separate regions
+c
+ if (cc .ge. td) goto 60
+c
+c check for circle J completely inside circle K
+c
+ if (cc+ther(j) .lt. therk) goto 40
+c
+c check for circles that are essentially parallel
+c
+ if (cc .gt. delta) goto 50
+ 40 continue
+ omit(j) = .true.
+ goto 60
+c
+c check to see if sphere of interest is completely buried
+c
+ 50 continue
+ if (pix2-cc .le. td) goto 170
+ 60 continue
+ end do
+ end if
+ end do
+c
+c find T value of circle intersections
+c
+ do k = 1, io
+ if (omit(k)) goto 110
+ omit(k) = .true.
+ narc = 0
+ top = .false.
+ txk = xc(k)
+ tyk = yc(k)
+ tzk = zc(k)
+ dk = sqrt(dsq(k))
+ bsqk = bsq(k)
+ bk = b(k)
+ gk = gr(k) * rr
+ risqk = risq(k)
+ rik = ri(k)
+ therk = ther(k)
+c
+c rotation matrix elements
+c
+ t1 = tzk / (bk*dk)
+ axx = txk * t1
+ axy = tyk * t1
+ axz = dk / bk
+ ayx = tyk / dk
+ ayy = txk / dk
+ azx = txk / bk
+ azy = tyk / bk
+ azz = tzk / bk
+ do j = 1, io
+ if (.not. omit(j)) then
+ txj = xc(j)
+ tyj = yc(j)
+ tzj = zc(j)
+c
+c rotate spheres so K vector colinear with z-axis
+c
+ uxj = txj*axx + tyj*axy - tzj*axz
+ uyj = tyj*ayy - txj*ayx
+ uzj = txj*azx + tyj*azy + tzj*azz
+ cosine = min(1.0d0,max(-1.0d0,uzj/b(j)))
+ if (acos(cosine) .lt. therk+ther(j)) then
+ dsqj = uxj*uxj + uyj*uyj
+ tb = uzj*gk - bg(j)
+ txb = uxj * tb
+ tyb = uyj * tb
+ td = rik * dsqj
+ tr2 = risqk*dsqj - tb*tb
+ tr2 = max(eps,tr2)
+ tr = sqrt(tr2)
+ txr = uxj * tr
+ tyr = uyj * tr
+c
+c get T values of intersection for K circle
+c
+ tb = (txb+tyr) / td
+ tb = min(1.0d0,max(-1.0d0,tb))
+ tk1 = acos(tb)
+ if (tyb-txr .lt. 0.0d0) tk1 = pix2 - tk1
+ tb = (txb-tyr) / td
+ tb = min(1.0d0,max(-1.0d0,tb))
+ tk2 = acos(tb)
+ if (tyb+txr .lt. 0.0d0) tk2 = pix2 - tk2
+ thec = (rrsq*uzj-gk*bg(j)) / (rik*ri(j)*b(j))
+ if (abs(thec) .lt. 1.0d0) then
+ the = -acos(thec)
+ else if (thec .ge. 1.0d0) then
+ the = 0.0d0
+ else if (thec .le. -1.0d0) then
+ the = -pi
+ end if
+c
+c see if "tk1" is entry or exit point; check t=0 point;
+c "ti" is exit point, "tf" is entry point
+c
+ cosine = min(1.0d0,max(-1.0d0,
+ & (uzj*gk-uxj*rik)/(b(j)*rr)))
+ if ((acos(cosine)-ther(j))*(tk2-tk1) .le. 0.0d0) then
+ ti = tk2
+ tf = tk1
+ else
+ ti = tk2
+ tf = tk1
+ end if
+ narc = narc + 1
+ if (narc .ge. maxarc) then
+ write (iout,70)
+ 70 format (/,' SURFATOM -- Increase the Value',
+ & ' of MAXARC')
+ stop
+ end if
+ if (tf .le. ti) then
+ arcf(narc) = tf
+ arci(narc) = 0.0d0
+ tf = pix2
+ lt(narc) = j
+ ex(narc) = the
+ top = .true.
+ narc = narc + 1
+ end if
+ arcf(narc) = tf
+ arci(narc) = ti
+ lt(narc) = j
+ ex(narc) = the
+ ux(j) = uxj
+ uy(j) = uyj
+ uz(j) = uzj
+ end if
+ end if
+ end do
+ omit(k) = .false.
+c
+c special case; K circle without intersections
+c
+ if (narc .le. 0) goto 90
+c
+c general case; sum up arclength and set connectivity code
+c
+ call sort2 (narc,arci,key)
+ arcsum = arci(1)
+ mi = key(1)
+ t = arcf(mi)
+ ni = mi
+ if (narc .gt. 1) then
+ do j = 2, narc
+ m = key(j)
+ if (t .lt. arci(j)) then
+ arcsum = arcsum + arci(j) - t
+ exang = exang + ex(ni)
+ jb = jb + 1
+ if (jb .ge. maxarc) then
+ write (iout,80)
+ 80 format (/,' SURFATOM -- Increase the Value',
+ & ' of MAXARC')
+ stop
+ end if
+ i = lt(ni)
+ kent(jb) = maxarc*i + k
+ i = lt(m)
+ kout(jb) = maxarc*k + i
+ end if
+ tt = arcf(m)
+ if (tt .ge. t) then
+ t = tt
+ ni = m
+ end if
+ end do
+ end if
+ arcsum = arcsum + pix2 - t
+ if (.not. top) then
+ exang = exang + ex(ni)
+ jb = jb + 1
+ i = lt(ni)
+ kent(jb) = maxarc*i + k
+ i = lt(mi)
+ kout(jb) = maxarc*k + i
+ end if
+ goto 100
+ 90 continue
+ arcsum = pix2
+ ib = ib + 1
+ 100 continue
+ arclen = arclen + gr(k)*arcsum
+ 110 continue
+ end do
+ if (arclen .eq. 0.0d0) goto 170
+ if (jb .eq. 0) goto 150
+c
+c find number of independent boundaries and check connectivity
+c
+ j = 0
+ do k = 1, jb
+ if (kout(k) .ne. 0) then
+ i = k
+ 120 continue
+ m = kout(i)
+ kout(i) = 0
+ j = j + 1
+ do ii = 1, jb
+ if (m .eq. kent(ii)) then
+ if (ii .eq. k) then
+ ib = ib + 1
+ if (j .eq. jb) goto 150
+ goto 130
+ end if
+ i = ii
+ goto 120
+ end if
+ end do
+ 130 continue
+ end if
+ end do
+ ib = ib + 1
+c
+c attempt to fix connectivity error by moving atom slightly
+c
+ if (moved) then
+ write (iout,140) ir
+ 140 format (/,' SURFATOM -- Connectivity Error at Atom',i6)
+ else
+ moved = .true.
+ xr = xr + rmove
+ yr = yr + rmove
+ zr = zr + rmove
+ goto 10
+ end if
+c
+c compute the exposed surface area for the sphere of interest
+c
+ 150 continue
+ area = ib*pix2 + exang + arclen
+ area = mod(area,4.0d0*pi) * rrsq
+c
+c attempt to fix negative area by moving atom slightly
+c
+ if (area .lt. 0.0d0) then
+ if (moved) then
+ write (iout,160) ir
+ 160 format (/,' SURFATOM -- Negative Area at Atom',i6)
+ else
+ moved = .true.
+ xr = xr + rmove
+ yr = yr + rmove
+ zr = zr + rmove
+ goto 10
+ end if
+ end if
+ 170 continue
+ return
+ end
--- /dev/null
+ subroutine test
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.DISTFIT'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.CONTROL'
+ include 'COMMON.FFIELD'
+ include 'COMMON.MINIM'
+ include 'COMMON.CHAIN'
+ double precision time0,time1
+ double precision energy(0:n_ene),ee
+ double precision var(maxvar),var1(maxvar)
+ integer j1,j2
+ logical debug,accepted
+ debug=.true.
+
+
+ call geom_to_var(nvar,var1)
+ call chainbuild
+ call etotal(energy(0))
+ etot=energy(0)
+ call rmsd(rms)
+ write(iout,*) 'etot=',0,etot,rms
+ call secondary2(.false.)
+
+ call write_pdb(0,'first structure',etot)
+
+ j1=13
+ j2=21
+ da=180.0*deg2rad
+
+
+
+ temp=3000.0d0
+ betbol=1.0D0/(1.9858D-3*temp)
+ jr=iran_num(j1,j2)
+ d=ran_number(-pi,pi)
+c phi(jr)=pinorm(phi(jr)+d)
+ call chainbuild
+ call etotal(energy(0))
+ etot0=energy(0)
+ call rmsd(rms)
+ write(iout,*) 'etot=',1,etot0,rms
+ call write_pdb(1,'perturb structure',etot0)
+
+ do i=2,500,2
+ jr=iran_num(j1,j2)
+ d=ran_number(-da,da)
+ phiold=phi(jr)
+ phi(jr)=pinorm(phi(jr)+d)
+ call chainbuild
+ call etotal(energy(0))
+ etot=energy(0)
+
+ if (etot.lt.etot0) then
+ accepted=.true.
+ else
+ accepted=.false.
+ xxr=ran_number(0.0D0,1.0D0)
+ xxh=betbol*(etot-etot0)
+ if (xxh.lt.50.0D0) then
+ xxh=dexp(-xxh)
+ if (xxh.gt.xxr) accepted=.true.
+ endif
+ endif
+ accepted=.true.
+c print *,etot0,etot,accepted
+ if (accepted) then
+ etot0=etot
+ call rmsd(rms)
+ write(iout,*) 'etot=',i,etot,rms
+ call write_pdb(i,'MC structure',etot)
+c minimize
+c call geom_to_var(nvar,var1)
+ call sc_move(2,nres-1,1,10d0,nft_sc,etot)
+ call geom_to_var(nvar,var)
+ call minimize(etot,var,iretcode,nfun)
+ write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun
+ call var_to_geom(nvar,var)
+ call chainbuild
+ call rmsd(rms)
+ write(iout,*) 'etot mcm=',i,etot,rms
+ call write_pdb(i+1,'MCM structure',etot)
+ call var_to_geom(nvar,var1)
+c --------
+ else
+ phi(jr)=phiold
+ endif
+ enddo
+
+c minimize
+c call sc_move(2,nres-1,1,10d0,nft_sc,etot)
+c call geom_to_var(nvar,var)
+c
+c call chainbuild
+c call write_pdb(998 ,'sc min',etot)
+c
+c call minimize(etot,var,iretcode,nfun)
+c write(iout,*)'------------------------------------------------'
+c write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun
+c
+c call var_to_geom(nvar,var)
+c call chainbuild
+c call write_pdb(999,'full min',etot)
+
+
+ return
+ end
+
+
+
+
+ subroutine test_local
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ double precision time0,time1
+ double precision energy(0:n_ene),ee
+ double precision varia(maxvar)
+c
+ call chainbuild
+c call geom_to_var(nvar,varia)
+ call write_pdb(1,'first structure',0d0)
+
+ call etotal(energy(0))
+ etot=energy(0)
+ write(iout,*) nnt,nct,etot
+
+ write(iout,*) 'calling sc_move'
+ call sc_move(nnt,nct,5,10d0,nft_sc,etot)
+ write(iout,*) nft_sc,etot
+ call write_pdb(2,'second structure',etot)
+
+ write(iout,*) 'calling local_move'
+ call local_move_init(.false.)
+ call local_move(24,29,20d0,50d0)
+ call chainbuild
+ call write_pdb(3,'third structure',etot)
+
+ write(iout,*) 'calling sc_move'
+ call sc_move(24,29,5,10d0,nft_sc,etot)
+ write(iout,*) nft_sc,etot
+ call write_pdb(2,'last structure',etot)
+
+
+ return
+ end
+
+ subroutine test_sc
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ double precision time0,time1
+ double precision energy(0:n_ene),ee
+ double precision varia(maxvar)
+c
+ call chainbuild
+c call geom_to_var(nvar,varia)
+ call write_pdb(1,'first structure',0d0)
+
+ call etotal(energy(0))
+ etot=energy(0)
+ write(iout,*) nnt,nct,etot
+
+ write(iout,*) 'calling sc_move'
+
+ call sc_move(nnt,nct,5,10d0,nft_sc,etot)
+ write(iout,*) nft_sc,etot
+ call write_pdb(2,'second structure',etot)
+
+ write(iout,*) 'calling sc_move 2nd time'
+
+ call sc_move(nnt,nct,5,1d0,nft_sc,etot)
+ write(iout,*) nft_sc,etot
+ call write_pdb(3,'last structure',etot)
+ return
+ end
+c--------------------------------------------------------
+ subroutine bgrow(bstrand,nbstrand,in,ind,new)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ integer bstrand(maxres/3,6)
+
+ ishift=iabs(bstrand(in,ind+4)-new)
+
+ print *,'bgrow',bstrand(in,ind+4),new,ishift
+
+ bstrand(in,ind)=new
+
+ if(ind.eq.1)then
+ bstrand(nbstrand,5)=bstrand(nbstrand,1)
+ do i=1,nbstrand-1
+ IF (bstrand(nbstrand,3).eq.bstrand(i,3)) THEN
+ if (bstrand(i,5).lt.bstrand(i,6)) then
+ bstrand(i,5)=bstrand(i,5)-ishift
+ else
+ bstrand(i,5)=bstrand(i,5)+ishift
+ endif
+ ENDIF
+ enddo
+ else
+ bstrand(nbstrand,6)=bstrand(nbstrand,2)
+ do i=1,nbstrand-1
+ IF (bstrand(nbstrand,3).eq.bstrand(i,3)) THEN
+ if (bstrand(i,6).lt.bstrand(i,5)) then
+ bstrand(i,6)=bstrand(i,6)-ishift
+ else
+ bstrand(i,6)=bstrand(i,6)+ishift
+ endif
+ ENDIF
+ enddo
+ endif
+
+
+ return
+ end
+
+
+c-------------------------------------------------
+
+ subroutine secondary(lprint)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.DISTFIT'
+
+ integer ncont,icont(2,maxres*maxres/2),isec(maxres,3)
+ logical lprint,not_done
+ real dcont(maxres*maxres/2),d
+ real rcomp /7.0/
+ real rbeta /5.2/
+ real ralfa /5.2/
+ real r310 /6.6/
+ double precision xpi(3),xpj(3)
+
+
+
+ call chainbuild
+cd call write_pdb(99,'sec structure',0d0)
+ ncont=0
+ nbfrag=0
+ nhfrag=0
+ do i=1,nres
+ isec(i,1)=0
+ isec(i,2)=0
+ isec(i,3)=0
+ enddo
+
+ do i=2,nres-3
+ do k=1,3
+ xpi(k)=0.5d0*(c(k,i-1)+c(k,i))
+ enddo
+ do j=i+2,nres
+ do k=1,3
+ xpj(k)=0.5d0*(c(k,j-1)+c(k,j))
+ enddo
+cd d = (c(1,i)-c(1,j))*(c(1,i)-c(1,j)) +
+cd & (c(2,i)-c(2,j))*(c(2,i)-c(2,j)) +
+cd & (c(3,i)-c(3,j))*(c(3,i)-c(3,j))
+cd print *,'CA',i,j,d
+ d = (xpi(1)-xpj(1))*(xpi(1)-xpj(1)) +
+ & (xpi(2)-xpj(2))*(xpi(2)-xpj(2)) +
+ & (xpi(3)-xpj(3))*(xpi(3)-xpj(3))
+ if ( d.lt.rcomp*rcomp) then
+ ncont=ncont+1
+ icont(1,ncont)=i
+ icont(2,ncont)=j
+ dcont(ncont)=sqrt(d)
+ endif
+ enddo
+ enddo
+ if (lprint) then
+ write (iout,*)
+ write (iout,'(a)') '#PP contact map distances:'
+ do i=1,ncont
+ write (iout,'(3i4,f10.5)')
+ & i,icont(1,i),icont(2,i),dcont(i)
+ enddo
+ endif
+
+c finding parallel beta
+cd write (iout,*) '------- looking for parallel beta -----------'
+ nbeta=0
+ nstrand=0
+ do i=1,ncont
+ i1=icont(1,i)
+ j1=icont(2,i)
+ if(dcont(i).le.rbeta .and. j1-i1.gt.4 .and.
+ & isec(i1,1).le.1.and.isec(j1,1).le.1.and.
+ & (isec(i1,2).ne.isec(j1,2).or.isec(i1,2)*isec(j1,2).eq.0).and.
+ & (isec(i1,3).ne.isec(j1,3).or.isec(i1,3)*isec(j1,3).eq.0).and.
+ & (isec(i1,2).ne.isec(j1,3).or.isec(i1,2)*isec(j1,3).eq.0).and.
+ & (isec(i1,3).ne.isec(j1,2).or.isec(i1,3)*isec(j1,2).eq.0)
+ & ) then
+ ii1=i1
+ jj1=j1
+cd write (iout,*) i1,j1,dcont(i)
+ not_done=.true.
+ do while (not_done)
+ i1=i1+1
+ j1=j1+1
+ do j=1,ncont
+ if (i1.eq.icont(1,j) .and. j1.eq.icont(2,j)
+ & .and. dcont(j).le.rbeta .and.
+ & isec(i1,1).le.1.and.isec(j1,1).le.1.and.
+ & (isec(i1,2).ne.isec(j1,2).or.isec(i1,2)*isec(j1,2).eq.0).and.
+ & (isec(i1,3).ne.isec(j1,3).or.isec(i1,3)*isec(j1,3).eq.0).and.
+ & (isec(i1,2).ne.isec(j1,3).or.isec(i1,2)*isec(j1,3).eq.0).and.
+ & (isec(i1,3).ne.isec(j1,2).or.isec(i1,3)*isec(j1,2).eq.0)
+ & ) goto 5
+ enddo
+ not_done=.false.
+ 5 continue
+cd write (iout,*) i1,j1,dcont(j),not_done
+ enddo
+ j1=j1-1
+ i1=i1-1
+ if (i1-ii1.gt.1) then
+ ii1=max0(ii1-1,1)
+ jj1=max0(jj1-1,1)
+ nbeta=nbeta+1
+ if(lprint)write(iout,*)'parallel beta',nbeta,ii1,i1,jj1,j1
+
+ nbfrag=nbfrag+1
+ bfrag(1,nbfrag)=ii1
+ bfrag(2,nbfrag)=i1
+ bfrag(3,nbfrag)=jj1
+ bfrag(4,nbfrag)=j1
+
+ do ij=ii1,i1
+ isec(ij,1)=isec(ij,1)+1
+ isec(ij,1+isec(ij,1))=nbeta
+ enddo
+ do ij=jj1,j1
+ isec(ij,1)=isec(ij,1)+1
+ isec(ij,1+isec(ij,1))=nbeta
+ enddo
+
+ if(lprint) then
+ nstrand=nstrand+1
+ if (nbeta.le.9) then
+ write(12,'(a18,i1,a9,i3,a2,i3,a1)')
+ & "DefPropRes 'strand",nstrand,
+ & "' 'num = ",ii1-1,"..",i1-1,"'"
+ else
+ write(12,'(a18,i2,a9,i3,a2,i3,a1)')
+ & "DefPropRes 'strand",nstrand,
+ & "' 'num = ",ii1-1,"..",i1-1,"'"
+ endif
+ nstrand=nstrand+1
+ if (nbeta.le.9) then
+ write(12,'(a18,i1,a9,i3,a2,i3,a1)')
+ & "DefPropRes 'strand",nstrand,
+ & "' 'num = ",jj1-1,"..",j1-1,"'"
+ else
+ write(12,'(a18,i2,a9,i3,a2,i3,a1)')
+ & "DefPropRes 'strand",nstrand,
+ & "' 'num = ",jj1-1,"..",j1-1,"'"
+ endif
+ write(12,'(a8,4i4)')
+ & "SetNeigh",ii1-1,i1-1,jj1-1,j1-1
+ endif
+ endif
+ endif
+ enddo
+
+c finding antiparallel beta
+cd write (iout,*) '--------- looking for antiparallel beta ---------'
+
+ do i=1,ncont
+ i1=icont(1,i)
+ j1=icont(2,i)
+ if (dcont(i).le.rbeta.and.
+ & isec(i1,1).le.1.and.isec(j1,1).le.1.and.
+ & (isec(i1,2).ne.isec(j1,2).or.isec(i1,2)*isec(j1,2).eq.0).and.
+ & (isec(i1,3).ne.isec(j1,3).or.isec(i1,3)*isec(j1,3).eq.0).and.
+ & (isec(i1,2).ne.isec(j1,3).or.isec(i1,2)*isec(j1,3).eq.0).and.
+ & (isec(i1,3).ne.isec(j1,2).or.isec(i1,3)*isec(j1,2).eq.0)
+ & ) then
+ ii1=i1
+ jj1=j1
+cd write (iout,*) i1,j1,dcont(i)
+
+ not_done=.true.
+ do while (not_done)
+ i1=i1+1
+ j1=j1-1
+ do j=1,ncont
+ if (i1.eq.icont(1,j).and.j1.eq.icont(2,j) .and.
+ & isec(i1,1).le.1.and.isec(j1,1).le.1.and.
+ & (isec(i1,2).ne.isec(j1,2).or.isec(i1,2)*isec(j1,2).eq.0).and.
+ & (isec(i1,3).ne.isec(j1,3).or.isec(i1,3)*isec(j1,3).eq.0).and.
+ & (isec(i1,2).ne.isec(j1,3).or.isec(i1,2)*isec(j1,3).eq.0).and.
+ & (isec(i1,3).ne.isec(j1,2).or.isec(i1,3)*isec(j1,2).eq.0)
+ & .and. dcont(j).le.rbeta ) goto 6
+ enddo
+ not_done=.false.
+ 6 continue
+cd write (iout,*) i1,j1,dcont(j),not_done
+ enddo
+ i1=i1-1
+ j1=j1+1
+ if (i1-ii1.gt.1) then
+ if(lprint)write (iout,*)'antiparallel beta',
+ & nbeta,ii1-1,i1,jj1,j1-1
+
+ nbfrag=nbfrag+1
+ bfrag(1,nbfrag)=max0(ii1-1,1)
+ bfrag(2,nbfrag)=i1
+ bfrag(3,nbfrag)=jj1
+ bfrag(4,nbfrag)=max0(j1-1,1)
+
+ nbeta=nbeta+1
+ iii1=max0(ii1-1,1)
+ do ij=iii1,i1
+ isec(ij,1)=isec(ij,1)+1
+ isec(ij,1+isec(ij,1))=nbeta
+ enddo
+ jjj1=max0(j1-1,1)
+ do ij=jjj1,jj1
+ isec(ij,1)=isec(ij,1)+1
+ isec(ij,1+isec(ij,1))=nbeta
+ enddo
+
+
+ if (lprint) then
+ nstrand=nstrand+1
+ if (nstrand.le.9) then
+ write(12,'(a18,i1,a9,i3,a2,i3,a1)')
+ & "DefPropRes 'strand",nstrand,
+ & "' 'num = ",ii1-2,"..",i1-1,"'"
+ else
+ write(12,'(a18,i2,a9,i3,a2,i3,a1)')
+ & "DefPropRes 'strand",nstrand,
+ & "' 'num = ",ii1-2,"..",i1-1,"'"
+ endif
+ nstrand=nstrand+1
+ if (nstrand.le.9) then
+ write(12,'(a18,i1,a9,i3,a2,i3,a1)')
+ & "DefPropRes 'strand",nstrand,
+ & "' 'num = ",j1-2,"..",jj1-1,"'"
+ else
+ write(12,'(a18,i2,a9,i3,a2,i3,a1)')
+ & "DefPropRes 'strand",nstrand,
+ & "' 'num = ",j1-2,"..",jj1-1,"'"
+ endif
+ write(12,'(a8,4i4)')
+ & "SetNeigh",ii1-2,i1-1,jj1-1,j1-2
+ endif
+ endif
+ endif
+ enddo
+
+ if (nstrand.gt.0.and.lprint) then
+ write(12,'(a27,$)') "DefPropRes 'sheet' 'strand1"
+ do i=2,nstrand
+ if (i.le.9) then
+ write(12,'(a9,i1,$)') " | strand",i
+ else
+ write(12,'(a9,i2,$)') " | strand",i
+ endif
+ enddo
+ write(12,'(a1)') "'"
+ endif
+
+
+c finding alpha or 310 helix
+
+ nhelix=0
+ do i=1,ncont
+ i1=icont(1,i)
+ j1=icont(2,i)
+ if (j1.eq.i1+3.and.dcont(i).le.r310
+ & .or.j1.eq.i1+4.and.dcont(i).le.ralfa ) then
+cd if (j1.eq.i1+3) write (iout,*) "found 1-4 ",i1,j1,dcont(i)
+cd if (j1.eq.i1+4) write (iout,*) "found 1-5 ",i1,j1,dcont(i)
+ ii1=i1
+ jj1=j1
+ if (isec(ii1,1).eq.0) then
+ not_done=.true.
+ else
+ not_done=.false.
+ endif
+ do while (not_done)
+ i1=i1+1
+ j1=j1+1
+ do j=1,ncont
+ if (i1.eq.icont(1,j) .and. j1.eq.icont(2,j)) goto 10
+ enddo
+ not_done=.false.
+ 10 continue
+cd write (iout,*) i1,j1,not_done
+ enddo
+ j1=j1-1
+ if (j1-ii1.gt.4) then
+ nhelix=nhelix+1
+cd write (iout,*)'helix',nhelix,ii1,j1
+
+ nhfrag=nhfrag+1
+ hfrag(1,nhfrag)=ii1
+ hfrag(2,nhfrag)=max0(j1-1,1)
+
+ do ij=ii1,j1
+ isec(ij,1)=-1
+ enddo
+ if (lprint) then
+ write (iout,'(a6,i3,2i4)') "Helix",nhelix,ii1-1,j1-2
+ if (nhelix.le.9) then
+ write(12,'(a17,i1,a9,i3,a2,i3,a1)')
+ & "DefPropRes 'helix",nhelix,
+ & "' 'num = ",ii1-1,"..",j1-2,"'"
+ else
+ write(12,'(a17,i2,a9,i3,a2,i3,a1)')
+ & "DefPropRes 'helix",nhelix,
+ & "' 'num = ",ii1-1,"..",j1-2,"'"
+ endif
+ endif
+ endif
+ endif
+ enddo
+
+ if (nhelix.gt.0.and.lprint) then
+ write(12,'(a26,$)') "DefPropRes 'helix' 'helix1"
+ do i=2,nhelix
+ if (nhelix.le.9) then
+ write(12,'(a8,i1,$)') " | helix",i
+ else
+ write(12,'(a8,i2,$)') " | helix",i
+ endif
+ enddo
+ write(12,'(a1)') "'"
+ endif
+
+ if (lprint) then
+ write(12,'(a37)') "DefPropRes 'coil' '! (helix | sheet)'"
+ write(12,'(a20)') "XMacStand ribbon.mac"
+ endif
+
+
+ return
+ end
+c----------------------------------------------------------------------------
+
+ subroutine write_pdb(npdb,titelloc,ee)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ character*50 titelloc1
+ character*(*) titelloc
+ character*3 zahl
+ character*5 liczba5
+ double precision ee
+ integer npdb,ilen
+ external ilen
+
+ titelloc1=titelloc
+ lenpre=ilen(prefix)
+ if (npdb.lt.1000) then
+ call numstr(npdb,zahl)
+ open(ipdb,file=prefix(:lenpre)//'@@'//zahl//'.pdb')
+ else
+ if (npdb.lt.10000) then
+ write(liczba5,'(i1,i4)') 0,npdb
+ else
+ write(liczba5,'(i5)') npdb
+ endif
+ open(ipdb,file=prefix(:lenpre)//'@@'//liczba5//'.pdb')
+ endif
+ call pdbout(ee,titelloc1,ipdb)
+ close(ipdb)
+ return
+ end
+
+c--------------------------------------------------------
+ subroutine softreg
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.GEO'
+ include 'COMMON.CHAIN'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.VAR'
+ include 'COMMON.CONTROL'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.FFIELD'
+ include 'COMMON.MINIM'
+ include 'COMMON.INTERACT'
+c
+ include 'COMMON.DISTFIT'
+ integer iff(maxres)
+ double precision time0,time1
+ double precision energy(0:n_ene),ee
+ double precision var(maxvar)
+ integer ieval
+c
+ logical debug,ltest,fail
+ character*50 linia
+c
+ linia='test'
+ debug=.true.
+ in_pdb=0
+
+
+
+c------------------------
+c
+c freeze sec.elements
+c
+ do i=1,nres
+ mask_phi(i)=1
+ mask_theta(i)=1
+ mask_side(i)=1
+ iff(i)=0
+ enddo
+
+ do j=1,nbfrag
+ do i=bfrag(1,j),bfrag(2,j)
+ mask_phi(i)=0
+ mask_theta(i)=0
+ iff(i)=1
+ enddo
+ if (bfrag(3,j).le.bfrag(4,j)) then
+ do i=bfrag(3,j),bfrag(4,j)
+ mask_phi(i)=0
+ mask_theta(i)=0
+ iff(i)=1
+ enddo
+ else
+ do i=bfrag(4,j),bfrag(3,j)
+ mask_phi(i)=0
+ mask_theta(i)=0
+ iff(i)=1
+ enddo
+ endif
+ enddo
+ do j=1,nhfrag
+ do i=hfrag(1,j),hfrag(2,j)
+ mask_phi(i)=0
+ mask_theta(i)=0
+ iff(i)=1
+ enddo
+ enddo
+ mask_r=.true.
+
+
+
+ nhpb0=nhpb
+c
+c store dist. constrains
+c
+ do i=1,nres-3
+ do j=i+3,nres
+ if ( iff(i).eq.1.and.iff(j).eq.1 ) then
+ nhpb=nhpb+1
+ ihpb(nhpb)=i
+ jhpb(nhpb)=j
+ forcon(nhpb)=0.1
+ dhpb(nhpb)=DIST(i,j)
+ endif
+ enddo
+ enddo
+ call hpb_partition
+
+ if (debug) then
+ call chainbuild
+ call write_pdb(100+in_pdb,'input reg. structure',0d0)
+ endif
+
+
+ ipot0=ipot
+ maxmin0=maxmin
+ maxfun0=maxfun
+ wstrain0=wstrain
+ wang0=wang
+c
+c run soft pot. optimization
+c
+ ipot=6
+ wang=3.0
+ maxmin=2000
+ maxfun=4000
+ call geom_to_var(nvar,var)
+#ifdef MPI
+ time0=MPI_WTIME()
+#else
+ time0=tcpu()
+#endif
+ call minimize(etot,var,iretcode,nfun)
+
+ write(iout,*)'SUMSL return code is',iretcode,' eval SOFT',nfun
+#ifdef MPI
+ time1=MPI_WTIME()
+#else
+ time1=tcpu()
+#endif
+ write (iout,'(a,f6.2,f8.2,a)')' Time for soft min.',time1-time0,
+ & nfun/(time1-time0),' SOFT eval/s'
+ if (debug) then
+ call var_to_geom(nvar,var)
+ call chainbuild
+ call write_pdb(300+in_pdb,'soft structure',etot)
+ endif
+c
+c run full UNRES optimization with constrains and frozen 2D
+c the same variables as soft pot. optimizatio
+c
+ ipot=ipot0
+ wang=wang0
+ maxmin=maxmin0
+ maxfun=maxfun0
+#ifdef MPI
+ time0=MPI_WTIME()
+#else
+ time0=tcpu()
+#endif
+ call minimize(etot,var,iretcode,nfun)
+ write(iout,*)'SUMSL MASK DIST return code is',iretcode,
+ & ' eval ',nfun
+ ieval=nfun
+#ifdef MPI
+ time1=MPI_WTIME()
+#else
+ time1=tcpu()
+#endif
+ write (iout,'(a,f6.2,f8.2,a)')
+ & ' Time for mask dist min.',time1-time0,
+ & nfun/(time1-time0),' eval/s'
+ if (debug) then
+ call var_to_geom(nvar,var)
+ call chainbuild
+ call write_pdb(400+in_pdb,'mask & dist',etot)
+ endif
+c
+c switch off constrains and
+c run full UNRES optimization with frozen 2D
+c
+
+c
+c reset constrains
+c
+ nhpb_c=nhpb
+ nhpb=nhpb0
+ link_start=1
+ link_end=nhpb
+ wstrain=wstrain0
+
+#ifdef MPI
+ time0=MPI_WTIME()
+#else
+ time0=tcpu()
+#endif
+ call minimize(etot,var,iretcode,nfun)
+ write(iout,*)'SUMSL MASK return code is',iretcode,' eval ',nfun
+ ieval=ieval+nfun
+#ifdef MPI
+ time1=MPI_WTIME()
+#else
+ time1=tcpu()
+#endif
+ write (iout,'(a,f6.2,f8.2,a)')' Time for mask min.',time1-time0,
+ & nfun/(time1-time0),' eval/s'
+
+
+ if (debug) then
+ call var_to_geom(nvar,var)
+ call chainbuild
+ call write_pdb(500+in_pdb,'mask 2d frozen',etot)
+ endif
+
+ mask_r=.false.
+
+
+c
+c run full UNRES optimization with constrains and NO frozen 2D
+c
+
+ nhpb=nhpb_c
+ link_start=1
+ link_end=nhpb
+ maxfun=maxfun0/5
+
+ do ico=1,5
+
+ wstrain=wstrain0/ico
+#ifdef MPI
+ time0=MPI_WTIME()
+#else
+ time0=tcpu()
+#endif
+ call minimize(etot,var,iretcode,nfun)
+ write(iout,'(a10,f6.3,a14,i3,a6,i5)')
+ & ' SUMSL DIST',wstrain,' return code is',iretcode,
+ & ' eval ',nfun
+ ieval=nfun
+#ifdef MPI
+ time1=MPI_WTIME()
+#else
+ time1=tcpu()
+#endif
+ write (iout,'(a,f6.2,f8.2,a)')
+ & ' Time for dist min.',time1-time0,
+ & nfun/(time1-time0),' eval/s'
+ if (debug) then
+ call var_to_geom(nvar,var)
+ call chainbuild
+ call write_pdb(600+in_pdb+ico,'dist cons',etot)
+ endif
+
+ enddo
+c
+ nhpb=nhpb0
+ link_start=1
+ link_end=nhpb
+ wstrain=wstrain0
+ maxfun=maxfun0
+
+
+c
+ if (minim) then
+#ifdef MPI
+ time0=MPI_WTIME()
+#else
+ time0=tcpu()
+#endif
+ call minimize(etot,var,iretcode,nfun)
+ write(iout,*)'------------------------------------------------'
+ write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun,
+ & '+ DIST eval',ieval
+#ifdef MPI
+ time1=MPI_WTIME()
+#else
+ time1=tcpu()
+#endif
+ write (iout,'(a,f6.2,f8.2,a)')' Time for full min.',time1-time0,
+ & nfun/(time1-time0),' eval/s'
+
+
+ call var_to_geom(nvar,var)
+ call chainbuild
+ call write_pdb(999,'full min',etot)
+ endif
+
+ return
+ end
+
+
--- /dev/null
+ subroutine thread_seq
+C Thread the sequence through a database of known structures
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.CONTROL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DBASE'
+ include 'COMMON.INTERACT'
+ include 'COMMON.VAR'
+ include 'COMMON.THREAD'
+ include 'COMMON.FFIELD'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.HEADER'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.TIME1'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.MCM'
+ include 'COMMON.NAMES'
+#ifdef MPI
+ include 'COMMON.INFO'
+ integer ThreadId,ThreadType,Kwita
+#endif
+ double precision varia(maxvar)
+ double precision przes(3),obr(3,3)
+ double precision time_for_thread
+ logical found_pattern,non_conv
+ character*32 head_pdb
+ double precision energia(0:n_ene)
+ n_ene_comp=nprint_ene
+C
+C Body
+C
+#ifdef MPI
+ if (me.eq.king) then
+ do i=1,nctasks
+ nsave_part(i)=0
+ enddo
+ endif
+ nacc_tot=0
+#endif
+ Kwita=0
+ close(igeom)
+ close(ipdb)
+ close(istat)
+ do i=1,maxthread
+ do j=1,14
+ ener0(j,i)=0.0D0
+ ener(j,i)=0.0D0
+ enddo
+ enddo
+ nres0=nct-nnt+1
+ ave_time_for_thread=0.0D0
+ max_time_for_thread=0.0D0
+cd print *,'nthread=',nthread,' nseq=',nseq,' nres0=',nres0
+ nthread=nexcl+nthread
+ do ithread=1,nthread
+ found_pattern=.false.
+ itrial=0
+ do while (.not.found_pattern)
+ itrial=itrial+1
+ if (itrial.gt.1000) then
+ write (iout,'(/a/)') 'Too many attempts to find pattern.'
+ nthread=ithread-1
+#ifdef MPI
+ call recv_stop_sig(Kwita)
+ call send_stop_sig(-3)
+#endif
+ goto 777
+ endif
+C Find long enough chain in the database
+ ii=iran_num(1,nseq)
+ nres_t=nres_base(1,ii)
+C Select the starting position to thread.
+ print *,'nseq',nseq,' ii=',ii,' nres_t=',
+ & nres_t,' nres0=',nres0
+ if (nres_t.ge.nres0) then
+ ist=iran_num(0,nres_t-nres0)
+#ifdef MPI
+ if (Kwita.eq.0) call recv_stop_sig(Kwita)
+ if (Kwita.lt.0) then
+ write (iout,*) 'Stop signal received. Terminating.'
+ write (*,*) 'Stop signal received. Terminating.'
+ nthread=ithread-1
+ write (*,*) 'ithread=',ithread,' nthread=',nthread
+ goto 777
+ endif
+ call pattern_receive
+#endif
+ do i=1,nexcl
+ if (iexam(1,i).eq.ii .and. iexam(2,i).eq.ist) goto 10
+ enddo
+ found_pattern=.true.
+ endif
+C If this point is reached, the pattern has not yet been examined.
+ 10 continue
+c print *,'found_pattern:',found_pattern
+ enddo
+ nexcl=nexcl+1
+ iexam(1,nexcl)=ii
+ iexam(2,nexcl)=ist
+#ifdef MPI
+ if (Kwita.eq.0) call recv_stop_sig(Kwita)
+ if (Kwita.lt.0) then
+ write (iout,*) 'Stop signal received. Terminating.'
+ nthread=ithread-1
+ write (*,*) 'ithread=',ithread,' nthread=',nthread
+ goto 777
+ endif
+ call pattern_send
+#endif
+ ipatt(1,ithread)=ii
+ ipatt(2,ithread)=ist
+#ifdef MPI
+ write (iout,'(/80(1h*)/a,i4,a,i5,2a,i3,a,i3,a,i3/)')
+ & 'Processor:',me,' Attempt:',ithread,
+ & ' pattern: ',str_nam(ii),nres_base(2,ii),':',nres_base(3,ii),
+ & ' start at res.',ist+1
+ write (*,'(a,i4,a,i5,2a,i3,a,i3,a,i3)') 'Processor:',me,
+ & ' Attempt:',ithread,
+ & ' pattern: ',str_nam(ii),nres_base(2,ii),':',nres_base(3,ii),
+ & ' start at res.',ist+1
+#else
+ write (iout,'(/80(1h*)/a,i5,2a,i3,a,i3,a,i3/)')
+ & 'Attempt:',ithread,
+ & ' pattern: ',str_nam(ii),nres_base(2,ii),':',nres_base(3,ii),
+ & ' start at res.',ist+1
+ write (*,'(a,i5,2a,i3,a,i3,a,i3)')
+ & 'Attempt:',ithread,
+ & ' pattern: ',str_nam(ii),nres_base(2,ii),':',nres_base(3,ii),
+ & ' start at res.',ist+1
+#endif
+ ipattern=ii
+C Copy coordinates from the database.
+ ist=ist-(nnt-1)
+ do i=nnt,nct
+ do j=1,3
+ c(j,i)=cart_base(j,i+ist,ii)
+c cref(j,i)=c(j,i)
+ enddo
+cd write (iout,'(a,i4,3f10.5)') restyp(itype(i)),i,(c(j,i),j=1,3)
+ enddo
+cd call fitsq(rms,c(1,nnt),cref(1,nnt),nct-nnt+1,przes,obr,
+cd non_conv)
+cd write (iout,'(a,f10.5)')
+cd & 'Initial RMS deviation from reference structure:',rms
+ if (itype(nres).eq.21) then
+ do j=1,3
+ dcj=c(j,nres-2)-c(j,nres-3)
+ c(j,nres)=c(j,nres-1)+dcj
+ c(j,2*nres)=c(j,nres)
+ enddo
+ endif
+ if (itype(1).eq.21) then
+ do j=1,3
+ dcj=c(j,4)-c(j,3)
+ c(j,1)=c(j,2)-dcj
+ c(j,nres+1)=c(j,1)
+ enddo
+ endif
+ call int_from_cart(.false.,.false.)
+cd print *,'Exit INT_FROM_CART.'
+cd print *,'nhpb=',nhpb
+ do i=nss+1,nhpb
+ ii=ihpb(i)
+ jj=jhpb(i)
+ dhpb(i)=dist(ii,jj)
+c write (iout,'(2i5,2f10.5)') ihpb(i),jhpb(i),dhpb(i),forcon(i)
+ enddo
+c stop 'End generate'
+C Generate SC conformations.
+ call sc_conf
+c call intout
+#ifdef MPI
+cd print *,'Processor:',me,': exit GEN_SIDE.'
+#else
+cd print *,'Exit GEN_SIDE.'
+#endif
+C Calculate initial energy.
+ call chainbuild
+ call etotal(energia(0))
+ etot=energia(0)
+ do i=1,n_ene_comp
+ ener0(i,ithread)=energia(i)
+ enddo
+ ener0(n_ene_comp+1,ithread)=energia(0)
+ if (refstr) then
+ call rms_nac_nnc(rms,frac,frac_nn,co,.true.)
+ ener0(n_ene_comp+3,ithread)=contact_fract(ncont,ncont_ref,
+ & icont,icont_ref)
+ ener0(n_ene_comp+2,ithread)=rms
+ ener0(n_ene_comp+4,ithread)=frac
+ ener0(n_ene_comp+5,ithread)=frac_nn
+ endif
+ ener0(n_ene_comp+3,ithread)=0.0d0
+C Minimize energy.
+#ifdef MPI
+ print*,'Processor:',me,' ithread=',ithread,' Start REGULARIZE.'
+#else
+ print*,'ithread=',ithread,' Start REGULARIZE.'
+#endif
+ curr_tim=tcpu()
+ call regularize(nct-nnt+1,etot,rms,
+ & cart_base(1,ist+nnt,ipattern),iretcode)
+ curr_tim1=tcpu()
+ time_for_thread=curr_tim1-curr_tim
+ ave_time_for_thread=
+ & ((ithread-1)*ave_time_for_thread+time_for_thread)/ithread
+ if (time_for_thread.gt.max_time_for_thread)
+ & max_time_for_thread=time_for_thread
+#ifdef MPI
+ print *,'Processor',me,': Exit REGULARIZE.'
+ if (WhatsUp.eq.2) then
+ write (iout,*)
+ & 'Sufficient number of confs. collected. Terminating.'
+ nthread=ithread-1
+ goto 777
+ else if (WhatsUp.eq.-1) then
+ nthread=ithread-1
+ write (iout,*) 'Time up in REGULARIZE. Call SEND_STOP_SIG.'
+ if (Kwita.eq.0) call recv_stop_sig(Kwita)
+ call send_stop_sig(-2)
+ goto 777
+ else if (WhatsUp.eq.-2) then
+ nthread=ithread-1
+ write (iout,*) 'Timeup signal received. Terminating.'
+ goto 777
+ else if (WhatsUp.eq.-3) then
+ nthread=ithread-1
+ write (iout,*) 'Error stop signal received. Terminating.'
+ goto 777
+ endif
+#else
+ print *,'Exit REGULARIZE.'
+ if (iretcode.eq.11) then
+ write (iout,'(/a/)')
+ &'******* Allocated time exceeded in SUMSL. The program will stop.'
+ nthread=ithread-1
+ goto 777
+ endif
+#endif
+ head_pdb=titel(:24)//':'//str_nam(ipattern)
+ if (outpdb) call pdbout(etot,head_pdb,ipdb)
+ if (outmol2) call mol2out(etot,head_pdb)
+c call intout
+ call briefout(ithread,etot)
+ link_end0=link_end
+ link_end=min0(link_end,nss)
+ write (iout,*) 'link_end=',link_end,' link_end0=',link_end0,
+ & ' nss=',nss
+ call etotal(energia(0))
+c call enerprint(energia(0))
+ link_end=link_end0
+cd call chainbuild
+cd call fitsq(rms,c(1,nnt),cref(1,nnt),nct-nnt+1,przes,obr,non_conv)
+cd write (iout,'(a,f10.5)')
+cd & 'RMS deviation from reference structure:',dsqrt(rms)
+ do i=1,n_ene_comp
+ ener(i,ithread)=energia(i)
+ enddo
+ ener(n_ene_comp+1,ithread)=energia(0)
+ ener(n_ene_comp+3,ithread)=rms
+ if (refstr) then
+ call rms_nac_nnc(rms,frac,frac_nn,co,.true.)
+ ener(n_ene_comp+2,ithread)=rms
+ ener(n_ene_comp+4,ithread)=frac
+ ener(n_ene_comp+5,ithread)=frac_nn
+ endif
+ call write_stat_thread(ithread,ipattern,ist)
+c write (istat,'(i4,2x,a8,i4,11(1pe14.5),2(0pf8.3),f8.5)')
+c & ithread,str_nam(ipattern),ist+1,(ener(k,ithread),k=1,11),
+c & (ener(k,ithread),k=12,14)
+#ifdef MPI
+ if (me.eq.king) then
+ nacc_tot=nacc_tot+1
+ call pattern_receive
+ call receive_MCM_info
+ if (nacc_tot.ge.nthread) then
+ write (iout,*)
+ & 'Sufficient number of conformations collected nacc_tot=',
+ & nacc_tot,'. Stopping other processors and terminating.'
+ write (*,*)
+ & 'Sufficient number of conformations collected nacc_tot=',
+ & nacc_tot,'. Stopping other processors and terminating.'
+ call recv_stop_sig(Kwita)
+ if (Kwita.eq.0) call send_stop_sig(-1)
+ nthread=ithread
+ goto 777
+ endif
+ else
+ call send_MCM_info(2)
+ endif
+#endif
+ if (timlim-curr_tim1-safety .lt. max_time_for_thread) then
+ write (iout,'(/2a)')
+ & '********** There would be not enough time for another thread. ',
+ & 'The program will stop.'
+ write (*,'(/2a)')
+ & '********** There would be not enough time for another thread. ',
+ & 'The program will stop.'
+ write (iout,'(a,1pe14.4/)')
+ & 'Elapsed time for last threading step: ',time_for_thread
+ nthread=ithread
+#ifdef MPI
+ call recv_stop_sig(Kwita)
+ call send_stop_sig(-2)
+#endif
+ goto 777
+ else
+ curr_tim=curr_tim1
+ write (iout,'(a,1pe14.4)')
+ & 'Elapsed time for this threading step: ',time_for_thread
+ endif
+#ifdef MPI
+ if (Kwita.eq.0) call recv_stop_sig(Kwita)
+ if (Kwita.lt.0) then
+ write (iout,*) 'Stop signal received. Terminating.'
+ write (*,*) 'Stop signal received. Terminating.'
+ nthread=ithread
+ write (*,*) 'nthread=',nthread,' ithread=',ithread
+ goto 777
+ endif
+#endif
+ enddo
+#ifdef MPI
+ call send_stop_sig(-1)
+#endif
+ 777 continue
+#ifdef MPI
+C Any messages left for me?
+ call pattern_receive
+ if (Kwita.eq.0) call recv_stop_sig(Kwita)
+#endif
+ call write_thread_summary
+#ifdef MPI
+ if (king.eq.king) then
+ Kwita=1
+ do while (Kwita.ne.0 .or. nacc_tot.ne.0)
+ Kwita=0
+ nacc_tot=0
+ call recv_stop_sig(Kwita)
+ call receive_MCM_info
+ enddo
+ do iproc=1,nprocs-1
+ call receive_thread_results(iproc)
+ enddo
+ call write_thread_summary
+ else
+ call send_thread_results
+ endif
+#endif
+ return
+ end
+c--------------------------------------------------------------------------
+ subroutine write_thread_summary
+C Thread the sequence through a database of known structures
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.CONTROL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DBASE'
+ include 'COMMON.INTERACT'
+ include 'COMMON.VAR'
+ include 'COMMON.THREAD'
+ include 'COMMON.FFIELD'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.HEADER'
+ include 'COMMON.NAMES'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.TIME1'
+#ifdef MPI
+ include 'COMMON.INFO'
+#endif
+ dimension ip(maxthread)
+ double precision energia(0:n_ene)
+ write (iout,'(30x,a/)')
+ & ' *********** Summary threading statistics ************'
+ write (iout,'(a)') 'Initial energies:'
+ write (iout,'(a4,2x,a12,14a14,3a8)')
+ & 'No','seq',(ename(print_order(i)),i=1,nprint_ene),'ETOT',
+ & 'RMSnat','NatCONT','NNCONT','RMS'
+C Energy sort patterns
+ do i=1,nthread
+ ip(i)=i
+ enddo
+ do i=1,nthread-1
+ enet=ener(n_ene-1,ip(i))
+ jj=i
+ do j=i+1,nthread
+ if (ener(n_ene-1,ip(j)).lt.enet) then
+ jj=j
+ enet=ener(n_ene-1,ip(j))
+ endif
+ enddo
+ if (jj.ne.i) then
+ ipj=ip(jj)
+ ip(jj)=ip(i)
+ ip(i)=ipj
+ endif
+ enddo
+ do ik=1,nthread
+ i=ip(ik)
+ ii=ipatt(1,i)
+ ist=nres_base(2,ii)+ipatt(2,i)
+ do kk=1,n_ene_comp
+ energia(i)=ener0(kk,i)
+ enddo
+ etot=ener0(n_ene_comp+1,i)
+ rmsnat=ener0(n_ene_comp+2,i)
+ rms=ener0(n_ene_comp+3,i)
+ frac=ener0(n_ene_comp+4,i)
+ frac_nn=ener0(n_ene_comp+5,i)
+
+ if (refstr) then
+ write (iout,'(i4,2x,a8,i4,14(1pe14.5),0pf8.3,f8.5,f8.5,f8.3)')
+ & i,str_nam(ii),ist+1,
+ & (energia(print_order(kk)),kk=1,nprint_ene),
+ & etot,rmsnat,frac,frac_nn,rms
+ else
+ write (iout,'(i4,2x,a8,i4,14(1pe14.5),0pf8.3)')
+ & i,str_nam(ii),ist+1,
+ & (energia(print_order(kk)),kk=1,nprint_ene),etot
+ endif
+ enddo
+ write (iout,'(//a)') 'Final energies:'
+ write (iout,'(a4,2x,a12,17a14,3a8)')
+ & 'No','seq',(ename(print_order(kk)),kk=1,nprint_ene),'ETOT',
+ & 'RMSnat','NatCONT','NNCONT','RMS'
+ do ik=1,nthread
+ i=ip(ik)
+ ii=ipatt(1,i)
+ ist=nres_base(2,ii)+ipatt(2,i)
+ do kk=1,n_ene_comp
+ energia(kk)=ener(kk,ik)
+ enddo
+ etot=ener(n_ene_comp+1,i)
+ rmsnat=ener(n_ene_comp+2,i)
+ rms=ener(n_ene_comp+3,i)
+ frac=ener(n_ene_comp+4,i)
+ frac_nn=ener(n_ene_comp+5,i)
+ write (iout,'(i4,2x,a8,i4,14(1pe14.5),0pf8.3,f8.5,f8.5,f8.3)')
+ & i,str_nam(ii),ist+1,
+ & (energia(print_order(kk)),kk=1,nprint_ene),
+ & etot,rmsnat,frac,frac_nn,rms
+ enddo
+ write (iout,'(/a/)') 'IEXAM array:'
+ write (iout,'(i5)') nexcl
+ do i=1,nexcl
+ write (iout,'(2i5)') iexam(1,i),iexam(2,i)
+ enddo
+ write (iout,'(/a,1pe14.4/a,1pe14.4/)')
+ & 'Max. time for threading step ',max_time_for_thread,
+ & 'Average time for threading step: ',ave_time_for_thread
+ return
+ end
+c----------------------------------------------------------------------------
+ subroutine sc_conf
+C Sample (hopefully) optimal SC orientations given backcone conformation.
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DBASE'
+ include 'COMMON.INTERACT'
+ include 'COMMON.VAR'
+ include 'COMMON.THREAD'
+ include 'COMMON.FFIELD'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.HEADER'
+ include 'COMMON.GEO'
+ include 'COMMON.IOUNITS'
+ double precision varia(maxvar)
+ common /srutu/ icall
+ double precision energia(0:n_ene)
+ logical glycine,fail
+ maxsample=10
+ link_end0=link_end
+ link_end=min0(link_end,nss)
+ do i=nnt,nct
+ if (itype(i).ne.10) then
+cd print *,'i=',i,' itype=',itype(i),' theta=',theta(i+1)
+ call gen_side(itype(i),theta(i+1),alph(i),omeg(i),fail)
+ endif
+ enddo
+ call chainbuild
+ call etotal(energia(0))
+ do isample=1,maxsample
+C Choose a non-glycine side chain.
+ glycine=.true.
+ do while(glycine)
+ ind_sc=iran_num(nnt,nct)
+ glycine=(itype(ind_sc).eq.10)
+ enddo
+ alph0=alph(ind_sc)
+ omeg0=omeg(ind_sc)
+ call gen_side(itype(ind_sc),theta(ind_sc+1),alph(ind_sc),
+ & omeg(ind_sc),fail)
+ call chainbuild
+ call etotal(energia(0))
+cd write (iout,'(a,i5,a,i4,2(a,f8.3),2(a,1pe14.5))')
+cd & 'Step:',isample,' SC',ind_sc,' alpha',alph(ind_sc)*rad2deg,
+cd & ' omega',omeg(ind_sc)*rad2deg,' old energy',e0,' new energy',e1
+ e1=0.0d0
+ if (e0.le.e1) then
+ alph(ind_sc)=alph0
+ omeg(ind_sc)=omeg0
+ else
+ e0=e1
+ endif
+ enddo
+ link_end=link_end0
+ return
+ end
+c---------------------------------------------------------------------------
+ subroutine write_stat_thread(ithread,ipattern,ist)
+ implicit real*8 (a-h,o-z)
+ include "DIMENSIONS"
+ include "COMMON.CONTROL"
+ include "COMMON.IOUNITS"
+ include "COMMON.THREAD"
+ include "COMMON.FFIELD"
+ include "COMMON.DBASE"
+ include "COMMON.NAMES"
+ double precision energia(0:n_ene)
+
+#if defined(AIX) || defined(PGI)
+ open(istat,file=statname,position='append')
+#else
+ open(istat,file=statname,access='append')
+#endif
+ do i=1,n_ene_comp
+ energia(i)=ener(i,ithread)
+ enddo
+ etot=ener(n_ene_comp+1,ithread)
+ rmsnat=ener(n_ene_comp+2,ithread)
+ rms=ener(n_ene_comp+3,ithread)
+ frac=ener(n_ene_comp+4,ithread)
+ frac_nn=ener(n_ene_comp+5,ithread)
+ write (istat,'(i4,2x,a8,i4,14(1pe14.5),0pf8.3,f8.5,f8.5,f8.3)')
+ & ithread,str_nam(ipattern),ist+1,
+ & (energia(print_order(i)),i=1,nprint_ene),
+ & etot,rmsnat,frac,frac_nn,rms
+ close (istat)
+ return
+ end
--- /dev/null
+C $Date: 1994/10/05 16:41:52 $
+C $Revision: 2.2 $
+C
+C
+C
+ subroutine set_timers
+c
+ implicit none
+ double precision tcpu
+ include 'COMMON.TIME1'
+#ifdef MP
+ include 'mpif.h'
+#endif
+C Diminish the assigned time limit a little so that there is some time to
+C end a batch job
+c timlim=batime-150.0
+C Calculate the initial time, if it is not zero (e.g. for the SUN).
+ stime=tcpu()
+#ifdef MPI
+ walltime=MPI_WTIME()
+ time_reduce=0.0d0
+ time_allreduce=0.0d0
+ time_bcast=0.0d0
+ time_gather=0.0d0
+ time_sendrecv=0.0d0
+ time_scatter=0.0d0
+ time_scatter_fmat=0.0d0
+ time_scatter_ginv=0.0d0
+ time_scatter_fmatmult=0.0d0
+ time_scatter_ginvmult=0.0d0
+ time_barrier_e=0.0d0
+ time_barrier_g=0.0d0
+ time_enecalc=0.0d0
+ time_sumene=0.0d0
+ time_lagrangian=0.0d0
+ time_sumgradient=0.0d0
+ time_intcartderiv=0.0d0
+ time_inttocart=0.0d0
+ time_ginvmult=0.0d0
+ time_fricmatmult=0.0d0
+ time_cartgrad=0.0d0
+ time_bcastc=0.0d0
+ time_bcast7=0.0d0
+ time_bcastw=0.0d0
+ time_intfcart=0.0d0
+ time_vec=0.0d0
+ time_mat=0.0d0
+ time_fric=0.0d0
+ time_stoch=0.0d0
+ time_fricmatmult=0.0d0
+ time_fsample=0.0d0
+#endif
+cd print *,' in SET_TIMERS stime=',stime
+ return
+ end
+C------------------------------------------------------------------------------
+ logical function stopx(nf)
+C This function returns .true. if one of the following reasons to exit SUMSL
+C occurs. The "reason" code is stored in WHATSUP passed thru a COMMON block:
+C
+C... WHATSUP = 0 - go on, no reason to stop. Stopx will return .false.
+C... 1 - Time up in current node;
+C... 2 - STOP signal was received from another node because the
+C... node's task was accomplished (parallel only);
+C... -1 - STOP signal was received from another node because of error;
+C... -2 - STOP signal was received from another node, because
+C... the node's time was up.
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ integer nf
+ logical ovrtim
+#ifdef MP
+ include 'mpif.h'
+ include 'COMMON.INFO'
+#endif
+ include 'COMMON.IOUNITS'
+ include 'COMMON.TIME1'
+ integer Kwita
+
+cd print *,'Processor',MyID,' NF=',nf
+#ifndef MPI
+ if (ovrtim()) then
+C Finish if time is up.
+ stopx = .true.
+ WhatsUp=1
+#ifdef MPL
+ else if (mod(nf,100).eq.0) then
+C Other processors might have finished. Check this every 100th function
+C evaluation.
+C Master checks if any other processor has sent accepted conformation(s) to it.
+ if (MyID.ne.MasterID) call receive_mcm_info
+ if (MyID.eq.MasterID) call receive_conf
+cd print *,'Processor ',MyID,' is checking STOP: nf=',nf
+ call recv_stop_sig(Kwita)
+ if (Kwita.eq.-1) then
+ write (iout,'(a,i4,a,i5)') 'Processor',
+ & MyID,' has received STOP signal in STOPX; NF=',nf
+ write (*,'(a,i4,a,i5)') 'Processor',
+ & MyID,' has received STOP signal in STOPX; NF=',nf
+ stopx=.true.
+ WhatsUp=2
+ elseif (Kwita.eq.-2) then
+ write (iout,*)
+ & 'Processor',MyID,' received TIMEUP-STOP signal in SUMSL.'
+ write (*,*)
+ & 'Processor',MyID,' received TIMEUP-STOP signal in SUMSL.'
+ WhatsUp=-2
+ stopx=.true.
+ else if (Kwita.eq.-3) then
+ write (iout,*)
+ & 'Processor',MyID,' received ERROR-STOP signal in SUMSL.'
+ write (*,*)
+ & 'Processor',MyID,' received ERROR-STOP signal in SUMSL.'
+ WhatsUp=-1
+ stopx=.true.
+ else
+ stopx=.false.
+ WhatsUp=0
+ endif
+#endif
+ else
+ stopx = .false.
+ WhatsUp=0
+ endif
+#else
+ stopx=.false.
+#endif
+
+#ifdef OSF
+c Check for FOUND_NAN flag
+ if (FOUND_NAN) then
+ write(iout,*)" *** stopx : Found a NaN"
+ stopx=.true.
+ endif
+#endif
+
+ return
+ end
+C--------------------------------------------------------------------------
+ logical function ovrtim()
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.TIME1'
+ include 'COMMON.SETUP'
+ include 'COMMON.CONTROL'
+ real*8 tcpu
+#ifdef MPI
+ include "mpif.h"
+ curtim = MPI_Wtime()-walltime
+#else
+ curtim= tcpu()
+#endif
+C curtim is the current time in seconds.
+c write (iout,*) "curtim",curtim," timlim",timlim," safety",safety
+ if (curtim .ge. timlim - safety) then
+ if (me.eq.king .or. .not. out1file)
+ & write (iout,'(a,f10.2,a,f10.2,a,f10.2,a)')
+ & "***************** Elapsed time (",curtim,
+ & " s) is within the safety limit (",safety,
+ & " s) of the allocated time (",timlim," s). Terminating."
+ ovrtim=.true.
+ else
+ ovrtim=.false.
+ endif
+ return
+ end
+**************************************************************************
+ double precision function tcpu()
+ include 'COMMON.TIME1'
+#ifdef ES9000
+****************************
+C Next definition for EAGLE (ibm-es9000)
+ real*8 micseconds
+ integer rcode
+ tcpu=cputime(micseconds,rcode)
+ tcpu=(micseconds/1.0E6) - stime
+****************************
+#endif
+#ifdef SUN
+****************************
+C Next definitions for sun
+ REAL*8 ECPU,ETIME,ETCPU
+ dimension tarray(2)
+ tcpu=etime(tarray)
+ tcpu=tarray(1)
+****************************
+#endif
+#ifdef KSR
+****************************
+C Next definitions for ksr
+C this function uses the ksr timer ALL_SECONDS from the PMON library to
+C return the elapsed time in seconds
+ tcpu= all_seconds() - stime
+****************************
+#endif
+#ifdef SGI
+****************************
+C Next definitions for sgi
+ real timar(2), etime
+ seconds = etime(timar)
+Cd print *,'seconds=',seconds,' stime=',stime
+C usrsec = timar(1)
+C syssec = timar(2)
+ tcpu=seconds - stime
+****************************
+#endif
+
+#ifdef LINUX
+****************************
+C Next definitions for sgi
+ real timar(2), etime
+ seconds = etime(timar)
+Cd print *,'seconds=',seconds,' stime=',stime
+C usrsec = timar(1)
+C syssec = timar(2)
+ tcpu=seconds - stime
+****************************
+#endif
+
+
+#ifdef CRAY
+****************************
+C Next definitions for Cray
+C call date(curdat)
+C curdat=curdat(1:9)
+C call clock(curtim)
+C curtim=curtim(1:8)
+ cpusec = second()
+ tcpu=cpusec - stime
+****************************
+#endif
+#ifdef AIX
+****************************
+C Next definitions for RS6000
+ integer*4 i1,mclock
+ i1 = mclock()
+ tcpu = (i1+0.0D0)/100.0D0
+#endif
+#ifdef WINPGI
+****************************
+c next definitions for windows NT Digital fortran
+ real time_real
+ call cpu_time(time_real)
+ tcpu = time_real
+#endif
+#ifdef WINIFL
+****************************
+c next definitions for windows NT Digital fortran
+ real time_real
+ call cpu_time(time_real)
+ tcpu = time_real
+#endif
+
+ return
+ end
+C---------------------------------------------------------------------------
+ subroutine dajczas(rntime,hrtime,mintime,sectime)
+ include 'COMMON.IOUNITS'
+ real*8 rntime,hrtime,mintime,sectime
+ hrtime=rntime/3600.0D0
+ hrtime=aint(hrtime)
+ mintime=aint((rntime-3600.0D0*hrtime)/60.0D0)
+ sectime=aint((rntime-3600.0D0*hrtime-60.0D0*mintime)+0.5D0)
+ if (sectime.eq.60.0D0) then
+ sectime=0.0D0
+ mintime=mintime+1.0D0
+ endif
+ ihr=hrtime
+ imn=mintime
+ isc=sectime
+ write (iout,328) ihr,imn,isc
+ 328 FORMAT(//'***** Computation time: ',I4 ,' hours ',I2 ,
+ 1 ' minutes ', I2 ,' seconds *****')
+ return
+ end
+C---------------------------------------------------------------------------
+ subroutine print_detailed_timing
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.IOUNITS'
+ include 'COMMON.TIME1'
+ include 'COMMON.SETUP'
+#ifdef MPI
+ time1=MPI_WTIME()
+ write (iout,'(80(1h=)/a/(80(1h=)))')
+ & "Details of FG communication time"
+ write (*,'(7(a40,1pe15.5/),40(1h-)/a40,1pe15.5/80(1h=))')
+ & "BROADCAST:",time_bcast,"REDUCE:",time_reduce,
+ & "GATHER:",time_gather,
+ & "SCATTER:",time_scatter,"SENDRECV:",time_sendrecv,
+ & "BARRIER ene",time_barrier_e,
+ & "BARRIER grad",time_barrier_g,
+ & "TOTAL:",
+ & time_bcast+time_reduce+time_gather+time_scatter+time_sendrecv
+ write (*,*) fg_rank,myrank,
+ & ': Total wall clock time',time1-walltime,' sec'
+ write (*,*) "Processor",fg_rank,myrank,
+ & ": BROADCAST time",time_bcast," REDUCE time",
+ & time_reduce," GATHER time",time_gather," SCATTER time",
+ & time_scatter,
+ & " SCATTER fmatmult",time_scatter_fmatmult,
+ & " SCATTER ginvmult",time_scatter_ginvmult,
+ & " SCATTER fmat",time_scatter_fmat,
+ & " SCATTER ginv",time_scatter_ginv,
+ & " SENDRECV",time_sendrecv,
+ & " BARRIER ene",time_barrier_e,
+ & " BARRIER GRAD",time_barrier_g,
+ & " BCAST7",time_bcast7," BCASTC",time_bcastc,
+ & " BCASTW",time_bcastw," ALLREDUCE",time_allreduce,
+ & " TOTAL",
+ & time_bcast+time_reduce+time_gather+time_scatter+
+ & time_sendrecv+time_barrier+time_bcastc
+#else
+ time1=tcpu()
+#endif
+ write (*,*) "Processor",fg_rank,myrank," enecalc",time_enecalc
+ write (*,*) "Processor",fg_rank,myrank," sumene",time_sumene
+ write (*,*) "Processor",fg_rank,myrank," intfromcart",
+ & time_intfcart
+ write (*,*) "Processor",fg_rank,myrank," vecandderiv",
+ & time_vec
+ write (*,*) "Processor",fg_rank,myrank," setmatrices",
+ & time_mat
+ write (*,*) "Processor",fg_rank,myrank," ginvmult",
+ & time_ginvmult
+ write (*,*) "Processor",fg_rank,myrank," fricmatmult",
+ & time_fricmatmult
+ write (*,*) "Processor",fg_rank,myrank," inttocart",
+ & time_inttocart
+ write (*,*) "Processor",fg_rank,myrank," sumgradient",
+ & time_sumgradient
+ write (*,*) "Processor",fg_rank,myrank," intcartderiv",
+ & time_intcartderiv
+ if (fg_rank.eq.0) then
+ write (*,*) "Processor",fg_rank,myrank," lagrangian",
+ & time_lagrangian
+ write (*,*) "Processor",fg_rank,myrank," cartgrad",
+ & time_cartgrad
+ endif
+ return
+ end
--- /dev/null
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C C
+C U N R E S C
+C C
+C Program to carry out conformational search of proteins in an united-residue C
+C approximation. C
+C C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+
+
+#ifdef MPI
+ include 'mpif.h'
+ include 'COMMON.SETUP'
+#endif
+ include 'COMMON.TIME1'
+ include 'COMMON.INTERACT'
+ include 'COMMON.NAMES'
+ include 'COMMON.GEO'
+ include 'COMMON.HEADER'
+ include 'COMMON.CONTROL'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.VAR'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.FFIELD'
+ include 'COMMON.REMD'
+ include 'COMMON.MD'
+ include 'COMMON.SBRIDGE'
+ double precision hrtime,mintime,sectime
+ character*64 text_mode_calc(-2:14) /'test',
+ & 'SC rotamer distribution',
+ & 'Energy evaluation or minimization',
+ & 'Regularization of PDB structure',
+ & 'Threading of a sequence on PDB structures',
+ & 'Monte Carlo (with minimization) ',
+ & 'Energy minimization of multiple conformations',
+ & 'Checking energy gradient',
+ & 'Entropic sampling Monte Carlo (with minimization)',
+ & 'Energy map',
+ & 'CSA calculations',
+ & 'Not used 9',
+ & 'Not used 10',
+ & 'Soft regularization of PDB structure',
+ & 'Mesoscopic molecular dynamics (MD) ',
+ & 'Not used 13',
+ & 'Replica exchange molecular dynamics (REMD)'/
+ external ilen
+
+c call memmon_print_usage()
+
+ call init_task
+ if (me.eq.king)
+ & write(iout,*)'### LAST MODIFIED 03/28/12 23:29 by czarek'
+ if (me.eq.king) call cinfo
+C Read force field parameters and job setup data
+ call readrtns
+ call flush(iout)
+C
+ if (me.eq.king .or. .not. out1file) then
+ write (iout,'(2a/)')
+ & text_mode_calc(modecalc)(:ilen(text_mode_calc(modecalc))),
+ & ' calculation.'
+ if (minim) write (iout,'(a)')
+ & 'Conformations will be energy-minimized.'
+ write (iout,'(80(1h*)/)')
+ endif
+ call flush(iout)
+C
+ if (modecalc.eq.-2) then
+ call test
+ stop
+ else if (modecalc.eq.-1) then
+ write(iout,*) "call check_sc_map next"
+ call check_bond
+ stop
+ endif
+#ifdef MPI
+ if (fg_rank.gt.0) then
+C Fine-grain slaves just do energy and gradient components.
+ call ergastulum ! slave workhouse in Latin
+ else
+#endif
+ if (modecalc.eq.0) then
+ call exec_eeval_or_minim
+ else if (modecalc.eq.1) then
+ call exec_regularize
+ else if (modecalc.eq.2) then
+ call exec_thread
+ else if (modecalc.eq.3 .or. modecalc .eq.6) then
+ call exec_MC
+ else if (modecalc.eq.4) then
+ call exec_mult_eeval_or_minim
+ else if (modecalc.eq.5) then
+ call exec_checkgrad
+ else if (ModeCalc.eq.7) then
+ call exec_map
+ else if (ModeCalc.eq.8) then
+ call exec_CSA
+ else if (modecalc.eq.11) then
+ call exec_softreg
+ else if (modecalc.eq.12) then
+ call exec_MD
+ else if (modecalc.eq.14) then
+ call exec_MREMD
+ else
+ write (iout,'(a)') 'This calculation type is not supported',
+ & ModeCalc
+ endif
+#ifdef MPI
+ endif
+C Finish task.
+ if (fg_rank.eq.0) call finish_task
+c call memmon_print_usage()
+#ifdef TIMING
+ call print_detailed_timing
+#endif
+ call MPI_Finalize(ierr)
+ stop 'Bye Bye...'
+#else
+ call dajczas(tcpu(),hrtime,mintime,sectime)
+ stop '********** Program terminated normally.'
+#endif
+ end
+c--------------------------------------------------------------------------
+ subroutine exec_MD
+ include 'DIMENSIONS'
+#ifdef MPI
+ include "mpif.h"
+#endif
+ include 'COMMON.SETUP'
+ include 'COMMON.CONTROL'
+ include 'COMMON.IOUNITS'
+ if (me.eq.king .or. .not. out1file)
+ & write (iout,*) "Calling chainbuild"
+ call chainbuild
+ call MD
+ return
+ end
+c---------------------------------------------------------------------------
+ subroutine exec_MREMD
+ include 'DIMENSIONS'
+#ifdef MPI
+ include "mpif.h"
+ include 'COMMON.SETUP'
+ include 'COMMON.CONTROL'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.REMD'
+ if (me.eq.king .or. .not. out1file)
+ & write (iout,*) "Calling chainbuild"
+ call chainbuild
+ if (me.eq.king .or. .not. out1file)
+ & write (iout,*) "Calling REMD"
+ if (remd_mlist) then
+ call MREMD
+ else
+ do i=1,nrep
+ remd_m(i)=1
+ enddo
+ call MREMD
+ endif
+#else
+ write (iout,*) "MREMD works on parallel machines only"
+#endif
+ return
+ end
+c---------------------------------------------------------------------------
+ subroutine exec_eeval_or_minim
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.SETUP'
+ include 'COMMON.TIME1'
+ include 'COMMON.INTERACT'
+ include 'COMMON.NAMES'
+ include 'COMMON.GEO'
+ include 'COMMON.HEADER'
+ include 'COMMON.CONTROL'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.VAR'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.FFIELD'
+ include 'COMMON.REMD'
+ include 'COMMON.MD'
+ include 'COMMON.SBRIDGE'
+ common /srutu/ icall
+ double precision energy(0:n_ene)
+ double precision energy_long(0:n_ene),energy_short(0:n_ene)
+ double precision varia(maxvar)
+ if (indpdb.eq.0) call chainbuild
+#ifdef MPI
+ time00=MPI_Wtime()
+#else
+ time00=tcpu()
+#endif
+ call chainbuild_cart
+ if (split_ene) then
+ print *,"Processor",myrank," after chainbuild"
+ icall=1
+ call etotal_long(energy_long(0))
+ write (iout,*) "Printing long range energy"
+ call enerprint(energy_long(0))
+ call etotal_short(energy_short(0))
+ write (iout,*) "Printing short range energy"
+ call enerprint(energy_short(0))
+ do i=0,n_ene
+ energy(i)=energy_long(i)+energy_short(i)
+ write (iout,*) i,energy_long(i),energy_short(i),energy(i)
+ enddo
+ write (iout,*) "Printing long+short range energy"
+ call enerprint(energy(0))
+ endif
+ call etotal(energy(0))
+#ifdef MPI
+ time_ene=MPI_Wtime()-time00
+#else
+ time_ene=tcpu()-time00
+#endif
+ write (iout,*) "Time for energy evaluation",time_ene
+ print *,"after etotal"
+ etota = energy(0)
+ etot =etota
+ call enerprint(energy(0))
+ call hairpin(.true.,nharp,iharp)
+ call secondary2(.true.)
+ if (minim) then
+crc overlap test
+ if (overlapsc) then
+ print *, 'Calling OVERLAP_SC'
+ call overlap_sc(fail)
+ endif
+
+ if (searchsc) then
+ call sc_move(2,nres-1,10,1d10,nft_sc,etot)
+ print *,'SC_move',nft_sc,etot
+ write(iout,*) 'SC_move',nft_sc,etot
+ endif
+
+ if (dccart) then
+ print *, 'Calling MINIM_DC'
+#ifdef MPI
+ time1=MPI_WTIME()
+#else
+ time1=tcpu()
+#endif
+ call minim_dc(etot,iretcode,nfun)
+ else
+ if (indpdb.ne.0) then
+ call bond_regular
+ call chainbuild
+ endif
+ call geom_to_var(nvar,varia)
+ print *,'Calling MINIMIZE.'
+#ifdef MPI
+ time1=MPI_WTIME()
+#else
+ time1=tcpu()
+#endif
+ call minimize(etot,varia,iretcode,nfun)
+ endif
+ print *,'SUMSL return code is',iretcode,' eval ',nfun
+#ifdef MPI
+ evals=nfun/(MPI_WTIME()-time1)
+#else
+ evals=nfun/(tcpu()-time1)
+#endif
+ print *,'# eval/s',evals
+ print *,'refstr=',refstr
+ call hairpin(.true.,nharp,iharp)
+ call secondary2(.true.)
+ call etotal(energy(0))
+ etot = energy(0)
+ call enerprint(energy(0))
+
+ call intout
+ call briefout(0,etot)
+ if (refstr) call rms_nac_nnc(rms,frac,frac_nn,co,.true.)
+ write (iout,'(a,i3)') 'SUMSL return code:',iretcode
+ write (iout,'(a,i20)') '# of energy evaluations:',nfun+1
+ write (iout,'(a,f16.3)')'# of energy evaluations/sec:',evals
+ else
+ print *,'refstr=',refstr
+ if (refstr) call rms_nac_nnc(rms,frac,frac_nn,co,.true.)
+ call briefout(0,etot)
+ endif
+ if (outpdb) call pdbout(etot,titel(:32),ipdb)
+ if (outmol2) call mol2out(etot,titel(:32))
+ return
+ end
+c---------------------------------------------------------------------------
+ subroutine exec_regularize
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.SETUP'
+ include 'COMMON.TIME1'
+ include 'COMMON.INTERACT'
+ include 'COMMON.NAMES'
+ include 'COMMON.GEO'
+ include 'COMMON.HEADER'
+ include 'COMMON.CONTROL'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.VAR'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.FFIELD'
+ include 'COMMON.REMD'
+ include 'COMMON.MD'
+ include 'COMMON.SBRIDGE'
+ double precision energy(0:n_ene)
+
+ call gen_dist_constr
+ call sc_conf
+ call intout
+ call regularize(nct-nnt+1,etot,rms,cref(1,nnt),iretcode)
+ call etotal(energy(0))
+ energy(0)=energy(0)-energy(14)
+ etot=energy(0)
+ call enerprint(energy(0))
+ call intout
+ call briefout(0,etot)
+ if (outpdb) call pdbout(etot,titel(:32),ipdb)
+ if (outmol2) call mol2out(etot,titel(:32))
+ if (refstr) call rms_nac_nnc(rms,frac,frac_nn,co,.true.)
+ write (iout,'(a,i3)') 'SUMSL return code:',iretcode
+ return
+ end
+c---------------------------------------------------------------------------
+ subroutine exec_thread
+ include 'DIMENSIONS'
+#ifdef MP
+ include "mpif.h"
+#endif
+ include "COMMON.SETUP"
+ call thread_seq
+ return
+ end
+c---------------------------------------------------------------------------
+ subroutine exec_MC
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ character*10 nodeinfo
+ double precision varia(maxvar)
+#ifdef MPI
+ include "mpif.h"
+#endif
+ include "COMMON.SETUP"
+ include 'COMMON.CONTROL'
+ call mcm_setup
+ if (minim) then
+#ifdef MPI
+ if (modecalc.eq.3) then
+ call do_mcm(ipar)
+ else
+ call entmcm
+ endif
+#else
+ if (modecalc.eq.3) then
+ call do_mcm(ipar)
+ else
+ call entmcm
+ endif
+#endif
+ else
+ call monte_carlo
+ endif
+ return
+ end
+c---------------------------------------------------------------------------
+ subroutine exec_mult_eeval_or_minim
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+ dimension muster(mpi_status_size)
+#endif
+ include 'COMMON.SETUP'
+ include 'COMMON.TIME1'
+ include 'COMMON.INTERACT'
+ include 'COMMON.NAMES'
+ include 'COMMON.GEO'
+ include 'COMMON.HEADER'
+ include 'COMMON.CONTROL'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.VAR'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.FFIELD'
+ include 'COMMON.REMD'
+ include 'COMMON.MD'
+ include 'COMMON.SBRIDGE'
+ double precision varia(maxvar)
+ dimension ind(6)
+ double precision energy(0:max_ene)
+ logical eof
+ eof=.false.
+#ifdef MPI
+ if(me.ne.king) then
+ call minim_mcmf
+ return
+ endif
+
+ close (intin)
+ open(intin,file=intinname,status='old')
+ write (istat,'(a5,20a12)')"# ",
+ & (wname(print_order(i)),i=1,nprint_ene)
+ if (refstr) then
+ write (istat,'(a5,20a12)')"# ",
+ & (ename(print_order(i)),i=1,nprint_ene),
+ & "ETOT total","RMSD","nat.contact","nnt.contact"
+ else
+ write (istat,'(a5,20a12)')"# ",
+ & (ename(print_order(i)),i=1,nprint_ene),"ETOT total"
+ endif
+
+ if (.not.minim) then
+ do while (.not. eof)
+ if (read_cart) then
+ read (intin,'(e15.10,e15.5)',end=1100,err=1100) time,ene
+ call read_x(intin,*11)
+#ifdef MPI
+c Broadcast the order to compute internal coordinates to the slaves.
+ if (nfgtasks.gt.1)
+ & call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
+#endif
+ call int_from_cart1(.false.)
+ else
+ read (intin,'(i5)',end=1100,err=1100) iconf
+ call read_angles(intin,*11)
+ call geom_to_var(nvar,varia)
+ call chainbuild
+ endif
+ write (iout,'(a,i7)') 'Conformation #',iconf
+ call etotal(energy(0))
+ call briefout(iconf,energy(0))
+ call enerprint(energy(0))
+ etot=energy(0)
+ if (refstr) then
+ call rms_nac_nnc(rms,frac,frac_nn,co,.true.)
+ write (istat,'(i5,20(f12.3))') iconf,
+ & (energy(print_order(i)),i=1,nprint_ene),etot,
+ & rms,frac,frac_nn,co
+cjlee end
+ else
+ write (istat,'(i5,16(f12.3))') iconf,
+ & (energy(print_order(i)),i=1,nprint_ene),etot
+ endif
+ enddo
+1100 continue
+ goto 1101
+ endif
+
+ mm=0
+ imm=0
+ nft=0
+ ene0=0.0d0
+ n=0
+ iconf=0
+c do n=1,nzsc
+ do while (.not. eof)
+ mm=mm+1
+ if (mm.lt.nodes) then
+ if (read_cart) then
+ read (intin,'(e15.10,e15.5)',end=11,err=11) time,ene
+ call read_x(intin,*11)
+#ifdef MPI
+c Broadcast the order to compute internal coordinates to the slaves.
+ if (nfgtasks.gt.1)
+ & call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
+#endif
+ call int_from_cart1(.false.)
+ else
+ read (intin,'(i5)',end=11,err=11) iconf
+ call read_angles(intin,*11)
+ call geom_to_var(nvar,varia)
+ call chainbuild
+ endif
+ write (iout,'(a,i7)') 'Conformation #',iconf
+ n=n+1
+ imm=imm+1
+ ind(1)=1
+ ind(2)=n
+ ind(3)=0
+ ind(4)=0
+ ind(5)=0
+ ind(6)=0
+ ene0=0.0d0
+ call mpi_send(ind,6,mpi_integer,mm,idint,CG_COMM,
+ * ierr)
+ call mpi_send(varia,nvar,mpi_double_precision,mm,
+ * idreal,CG_COMM,ierr)
+ call mpi_send(ene0,1,mpi_double_precision,mm,
+ * idreal,CG_COMM,ierr)
+c print *,'task ',n,' sent to worker ',mm,nvar
+ else
+ call mpi_recv(ind,6,mpi_integer,mpi_any_source,idint,
+ * CG_COMM,muster,ierr)
+ man=muster(mpi_source)
+c print *,'receiving result from worker ',man,' (',iii1,iii,')'
+ call mpi_recv(varia,nvar,mpi_double_precision,
+ * man,idreal,CG_COMM,muster,ierr)
+ call mpi_recv(ene,1,
+ * mpi_double_precision,man,idreal,
+ * CG_COMM,muster,ierr)
+ call mpi_recv(ene0,1,
+ * mpi_double_precision,man,idreal,
+ * CG_COMM,muster,ierr)
+c print *,'result received from worker ',man,' sending now'
+
+ call var_to_geom(nvar,varia)
+ call chainbuild
+ call etotal(energy(0))
+ iconf=ind(2)
+ write (iout,*)
+ write (iout,*)
+ write (iout,'(a,2i7)') 'Conformation #',iconf,ind(5)
+
+ etot=energy(0)
+ call enerprint(energy(0))
+ call briefout(it,etot)
+c if (minim) call briefout(it,etot)
+ if (refstr) then
+ call rms_nac_nnc(rms,frac,frac_nn,co,.true.)
+ write (istat,'(i5,19(f12.3))') iconf,
+ & (energy(print_order(i)),i=1,nprint_ene),etot,
+ & rms,frac,frac_nn,co
+ else
+ write (istat,'(i5,15(f12.3))') iconf,
+ & (energy(print_order(i)),i=1,nprint_ene),etot
+ endif
+
+ imm=imm-1
+ if (read_cart) then
+ read (intin,'(e15.10,e15.5)',end=1101,err=1101) time,ene
+ call read_x(intin,*11)
+#ifdef MPI
+c Broadcast the order to compute internal coordinates to the slaves.
+ if (nfgtasks.gt.1)
+ & call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
+#endif
+ call int_from_cart1(.false.)
+ else
+ read (intin,'(i5)',end=1101,err=1101) iconf
+ call read_angles(intin,*11)
+ call geom_to_var(nvar,varia)
+ call chainbuild
+ endif
+ n=n+1
+ imm=imm+1
+ ind(1)=1
+ ind(2)=n
+ ind(3)=0
+ ind(4)=0
+ ind(5)=0
+ ind(6)=0
+ call mpi_send(ind,6,mpi_integer,man,idint,CG_COMM,
+ * ierr)
+ call mpi_send(varia,nvar,mpi_double_precision,man,
+ * idreal,CG_COMM,ierr)
+ call mpi_send(ene0,1,mpi_double_precision,man,
+ * idreal,CG_COMM,ierr)
+ nf_mcmf=nf_mcmf+ind(4)
+ nmin=nmin+1
+ endif
+ enddo
+11 continue
+ do j=1,imm
+ call mpi_recv(ind,6,mpi_integer,mpi_any_source,idint,
+ * CG_COMM,muster,ierr)
+ man=muster(mpi_source)
+ call mpi_recv(varia,nvar,mpi_double_precision,
+ * man,idreal,CG_COMM,muster,ierr)
+ call mpi_recv(ene,1,
+ * mpi_double_precision,man,idreal,
+ * CG_COMM,muster,ierr)
+ call mpi_recv(ene0,1,
+ * mpi_double_precision,man,idreal,
+ * CG_COMM,muster,ierr)
+
+ call var_to_geom(nvar,varia)
+ call chainbuild
+ call etotal(energy(0))
+ iconf=ind(2)
+ write (iout,*)
+ write (iout,*)
+ write (iout,'(a,2i7)') 'Conformation #',iconf,ind(5)
+
+ etot=energy(0)
+ call enerprint(energy(0))
+ call briefout(it,etot)
+ if (refstr) then
+ call rms_nac_nnc(rms,frac,frac_nn,co,.true.)
+ write (istat,'(i5,19(f12.3))') iconf,
+ & (energy(print_order(i)),i=1,nprint_ene),etot,
+ & rms,frac,frac_nn,co
+ else
+ write (istat,'(i5,15(f12.3))') iconf,
+ & (energy(print_order(i)),i=1,nprint_ene),etot
+ endif
+ nmin=nmin+1
+ enddo
+1101 continue
+ do i=1, nodes-1
+ ind(1)=0
+ ind(2)=0
+ ind(3)=0
+ ind(4)=0
+ ind(5)=0
+ ind(6)=0
+ call mpi_send(ind,6,mpi_integer,i,idint,CG_COMM,
+ * ierr)
+ enddo
+#else
+ close (intin)
+ open(intin,file=intinname,status='old')
+ write (istat,'(a5,20a12)')"# ",
+ & (wname(print_order(i)),i=1,nprint_ene)
+ write (istat,'("# ",20(1pe12.4))')
+ & (weights(print_order(i)),i=1,nprint_ene)
+ if (refstr) then
+ write (istat,'(a5,20a12)')"# ",
+ & (ename(print_order(i)),i=1,nprint_ene),
+ & "ETOT total","RMSD","nat.contact","nnt.contact"
+ else
+ write (istat,'(a5,14a12)')"# ",
+ & (ename(print_order(i)),i=1,nprint_ene),"ETOT total"
+ endif
+ do while (.not. eof)
+ if (read_cart) then
+ read (intin,'(e15.10,e15.5)',end=1100,err=1100) time,ene
+ call read_x(intin,*11)
+#ifdef MPI
+c Broadcast the order to compute internal coordinates to the slaves.
+ if (nfgtasks.gt.1)
+ & call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
+#endif
+ call int_from_cart1(.false.)
+ else
+ read (intin,'(i5)',end=1100,err=1100) iconf
+ call read_angles(intin,*11)
+ call geom_to_var(nvar,varia)
+ call chainbuild
+ endif
+ write (iout,'(a,i7)') 'Conformation #',iconf
+ if (minim) call minimize(etot,varia,iretcode,nfun)
+ call etotal(energy(0))
+
+ etot=energy(0)
+ call enerprint(energy(0))
+ if (minim) call briefout(it,etot)
+ if (refstr) then
+ call rms_nac_nnc(rms,frac,frac_nn,co,.true.)
+ write (istat,'(i5,18(f12.3))') iconf,
+ & (energy(print_order(i)),i=1,nprint_ene),
+ & etot,rms,frac,frac_nn,co
+cjlee end
+ else
+ write (istat,'(i5,14(f12.3))') iconf,
+ & (energy(print_order(i)),i=1,nprint_ene),etot
+ endif
+ enddo
+ 11 continue
+ 1100 continue
+#endif
+ return
+ end
+c---------------------------------------------------------------------------
+ subroutine exec_checkgrad
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.SETUP'
+ include 'COMMON.TIME1'
+ include 'COMMON.INTERACT'
+ include 'COMMON.NAMES'
+ include 'COMMON.GEO'
+ include 'COMMON.HEADER'
+ include 'COMMON.CONTROL'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.VAR'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.FFIELD'
+ include 'COMMON.REMD'
+ include 'COMMON.MD'
+ include 'COMMON.SBRIDGE'
+ common /srutu/ icall
+ double precision energy(0:max_ene)
+c do i=2,nres
+c vbld(i)=vbld(i)+ran_number(-0.1d0,0.1d0)
+c if (itype(i).ne.10)
+c & vbld(i+nres)=vbld(i+nres)+ran_number(-0.001d0,0.001d0)
+c enddo
+ if (indpdb.eq.0) call chainbuild
+c do i=0,nres
+c do j=1,3
+c dc(j,i)=dc(j,i)+ran_number(-0.2d0,0.2d0)
+c enddo
+c enddo
+c do i=1,nres-1
+c if (itype(i).ne.10) then
+c do j=1,3
+c dc(j,i+nres)=dc(j,i+nres)+ran_number(-0.2d0,0.2d0)
+c enddo
+c endif
+c enddo
+c do j=1,3
+c dc(j,0)=ran_number(-0.2d0,0.2d0)
+c enddo
+ usampl=.true.
+ totT=1.d0
+ eq_time=0.0d0
+ call read_fragments
+ read(inp,*) t_bath
+ call rescale_weights(t_bath)
+ call chainbuild_cart
+ call cartprint
+ call intout
+ icall=1
+ call etotal(energy(0))
+ etot = energy(0)
+ call enerprint(energy(0))
+ write (iout,*) "Uconst",Uconst," Uconst_back",uconst_back
+ print *,'icheckgrad=',icheckgrad
+ goto (10,20,30) icheckgrad
+ 10 call check_ecartint
+ return
+ 20 call check_cartgrad
+ return
+ 30 call check_eint
+ return
+ end
+c---------------------------------------------------------------------------
+ subroutine exec_map
+C Energy maps
+ call map_read
+ call map
+ return
+ end
+c---------------------------------------------------------------------------
+ subroutine exec_CSA
+#ifdef MPI
+ include "mpif.h"
+#endif
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+C Conformational Space Annealling programmed by Jooyoung Lee.
+C This method works only with parallel machines!
+#ifdef MPI
+csa call together
+ write (iout,*) "CSA is not supported in this version"
+#else
+csa write (iout,*) "CSA works on parallel machines only"
+ write (iout,*) "CSA is not supported in this version"
+#endif
+ return
+ end
+c---------------------------------------------------------------------------
+ subroutine exec_softreg
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.CONTROL'
+ double precision energy(0:max_ene)
+ logical debug /.false./
+ call chainbuild
+ call etotal(energy(0))
+ call enerprint(energy(0))
+ if (.not.lsecondary) then
+ write(iout,*) 'Calling secondary structure recognition'
+ call secondary2(debug)
+ else
+ write(iout,*) 'Using secondary structure supplied in pdb'
+ endif
+
+ call softreg
+
+ call etotal(energy(0))
+ etot=energy(0)
+ call enerprint(energy(0))
+ call intout
+ call briefout(0,etot)
+ call secondary2(.true.)
+ if (refstr) call rms_nac_nnc(rms,frac,frac_nn,co,.true.)
+ return
+ end
projects / unres.git / commitdiff