From: Bartlomiej Zaborowski Date: Wed, 26 Sep 2012 13:43:23 +0000 (+0200) Subject: "Przygotowanie CSA do D i L aminokwasow" X-Git-Tag: v.3.2~67^2~5^2~5 X-Git-Url: http://mmka.chem.univ.gda.pl/gitweb/?a=commitdiff_plain;h=8055c4bbbbc16fd9499bf70d85f9a94697170300;hp=779173c6af2a1c8afd3662164233a3c858984f7f;p=unres.git "Przygotowanie CSA do D i L aminokwasow" --- diff --git a/source/unres/src_CSA_DiL/CMakeLists.txt b/source/unres/src_CSA_DiL/CMakeLists.txt new file mode 100644 index 0000000..8ee5798 --- /dev/null +++ b/source/unres/src_CSA_DiL/CMakeLists.txt @@ -0,0 +1,320 @@ +# +# CMake project file for UNRES CSA version +# + +enable_language (Fortran) + +#================================ +# Set source file lists +#================================ +set(UNRES_CSA_SRC0 + arcos.f + banach.f + bank.F + cartder.F + cartprint.f + chainbuild.F + checkder_p.F + contact.f + convert.f + cored.f + csa.f + dfa.F + diff12.f + distfit.f + djacob.f + econstr_local.F + elecont.f + energy_p_new_barrier.F + fitsq.f + gen_rand_conf.F + geomout_min.F + gradient_p.F + indexx.f + initialize_p.F + intcartderiv.F + intcor.f + intlocal.f + int_to_cart.f + local_move.f + matmult.f + minimize_p.F + minim_jlee.F + minim_mult.F + misc.f + MP.F + newconf.F + parmread.F + pinorm.f + printmat.f + prng_32.F + randgens.f + ran.f + readpdb.F + readrtns_csa.F + rescode.f + rmdd.f + rmsd.F + sc_move.F + shift.F + sumsld.f + test.F + timing.F + TMscore_subroutine.f + together.F + unres_csa.F +) + +set(UNRES_CSA_SRC3 energy_p_new_barrier.F gradient_p.F ) + +set(UNRES_CSA_PP_SRC + bank.F + cartder.F + chainbuild.F + checkder_p.F + dfa.F + econstr_local.F + energy_p_new_barrier.F + gen_rand_conf.F + geomout_min.F + gradient_p.F + initialize_p.F + intcartderiv.F + minimize_p.F + minim_jlee.F + minim_mult.F + MP.F + newconf.F + parmread.F + prng_32.F + readpdb.F + readrtns_csa.F + rmsd.F + sc_move.F + shift.F + test.F + timing.F + together.F + unres_csa.F +) + + +#================================================ +# Set comipiler flags for different sourcefiles +#================================================ +if (Fortran_COMPILER_NAME STREQUAL "ifort") + set(FFLAGS0 "-c -ip -w" ) + set(FFLAGS1 "-c -w -g -d2 -CA -CB" ) + set(FFLAGS2 "-c -w -g -00 ") + #set(FFLAGS3 "-c -w -O3 -ipo -ipo_obj -opt_report" ) + set(FFLAGS3 "-c -w -ipo " ) +elseif (Fortran_COMPILER_NAME STREQUAL "gfortran") + set(FFLAGS0 "-cpp -c -I. ") + set(FFLAGS1 "-cpp -c -g -I. " ) + set(FFLAGS2 "-cpp -c -I. ") + #set(FFLAGS3 "-c -w -O3 -ipo -ipo_obj -opt_report" ) + set(FFLAGS3 "-cpp -c -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_CSA_SRC0} PROPERTY COMPILE_FLAGS ${FFLAGS0} ) +set_property(SOURCE ${UNRES_CSA_SRC1} PROPERTY COMPILE_FLAGS ${FFLAGS1} ) +set_property(SOURCE ${UNRES_CSA_SRC2} PROPERTY COMPILE_FLAGS ${FFLAGS2} ) +set_property(SOURCE ${UNRES_CSA_SRC3} PROPERTY COMPILE_FLAGS ${FFLAGS3} ) + +#========================================= +# Settings for CSA force fields +#========================================= + +if(UNRES_CSA_FF STREQUAL "CASP3" ) + set(CPPFLAGS "PROCOR -DUNRES -DISNAN -DSPLITELE -DLANG0 -DCRYST_TOR -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DMOMENT" ) +elseif(UNRES_CSA_FF STREQUAL "ALPHA") + set(CPPFLAGS "PROCOR -DUNRES -DISNAN -DSPLITELE -DLANG0 -DMOMENT -DCRYST_BOND -DCRYST_THETA -DCRYST_SC" ) +elseif(UNRES_CSA_FF STREQUAL "BETA") + set(CPPFLAGS "PROCOR -DUNRES -DISNAN -DSPLITELE -DLANG0 -DMOMENT -DCRYST_BOND -DCRYST_THETA -DCRYST_SC" ) +elseif(UNRES_CSA_FF STREQUAL "ALPHABETA") + set(CPPFLAGS "PROCOR -DUNRES -DISNAN -DSPLITELE -DLANG0 -DMOMENT -DCRYST_BOND -DCRYST_THETA -DCRYST_SC" ) +elseif(UNRES_CSA_FF STREQUAL "CASP5") + set(CPPFLAGS "PROCOR -DUNRES -DISNAN -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC" ) +elseif(UNRES_CSA_FF STREQUAL "3P") + set(CPPFLAGS "PROCOR -DUNRES -DISNAN -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC" ) +elseif(UNRES_CSA_FF STREQUAL "4P") + set(CPPFLAGS "PROCOR -DUNRES -DISNAN -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC" ) +endif(UNRES_CSA_FF STREQUAL "CASP3") + +#========================================= +# System specific flags +#========================================= +if(${CMAKE_SYSTEM_NAME} MATCHES "Linux") + set(CPPFLAGS "${CPPFLAGS} -DLINUX") +endif(${CMAKE_SYSTEM_NAME} MATCHES "Linux") + +#========================================= +# Compiler specific flags +#========================================= + +if (Fortran_COMPILER_NAME STREQUAL "ifort") + # Add ifort preprocessor flags + set(CPPFLAGS "${CPPFLAGS} -DPGI") +elseif (Fortran_COMPILER_NAME STREQUAL "f95") + # Add new gfortran flags + set(CPPFLAGS "${CPPFLAGS} -DG77") +elseif (Fortran_COMPILER_NAME STREQUAL "gfortran") + # Add old gfortran flags + set(CPPFLAGS "${CPPFLAGS} -DG77") +endif (Fortran_COMPILER_NAME STREQUAL "ifort") + +#========================================= +# Add MPI preprocessor flags +#========================================= +set(CPPFLAGS "${CPPFLAGS} -DMP -DMPI") + +# Apply preprocesor flags to *.F files +set_property(SOURCE ${UNRES_CSA_PP_SRC} PROPERTY COMPILE_DEFINITIONS ${CPPFLAGS} ) + + +#======================================== +# Setting binary name +#======================================== +set(UNRES_BIN "unresCSA_${Fortran_COMPILER_NAME}_${UNRES_CSA_FF}.exe") + +#========================================= +# cinfo.f workaround for CMake +#========================================= +# get current time +TODAY(DATE) +# generate cinfo.f +FILE(WRITE ${CMAKE_CURRENT_BINARY_DIR}/cinfo.f +"C CMake generated file + subroutine cinfo + include 'COMMON.IOUNITS' + write(iout,*)'++++ Compile info ++++' + write(iout,*)'Version ${UNRES_MAJOR}.${UNRES_MINOR} build ${UNRES_PATCH}' + write(iout,*)'Compiled ${DATE}' + write(iout,*)'Compiled by $ENV{USER}@$ENV{HOST}' + write(iout,*)'OS name: ${CMAKE_SYSTEM_NAME}' + write(iout,*)'OS release: ${CMAKE_SYSTEM}' + write(iout,*)'FC: ${CMAKE_Fortran_COMPILER}' + write(iout,*)'CSA Force field: ${UNRES_CSA_FF}' + write(iout,*)'++++ End of compile info ++++' + return + end +") +# set include path +set_property(SOURCE ${CMAKE_CURRENT_BINARY_DIR}/cinfo.f PROPERTY COMPILE_FLAGS "${FFLAGS0} -I${CMAKE_CURRENT_SOURCE_DIR}" ) + +#========================================= +# Set full unres CSA sources +#========================================= +set(UNRES_CSA_SRCS ${UNRES_CSA_SRC0} ${UNRES_CSA_SRC3} ${CMAKE_CURRENT_BINARY_DIR}/cinfo.f ) + +#========================================= +# Build the binary +#========================================= +add_executable(UNRES_BIN-CSA ${UNRES_CSA_SRCS} ) +set_target_properties(UNRES_BIN-CSA 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) +target_link_libraries( UNRES_BIN-CSA ${MPIF_LIBRARIES} ) +# link libxdrf.a +#target_link_libraries( ${UNRES_BIN} xdrf ) + +#========================================= +# TESTS +#========================================= + +#-- Copy all the data files from the test directory into the source directory +#SET(UNRES_TEST_FILES +# ala10.inp +# ) + +#FOREACH (UNRES_TEST_FILE ${UNRES_TEST_FILES}) +# SET (unres_test_dest "${CMAKE_CURRENT_BINARY_DIR}/${UNRES_TEST_FILE}") +# MESSAGE (STATUS " Copying ${UNRES_TEST_FILE} from ${CMAKE_SOURCE_DIR}/examples/unres/MD/ff_gab/${UNRES_TEST_FILE} to ${unres_test_dest}") +# ADD_CUSTOM_COMMAND ( +# TARGET ${UNRES_BIN} +# POST_BUILD +# COMMAND ${CMAKE_COMMAND} -E copy ${CMAKE_SOURCE_DIR}/examples/unres/MD/ff_gab/${UNRES_TEST_FILE} ${unres_test_dest} +# ) +#ENDFOREACH (UNRES_TEST_FILE ${UNRES_TEST_FILES}) + +#========================================= +# Generate data test files +#========================================= +# test_single_ala.sh +#========================================= + +#FILE(WRITE ${CMAKE_CURRENT_BINARY_DIR}/test_single_ala.sh +#"#!/bin/sh +#export POT=GB +#export PREFIX=ala10 +#----------------------------------------------------------------------------- +#UNRES_BIN=./${UNRES_BIN} +#----------------------------------------------------------------------------- +#DD=${CMAKE_SOURCE_DIR}/PARAM +#export BONDPAR=$DD/bond.parm +#export THETPAR=$DD/thetaml.5parm +#export ROTPAR=$DD/scgauss.parm +#export TORPAR=$DD/torsion_631Gdp.parm +#export TORDPAR=$DD/torsion_double_631Gdp.parm +#export ELEPAR=$DD/electr_631Gdp.parm +#export SIDEPAR=$DD/sc_GB_opt.1gab_3S_qclass5no310-shan2-sc-16-10-8k +#export FOURIER=$DD/fourier_opt.parm.1igd_hc_iter3_3 +#export SCPPAR=$DD/scp.parm +#export SCCORPAR=$DD/rotcorr_AM1.parm +#export PATTERN=$DD/patterns.cart +#----------------------------------------------------------------------------- +#$UNRES_BIN +#") + +#========================================= +# ala10.inp +#========================================= + +#file(WRITE ${CMAKE_CURRENT_BINARY_DIR}/ala10.inp +#"ala10 unblocked +#SEED=-1111333 MD ONE_LETTER rescale_mode=2 PDBOUT +#nstep=15000 ntwe=100 ntwx=1000 dt=0.1 lang=0 tbf t_bath=300 damax=1.0 & +#reset_moment=1000 reset_vel=1000 MDPDB +#WLONG=1.35279 WSCP=1.59304 WELEC=0.71534 WBOND=1.00000 WANG=1.13873 & +#WSCLOC=0.16258 WTOR=1.98599 WTORD=1.57069 WCORRH=0.42887 WCORR5=0.00000 & +#WCORR6=0.00000 WEL_LOC=0.16036 WTURN3=1.68722 WTURN4=0.66230 WTURN6=0.00000 & +#WVDWPP=0.11371 WHPB=1.00000 & +#CUTOFF=7.00000 WCORR4=0.00000 +#12 +#XAAAAAAAAAAX +# 0 +# 0 +# 90.0000 90.0000 90.0000 90.000 90.000 90.000 90.000 90.000 +# 90.0000 90.0000 +# 180.0000 180.0000 180.0000 180.000 180.000 180.000 180.000 180.000 +# 180.0000 +# 110.0000 110.0000 110.0000 100.000 110.000 100.000 110.000 110.000 +# 110.0000 110.0000 +# -120.0000 -120.0000 -120.000 -120.000 -120.000 -120.000 -120.000 -120.000 +# -120.0000 -120.0000 +#") + + +# Add tests + +#if(NOT UNRES_WITH_MPI) + +# add_test(NAME UNRES_MD_Ala10 COMMAND sh ${CMAKE_CURRENT_BINARY_DIR}/test_single_ala.sh ) + +#endif(NOT UNRES_WITH_MPI) + diff --git a/source/unres/src_CSA_DiL/COMMON.BANK b/source/unres/src_CSA_DiL/COMMON.BANK new file mode 100644 index 0000000..5b0fb34 --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.BANK @@ -0,0 +1,29 @@ + real*8 dihang,etot,bvar,bene,rene,rvar,avedif,difmin, + & ebmin,ebmax,ebmaxt,cutdif,dij,dihang_in + integer ibank,is,jbank,ibmin,ibmax,nbank,nconf,iuse,nstep,icycle, + & iseed,ntbank,ntbankm,iref,nconf_in,indb,ilastnstep, + & bvar_nss,bvar_ss,bvar_ns,bvar_s, + & nss_in,iss_in,jss_in,nadd + common/varin/dihang_in(mxang,maxres,mxch,mxio),nss_in(mxio), + & iss_in(maxss,mxio),jss_in(maxss,mxio) + common/minvar/dihang(mxang,maxres,mxch,mxio),etot(mxio),rmsn(mxio) + & ,pncn(mxio),nss_out(mxio), + & iss_out(maxss,mxio),jss_out(maxss,mxio) + common/bank/ + * bvar(mxang,maxres,mxch,mxio),bene(mxio),rene(mxio), + * brmsn(mxio),rrmsn(mxio), + * bpncn(mxio),rpncn(mxio), + * rvar(mxang,maxres,mxch,mxio),ibank(mxio),is(mxio), + * avedif,difmin,ebmin,ebmax,ebmaxt,dele,difcut,cutdif, + * rmscut,pnccut, + * jbank(mxio),dij(mxio,mxio),ibmin,ibmax, + * nbank,ntbank,ntbankm,nconf,iuse,nstep,icycle,iseed,iref, + * nconf_in,ilastnstep,nadd + common/bank_disulfid/ bvar_nss(mxio),bvar_ss(2,maxss,mxio), + * bvar_ns(mxio),bvar_s(maxss,mxio) + common/mvstat/ movenx(mxio),movernx(mxio), + & nstatnx(0:mxmv,3),nstatnx_tot(0:mxmv,3),indb(mxio,9), + & parent(3,mxio) + common/send2/isend2(mxio),iff_in(maxres,mxio2), + & dihang_in2(mxang,maxres,mxch,mxio2), + & idata(5,mxio) diff --git a/source/unres/src_CSA_DiL/COMMON.BOUNDS b/source/unres/src_CSA_DiL/COMMON.BOUNDS new file mode 100644 index 0000000..f3859ae --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.BOUNDS @@ -0,0 +1,2 @@ + double precision phibound(2,maxres) + common /bounds/ phibound diff --git a/source/unres/src_CSA_DiL/COMMON.CALC b/source/unres/src_CSA_DiL/COMMON.CALC new file mode 100644 index 0000000..67b4bb9 --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.CALC @@ -0,0 +1,15 @@ + integer i,j,k,l + double precision erij,rij,xj,yj,zj,dxi,dyi,dzi,dxj,dyj,dzj, + & chi1,chi2,chi12,chip1,chip2,chip12,alf1,alf2,alf12,om1,om2,om12, + & om1om2,chiom1,chiom2,chiom12,chipom1,chipom2,chipom12,eps1, + & faceps1,faceps1_inv,eps1_om12,facsig,sigsq,sigsq_om1,sigsq_om2, + & sigsq_om12,facp,facp_inv,facp1,eps2rt,eps2rt_om1,eps2rt_om2, + & eps2rt_om12,eps3rt,eom1,eom2,eom12,evdwij,eps2der,eps3der,sigder, + & dsci_inv,dscj_inv,gg + common /calc/ erij(3),rij,xj,yj,zj,dxi,dyi,dzi,dxj,dyj,dzj, + & chi1,chi2,chi12,chip1,chip2,chip12,alf1,alf2,alf12,om1,om2,om12, + & om1om2,chiom1,chiom2,chiom12,chipom1,chipom2,chipom12,eps1, + & faceps1,faceps1_inv,eps1_om12,facsig,sigsq,sigsq_om1,sigsq_om2, + & sigsq_om12,facp,facp_inv,facp1,eps2rt,eps2rt_om1,eps2rt_om2, + & eps2rt_om12,eps3rt,eom1,eom2,eom12,evdwij,eps2der,eps3der,sigder, + & dsci_inv,dscj_inv,gg(3),i,j diff --git a/source/unres/src_CSA_DiL/COMMON.CHAIN b/source/unres/src_CSA_DiL/COMMON.CHAIN new file mode 100644 index 0000000..f7a8a1d --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.CHAIN @@ -0,0 +1,12 @@ + 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 + 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 + 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 diff --git a/source/unres/src_CSA_DiL/COMMON.CONTACTS b/source/unres/src_CSA_DiL/COMMON.CONTACTS new file mode 100644 index 0000000..dfc8da2 --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.CONTACTS @@ -0,0 +1,75 @@ +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 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 diff --git a/source/unres/src_CSA_DiL/COMMON.CONTACTS.MOMENT b/source/unres/src_CSA_DiL/COMMON.CONTACTS.MOMENT new file mode 100644 index 0000000..16fae0e --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.CONTACTS.MOMENT @@ -0,0 +1,7 @@ +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. + double precision dip,dipderg,dipderx + common /dipint/ dip(4,maxconts,maxres),dipderg(4,maxconts,maxres), + & dipderx(3,5,4,maxconts,maxres) diff --git a/source/unres/src_CSA_DiL/COMMON.CONTROL b/source/unres/src_CSA_DiL/COMMON.CONTROL new file mode 100644 index 0000000..c12ef3a --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.CONTROL @@ -0,0 +1,13 @@ + 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 diff --git a/source/unres/src_CSA_DiL/COMMON.CSA b/source/unres/src_CSA_DiL/COMMON.CSA new file mode 100644 index 0000000..9c117c0 --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.CSA @@ -0,0 +1,11 @@ + integer ngroup,igroup,ntotgr,numch,irestart,ndiff,nbankm,iucut + double precision diffcut + common/alphaa/ ngroup(mxgr),igroup(3,mxang,mxgr),ntotgr,numch + common/csa_input/cut1,cut2,eglob_csa,estop,jstart,jend, + & n1,n2,n3,n4,n5,n6,n7,n8,n9,n14,n15,n16,n17,n18,n0, + & is1,is2,nseed,ntotal,icmax,nstmax,irestart,nran0,nran1,irr, + & nglob_csa,nmin_csa,ndiff,nbankm,iucut + logical ldih_bias,tm_score + common/dih_control/rdih_bias,ldih_bias,tm_score + common/diffcuta/ diffcut + diff --git a/source/unres/src_CSA_DiL/COMMON.DERIV b/source/unres/src_CSA_DiL/COMMON.DERIV new file mode 100644 index 0000000..4cf9f16 --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.DERIV @@ -0,0 +1,38 @@ + 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 , + & gdfad(3,maxres),gdfat(3,maxres),gdfan(3,maxres),gdfab(3,maxres) + + double precision derx,derx_turn + common /deriv_loc/ derx(3,5,2),derx_turn(3,5,2) + double precision dXX_C1tab(3,maxres),dYY_C1tab(3,maxres), + & dZZ_C1tab(3,maxres),dXX_Ctab(3,maxres),dYY_Ctab(3,maxres), + & dZZ_Ctab(3,maxres),dXX_XYZtab(3,maxres),dYY_XYZtab(3,maxres), + & dZZ_XYZtab(3,maxres) + common /deriv_scloc/ dXX_C1tab,dYY_C1tab,dZZ_C1tab,dXX_Ctab, + & dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,dZZ_XYZtab + integer igrad_start,igrad_end,jgrad_start(maxres), + & jgrad_end(maxres) + common /mpgrad/ igrad_start,igrad_end,jgrad_start,jgrad_end diff --git a/source/unres/src_CSA_DiL/COMMON.DFA b/source/unres/src_CSA_DiL/COMMON.DFA new file mode 100644 index 0000000..1c750cf --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.DFA @@ -0,0 +1,101 @@ +C ======= +C COMMON.DFA +C ======= +C 2010/12/20 By Juyong Lee +C +c parameter +C [ 8 * ( Nres - 8 ) ] distance restraints +C [ 2 * ( Nres - 8 ) ] angle restraints +C [ Nres ] neighbor restraints +C Total : ~ 11 * Nres restraints +C +C + INTEGER IDFAMAX,IDFAMX2,IDFACMD,IDMAXMIN, MAXN + PARAMETER(IDFAMAX=4000,IDFAMX2=1000,IDFACMD=500,IDMAXMIN=500) + PARAMETER(MAXN=4) + real*8 wwdist,wwangle,wwnei + parameter(wwdist=1.0d0,wwangle=1.0d0,wwnei=1.0d0) + +C IDFAMAX - maximum number of DFA restraint including distance, angle and +C number of neighbors ( Max of assign statement ) +C IDFAMX2 - maximum number of atoms which are targets of restraints +C IDFACMD - maximum number of 'DFA' command call +C IDMAXMIN - Maximum number of minima of dist, angle and neighbor info. from fragments +C MAXN - Maximum Number of shell, currently 4 +C MAXRES - Maximum number of CAs + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCc +C INTEGER +C DFANUM - Number of ALL DFA restrants +c IDFA[DIS, PHI, THE, NEI] - NUMBER of restraints +c IDISNUM - number of minima for a distance restraint +c IPHINUM - number of minima for a phi angle restraint +c ITHENUM - number of minima for a theta angle restraint +c INEINUM - number of minima for a number of neighbors restraint + +c IDISLIS - atom number of two atoms for distance restraint +c IPHILIS - atom numbers of four atoms for angle restraint +c ITHELIS - atom numbers of four atoms for angle restraint +c INEILIS - atom number of center of neighbor calculation +c JNEILIS - atom number of target of neighboring calculation +c JNEINUM - number of target atoms of neighboring term +C KSHELL - SHELL number + +C ishiftca - index shift for CA atoms in UNRES (1 if the 1st aa != GLY) +C ilastca - index of the last CA atom in UNRES (nres-1 if last aa != GLY) + +C old only for CHARMM +C STOAGDF - Store assign information ( How many assign within one command ) +C NMAP - mapping between dfanum and ndis, nphi, nthe, nnei + + INTEGER IDFADIS,IDFAPHI,IDFATHE,IDFANEI, + & IDISLIS,IPHILIS,ITHELIS,INEILIS, + & IDISNUM,IPHINUM,ITHENUM,INEINUM, + & FNEI, + & NCA,ICAIDX, + & STOAGDF, NMAP, IDFACAT, KDISNUM, KSHELL + & ishiftca,ilastca + COMMON /IDFA/ DFACMD, DFANUM, + & IDFADIS, IDFAPHI, IDFANEI, IDFATHE, + & IDISNUM(IDFAMAX), IPHINUM(IDFAMAX), + & ITHENUM(IDFAMAX), INEINUM(IDFAMAX), + & FNEI(IDFAMAX,IDMAXMIN), IDISLIS(2,IDFAMAX), + & IPHILIS(5,IDFAMAX), ITHELIS(5,IDFAMAX), + & INEILIS(IDFAMAX), + & KSHELL(IDFAMAX), + & IDFACAT(IDFACMD), + & KDISNUM(IDFAMAX), + & NCA, ICAIDX(MAXRES) + COMMON /IDFA2/ ishiftca,ilastca + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C REAL VARIABLES +C +c SCC[DIST, PHI, THE] - weight of each calculations +c FDIST - distance minima +C FPHI - phi minima +c FTHE - theta minima +C DFAEXP : calculate expential function in advance +C + REAL*8 SCCDIST, SCCPHI, SCCTHE, SCCNEI, FDIST, FPHI1, FPHI2, + & FTHE1, FTHE2, + & DIS_INC, PHI_INC, THE_INC, NEI_INC, BETA_INC, + & WSHET, EDFABET, + & CK, SCK +c & ,DFAEXP + + COMMON /RDFA/ SCCDIST(IDFAMAX,IDMAXMIN),FDIST(IDFAMAX,IDMAXMIN), + & SCCPHI(IDFAMAX,IDMAXMIN), SCCTHE(IDFAMAX,IDMAXMIN), + & SCCNEI(IDFAMAX,IDMAXMIN), + & FPHI1(IDFAMAX,IDMAXMIN), FPHI2(IDFAMAX,IDMAXMIN), + & FTHE1(IDFAMAX,IDMAXMIN), FTHE2(IDFAMAX,IDMAXMIN), + & DIS_INC, PHI_INC, THE_INC, NEI_INC, BETA_INC, + & WSHET(MAXRES,MAXRES), EDFABET, + & CK(4),SCK(4),S1(4),S2(4) +c & ,DFAEXP(15001), + + DATA CK/1.0D0,1.58740105197D0,2.08008382305D0,2.51984209979D0/ + DATA SCK/1.0D0,1.25992104989D0,1.44224957031D0,1.58740105197D0/ + DATA S1/3.75D0,5.75D0,7.75D0,9.75D0/ + DATA S2/4.25D0,6.25D0,8.25D0,10.25D0/ diff --git a/source/unres/src_CSA_DiL/COMMON.DISTFIT b/source/unres/src_CSA_DiL/COMMON.DISTFIT new file mode 100644 index 0000000..044225b --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.DISTFIT @@ -0,0 +1,14 @@ +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) + COMMON /frag/ bvar_frag(mxio,6),hvar_frag(mxio,3), + 1 lvar_frag(mxio,3),svar_frag(mxio,3), + 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 diff --git a/source/unres/src_CSA_DiL/COMMON.FFIELD b/source/unres/src_CSA_DiL/COMMON.FFIELD new file mode 100644 index 0000000..29c73f0 --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.FFIELD @@ -0,0 +1,26 @@ +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, + & wdfa_dist,wdfa_tor,wdfa_nei,wdfa_beta, + & scal14,cutoff_corr,delt_corr,r0_corr,ipot,n_ene_comp, + & rescale_mode + common /potentials/ potname(5) + character*3 potname +C----------------------------------------------------------------------- +C wlong,welec,wtor,wang,wscloc are the weight of the energy terms +C corresponding to side-chain, electrostatic, torsional, valence-angle, +C and local side-chain terms. +C +C IPOT determines which SC...SC interaction potential will be used: +C 1 - LJ: 2n-n Lennard-Jones +C 2 - LJK: 2n-n Kihara type (shifted Lennard-Jones) +C 3 - BP; Berne-Pechukas (angular dependence) +C 4 - GB; Gay-Berne (angular dependence) +C 5 - GBV; Gay-Berne-Vorobjev; angularly-dependent Kihara potential +C------------------------------------------------------------------------ diff --git a/source/unres/src_CSA_DiL/COMMON.GEO b/source/unres/src_CSA_DiL/COMMON.GEO new file mode 100644 index 0000000..8cfbbde --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.GEO @@ -0,0 +1,2 @@ + double precision pi,dwapi,pipol,pi3,dwapi3,deg2rad,rad2deg,angmin + common /geo/ pi,dwapi,pipol,pi3,dwapi3,deg2rad,rad2deg,angmin diff --git a/source/unres/src_CSA_DiL/COMMON.HAIRPIN b/source/unres/src_CSA_DiL/COMMON.HAIRPIN new file mode 100644 index 0000000..f103268 --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.HAIRPIN @@ -0,0 +1,5 @@ + 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 diff --git a/source/unres/src_CSA_DiL/COMMON.HEADER b/source/unres/src_CSA_DiL/COMMON.HEADER new file mode 100644 index 0000000..7154812 --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.HEADER @@ -0,0 +1,2 @@ + character*80 titel + common /header/ titel diff --git a/source/unres/src_CSA_DiL/COMMON.INFO b/source/unres/src_CSA_DiL/COMMON.INFO new file mode 100644 index 0000000..4f63708 --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.INFO @@ -0,0 +1,21 @@ +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 diff --git a/source/unres/src_CSA_DiL/COMMON.INTERACT b/source/unres/src_CSA_DiL/COMMON.INTERACT new file mode 100644 index 0000000..fabad93 --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.INTERACT @@ -0,0 +1,34 @@ + 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) diff --git a/source/unres/src_CSA_DiL/COMMON.IOUNITS b/source/unres/src_CSA_DiL/COMMON.IOUNITS new file mode 100644 index 0000000..49b6db3 --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.IOUNITS @@ -0,0 +1,69 @@ +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----------------------------------------------------------------------- diff --git a/source/unres/src_CSA_DiL/COMMON.LOCAL b/source/unres/src_CSA_DiL/COMMON.LOCAL new file mode 100644 index 0000000..837a7a3 --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.LOCAL @@ -0,0 +1,53 @@ + 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,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,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) diff --git a/source/unres/src_CSA_DiL/COMMON.LOCMOVE b/source/unres/src_CSA_DiL/COMMON.LOCMOVE new file mode 100644 index 0000000..211516d --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.LOCMOVE @@ -0,0 +1,19 @@ +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) diff --git a/source/unres/src_CSA_DiL/COMMON.MAXGRAD b/source/unres/src_CSA_DiL/COMMON.MAXGRAD new file mode 100644 index 0000000..285241a --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.MAXGRAD @@ -0,0 +1,12 @@ + 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 diff --git a/source/unres/src_CSA_DiL/COMMON.MCM b/source/unres/src_CSA_DiL/COMMON.MCM new file mode 100644 index 0000000..576f912 --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.MCM @@ -0,0 +1,70 @@ +C... Following COMMON block contains general variables controlling the MC/MCM +C... procedure +c----------------------------------------------------------------------------- + double precision Tcur,Tmin,Tmax,TstepH,TstepC,RanFract, + & overlap_cut,e_up,delte + integer nstepH,nstepC,maxacc,maxgen,maxtrial,maxtrial_iter, + & maxrepm,ngen,ntrial,ntherm,nrepm,neneval,nsave,maxoverlap, + & nsave_part,max_mcm_it,nsweep,print_mc + logical print_stat,print_int + common /mcm/ Tcur,Tmin,Tmax,TstepH,TstepC,Rbol,betbol,RanFract, + & overlap_cut,e_up,delte, + & nstepH,nstepC,maxacc,maxgen,maxtrial,maxtrial_iter,maxrepm, + & maxoverlap,ntrial,max_mcm_it, + & ngen,ntherm,nrepm,neneval,nsave,nsave_part(max_cg_procs),nsweep, + & print_mc,print_stat,print_int +c----------------------------------------------------------------------------- +C... The meaning of the above variables is as follows: +C... Tcur,Tmin,Tmax - Current,minimum and maximum temperature, respectively; +C... NstepC,NStepH - Number of cooling and heating steps, respectively; +C... TstepH,TstepC - factors by which T is multiplied in order to be +C... increased or decreased. +C... betbol - Boltzmann's inverse temperature (1/(Rbol*Tcur)); +C... Rbol - the gas constant; +C... RanFract - the chance that a new conformation will be random-generated; +C... maxacc - maximum number of accepted conformations; +C... maxgen,ngen - Maximum and current number of generated conformations; +C... maxtrial,ntrial - maximum number of trials before temperature is increased +C... and current number of trials, respectively; +C... maxrepm,nrepm - maximum number of allowed minima repetition and current +C... number of minima repetitions, respectively; +C... maxoverlap - max. # of overlapping confs generated in a single iteration; +C... neneval - number of energy evaluations; +C... nsave - number of confs. in the backup array; +C... nsweep - the number of macroiterations in generating the distributions. +c------------------------------------------------------------------------------ +C... Following COMMON block contains variables controlling motion. +c------------------------------------------------------------------------------ + double precision sumpro_type,sumpro_bond + integer koniecl, Nbm,MaxSideMove,nmove,moves(-1:MaxMoveType+1), + & moves_acc(-1:MaxMoveType+1),nacc_tot,nacc_part(0:MaxProcs) + common /move/ sumpro_type(0:MaxMoveType),sumpro_bond(0:maxres), + & koniecl,Nbm,MaxSideMove,nmove,nbond_move(maxres), + & nbond_acc(maxres),moves,moves_acc + common /accept_stats/ nacc_tot,nacc_part + integer nwindow,winstart,winend,winlen + common /windows/ nwindow,winstart(maxres),winend(maxres), + & winlen(maxres) + character*16 MovTypID + common /moveID/ MovTypID(-1:MaxMoveType+1) +c------------------------------------------------------------------------------ +C... koniecl - the number of bonds to be considered "end bonds" subjected to +C... end moves; +C... Nbm - The maximum length of N-bond segment to be moved; +C... MaxSideMove - maximum number of side chains subjected to local moves +C... simultaneously; +C... nmove - the current number of attempted moves; +C... nbond_move(*) array that stores the total numbers of 2-bond,3-bond,... +C... moves; +C... nendmove - number of endmoves; +C... nbackmove - number of backbone moves; +C... nsidemove - number of local side chain moves; +C... sumpro_type(*) - array that stores the lower and upper boundary of the +C... random-number range that determines the type of move +C... (N-bond, backbone or side chain); +C... sumpro_bond(*) - array that stores the probabilities to perform bond +C... moves of consecutive segment length. +C... winstart(*) - the starting position of the perturbation window; +C... winend(*) - the end position of the perturbation window; +C... winlen(*) - length of the perturbation window; +C... nwindow - the number of perturbation windows (0 - entire chain). diff --git a/source/unres/src_CSA_DiL/COMMON.MD_ b/source/unres/src_CSA_DiL/COMMON.MD_ new file mode 100644 index 0000000..22dba7c --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.MD_ @@ -0,0 +1,74 @@ + 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 + 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 + common /nosehoover/ glogs(maxmnh),qmass(maxmnh), + & vlogs(maxmnh),xlogs(maxmnh), + & nresn,nyosh,nnos,xiresp diff --git a/source/unres/src_CSA_DiL/COMMON.MINIM b/source/unres/src_CSA_DiL/COMMON.MINIM new file mode 100644 index 0000000..e44f9cd --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.MINIM @@ -0,0 +1,5 @@ + 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 diff --git a/source/unres/src_CSA_DiL/COMMON.NAMES b/source/unres/src_CSA_DiL/COMMON.NAMES new file mode 100644 index 0000000..e6f926b --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.NAMES @@ -0,0 +1,7 @@ + character*3 restyp + character*1 onelet + common /names/ restyp(ntyp+1),onelet(ntyp+1) + character*10 ename,wname + integer nprint_ene,print_order + common /namterm/ ename(n_ene),wname(n_ene),nprint_ene, + & print_order(n_ene) diff --git a/source/unres/src_CSA_DiL/COMMON.SBRIDGE b/source/unres/src_CSA_DiL/COMMON.SBRIDGE new file mode 100644 index 0000000..4cc80c8 --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.SBRIDGE @@ -0,0 +1,12 @@ + 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,forcon + integer ihpb,jhpb,nhpb + common /links/ dhpb(maxdim),forcon(maxdim),ihpb(maxdim), + & jhpb(maxdim),nhpb + double precision weidis + common /restraints/ weidis + integer link_start,link_end + common /links_split/ link_start,link_end diff --git a/source/unres/src_CSA_DiL/COMMON.SCCOR b/source/unres/src_CSA_DiL/COMMON.SCCOR new file mode 100644 index 0000000..5217de7 --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.SCCOR @@ -0,0 +1,6 @@ +C Parameters of the SCCOR term + double precision v1sccor,v2sccor + integer nterm_sccor + common/torsion/v1sccor(maxterm_sccor,20,20), + & v2sccor(maxterm_sccor,20,20), + & nterm_sccor diff --git a/source/unres/src_CSA_DiL/COMMON.SCROT b/source/unres/src_CSA_DiL/COMMON.SCROT new file mode 100644 index 0000000..2da7b8f --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.SCROT @@ -0,0 +1,3 @@ +C Parameters of the SC rotamers (local) term + double precision sc_parmin + common/scrot/sc_parmin(maxsccoef,20) diff --git a/source/unres/src_CSA_DiL/COMMON.SETUP b/source/unres/src_CSA_DiL/COMMON.SETUP new file mode 100644 index 0000000..5039116 --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.SETUP @@ -0,0 +1,21 @@ + integer king,idint,idreal,idchar,is_done + parameter (king=0,idint=1105,idreal=1729,idchar=1597,is_done=1) + integer me,cg_rank,fg_rank,fg_rank1,nodes,Nprocs,nfgtasks,kolor, + & koniec(0:maxprocs-1),WhatsUp,ifinish(maxprocs-1),CG_COMM,FG_COMM, + & FG_COMM1,CONT_FROM_COMM,CONT_TO_COMM,lentyp(0:maxprocs-1), + & kolor1,key1,nfgtasks1,MyRank, + & max_gs_size + logical yourjob, finished, cgdone + common/setup/me,MyRank,cg_rank,fg_rank,fg_rank1,nodes,Nprocs, + & nfgtasks,nfgtasks1, + & max_gs_size,kolor,koniec,WhatsUp,ifinish,CG_COMM,FG_COMM, + & FG_COMM1,CONT_FROM_COMM,CONT_TO_COMM,lentyp + integer MPI_UYZ,MPI_UYZGRAD,MPI_MU,MPI_MAT1,MPI_MAT2, + & MPI_THET,MPI_GAM, + & MPI_ROTAT1(0:1),MPI_ROTAT2(0:1),MPI_ROTAT_OLD(0:1), + & MPI_PRECOMP11(0:1),MPI_PRECOMP12(0:1),MPI_PRECOMP22(0:1), + & MPI_PRECOMP23(0:1) + common /types/ MPI_UYZ,MPI_UYZGRAD,MPI_MU,MPI_MAT1,MPI_MAT2, + & MPI_THET,MPI_GAM, + & MPI_ROTAT1,MPI_ROTAT2,MPI_ROTAT_OLD,MPI_PRECOMP11,MPI_PRECOMP12, + & MPI_PRECOMP22,MPI_PRECOMP23 diff --git a/source/unres/src_CSA_DiL/COMMON.SPLITELE b/source/unres/src_CSA_DiL/COMMON.SPLITELE new file mode 100644 index 0000000..a2f0447 --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.SPLITELE @@ -0,0 +1,2 @@ + double precision r_cut,rlamb + common /splitele/ r_cut,rlamb diff --git a/source/unres/src_CSA_DiL/COMMON.THREAD b/source/unres/src_CSA_DiL/COMMON.THREAD new file mode 100644 index 0000000..5c814cc --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.THREAD @@ -0,0 +1,7 @@ + integer nthread,nexcl,iexam,ipatt + double precision ener0,ener,max_time_for_thread, + & ave_time_for_thread + common /thread/ nthread,nexcl,iexam(2,maxthread), + & ipatt(2,maxthread) + common /thread1/ ener0(n_ene+2,maxthread),ener(n_ene+2,maxthread), + & max_time_for_thread,ave_time_for_thread diff --git a/source/unres/src_CSA_DiL/COMMON.TIME1 b/source/unres/src_CSA_DiL/COMMON.TIME1 new file mode 100644 index 0000000..d6203a6 --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.TIME1 @@ -0,0 +1,28 @@ + 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 diff --git a/source/unres/src_CSA_DiL/COMMON.TORCNSTR b/source/unres/src_CSA_DiL/COMMON.TORCNSTR new file mode 100644 index 0000000..e4af17c --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.TORCNSTR @@ -0,0 +1,6 @@ + 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 diff --git a/source/unres/src_CSA_DiL/COMMON.TORSION b/source/unres/src_CSA_DiL/COMMON.TORSION new file mode 100644 index 0000000..6b6605f --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.TORSION @@ -0,0 +1,23 @@ +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 diff --git a/source/unres/src_CSA_DiL/COMMON.VAR b/source/unres/src_CSA_DiL/COMMON.VAR new file mode 100644 index 0000000..71158b8 --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.VAR @@ -0,0 +1,20 @@ +C Store the geometric variables in the following COMMON block. + integer ntheta,nphi,nside,nvar,Origin,nstore,ialph,ivar, + & mask_theta,mask_phi,mask_side + double precision theta,phi,alph,omeg,varsave,esave,varall,vbld, + & thetaref,phiref,costtab,sinttab,cost2tab,sint2tab, + & xxtab,yytab,zztab,xxref,yyref,zzref + common /var/ theta(maxres),phi(maxres),alph(maxres),omeg(maxres), + & vbld(2*maxres),thetaref(maxres),phiref(maxres), + & costtab(maxres), sinttab(maxres), cost2tab(maxres), + & sint2tab(maxres),xxtab(maxres),yytab(maxres), + & zztab(maxres),xxref(maxres),yyref(maxres),zzref(maxres), + & ialph(maxres,2),ivar(4*maxres2),ntheta,nphi,nside,nvar +C Store the angles and variables corresponding to old conformations (for use +C in MCM). + common /oldgeo/ varsave(maxvar,maxsave),esave(maxsave), + & Origin(maxsave),nstore +C freeze some variables + logical mask_r + common /restr/ varall(maxvar),mask_r,mask_theta(maxres), + & mask_phi(maxres),mask_side(maxres) diff --git a/source/unres/src_CSA_DiL/COMMON.VECTORS b/source/unres/src_CSA_DiL/COMMON.VECTORS new file mode 100644 index 0000000..d880c24 --- /dev/null +++ b/source/unres/src_CSA_DiL/COMMON.VECTORS @@ -0,0 +1,3 @@ + common /vectors/ uy(3,maxres),uz(3,maxres), + & uygrad(3,3,2,maxres),uzgrad(3,3,2,maxres) + diff --git a/source/unres/src_CSA_DiL/DIMENSIONS b/source/unres/src_CSA_DiL/DIMENSIONS new file mode 100644 index 0000000..3225a09 --- /dev/null +++ b/source/unres/src_CSA_DiL/DIMENSIONS @@ -0,0 +1,139 @@ +******************************************************************************** +* 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=3) +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=27,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) +C Maximum number of generated conformations + integer mxio + parameter (mxio=1000) +C Maximum number of n7 generated conformations + integer mxio2 + parameter (mxio2=100) +C Maximum number of moves (n1-n8) + integer mxmv + parameter (mxmv=18) +C Maximum number of seed + integer max_seed + parameter (max_seed=200) +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) diff --git a/source/unres/src_CSA_DiL/MP.F b/source/unres/src_CSA_DiL/MP.F new file mode 100644 index 0000000..3b4bc70 --- /dev/null +++ b/source/unres/src_CSA_DiL/MP.F @@ -0,0 +1,516 @@ +#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' +c 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') +cremd if (modecalc.eq.12.or. +cremd & (modecalc.eq.14 .and. .not.restart1file)) then +cremd call move_from_tmp(rest2name) +cremd else if (modecalc.eq.14.and. me.eq.king) then +cremd call move_from_tmp(mremd_rst_name) +cremd endif +cmd if (mdpdb) then +cmd close(ipdb,status='keep') +cmd call move_from_tmp(pdbname) +cmd else if (me.eq.king .or. .not.traj1file) then +cmd close(icart,status='keep') +cmd call move_from_tmp(cartname) +cmd 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 diff --git a/source/unres/src_CSA_DiL/Makefile b/source/unres/src_CSA_DiL/Makefile new file mode 120000 index 0000000..74b5dd0 --- /dev/null +++ b/source/unres/src_CSA_DiL/Makefile @@ -0,0 +1 @@ +Makefile-DFA-NEWPARM.piasek \ No newline at end of file diff --git a/source/unres/src_CSA_DiL/Makefile-DFA-NEWPARM.kias b/source/unres/src_CSA_DiL/Makefile-DFA-NEWPARM.kias new file mode 100644 index 0000000..1df87fb --- /dev/null +++ b/source/unres/src_CSA_DiL/Makefile-DFA-NEWPARM.kias @@ -0,0 +1,101 @@ +CPPFLAGS = -DPROCOR -DLINUX -DPGI -DISNAN -DMP -DMPI -DUNRES \ + -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 = /usr/local/mpich-1.2.7p1-intel + +FC= ifort + +OPT = -O3 -ip -w +#OPT = -O0 + +FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include +FFLAGS1 = -c -w -g -O0 -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_021811_dfa_csa.exe +LIBS = -lpthread -L$(INSTALL_DIR)/lib -lmpich + +ARCH = LINUX +PP = /lib/cpp -P + + +all: unres + +.SUFFIXES: .F +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + + +object = unres_csa.o arcos.o cartprint.o chainbuild.o initialize_p.o \ + matmult.o readrtns_csa.o parmread.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 \ + gradient_p.o minimize_p.o sumsld.o \ + cored.o rmdd.o geomout_min.o readpdb.o \ + intcartderiv.o \ + MP.o printmat.o convert.o int_to_cart.o \ + dfa.o \ + together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ + indexx.o prng_32.o contact.o gen_rand_conf.o \ + sc_move.o test.o local_move.o rmsd.o fitsq.o elecont.o djacob.o \ + distfit.o banach.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 + +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 + +dfa.o : dfa.F + ${FC} -mp ${FFLAGS} ${CPPFLAGS} dfa.F + + + diff --git a/source/unres/src_CSA_DiL/Makefile-DFA-NEWPARM.piasek b/source/unres/src_CSA_DiL/Makefile-DFA-NEWPARM.piasek new file mode 100644 index 0000000..43cd300 --- /dev/null +++ b/source/unres/src_CSA_DiL/Makefile-DFA-NEWPARM.piasek @@ -0,0 +1,108 @@ +CPPFLAGS = -DPROCOR -DLINUX -DPGI -DISNAN -DMP -DMPI -DUNRES \ + -DSPLITELE -DAMD64 -DLANG0 +# -DCRYST_BOND -DCRYST_THETA -DCRYST_SC +#-DCRYST_TOR +# -DPROCOR +# -DTSCSC +#-DTIMING \ +# -DMOMENT +#-DPARVEC +#-DPARINT -DPARINTDER + +#INSTALL_DIR = /usr/local/mpich-1.2.0 +#INSTALL_DIR = /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/ +#INSTALL_DIR = /opt/mpi/mvapich +INSTALL_DIR = /users/local/mpi64/mpich-1.2.7p1/ +# +#FC= /usr/local/opt/intel/compiler60/ia32/bin/ifc +FC= ifort +#FCL = ${INSTALL_DIR}/bin/mpif77 +#CC = cc + +OPT = -O3 -ip -w + +FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include +FFLAGS1 = -c -w -g -O0 -d2 -CA -CB -I$(INSTALL_DIR)/include +FFLAGS2 = -c -w -g -O0 -I$(INSTALL_DIR)/include +FFLAGS3 = -c -w -O3 -mp +FFLAGSE = -c -w -O3 -ipo -ipo_obj -opt_report -I$(INSTALL_DIR)/include + +BIN = ../../../bin/unres/CSA/unres_dfa_csa-Yi.exe +#BIN = ../../../bin/unres/CSA/unres_csa_ifort_mpich-1.2.7p1.exe +#LIBS = -L$(INSTALL_DIR)/lib -lmpich +LIBS = -lpthread -L$(INSTALL_DIR)/lib -lmpich + +ARCH = LINUX +PP = /lib/cpp -P + +#all: unresCSA +all: unres + +.SUFFIXES: .F +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + + +object = unres_csa.o arcos.o cartprint.o chainbuild.o initialize_p.o \ + matmult.o readrtns_csa.o parmread.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 \ + gradient_p.o minimize_p.o sumsld.o \ + cored.o rmdd.o geomout_min.o readpdb.o \ + intcartderiv.o \ + MP.o printmat.o convert.o int_to_cart.o \ + dfa.o \ + together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ + indexx.o prng_32.o contact.o gen_rand_conf.o \ + sc_move.o test.o local_move.o rmsd.o fitsq.o elecont.o djacob.o \ + distfit.o banach.o TMscore_subroutine.o minim_mult.o + +#unresCSA: ${object} +unres: ${object} +# cc -o compinfo compinfo.c +# ./compinfo + ${FC} ${FFLAGS} cinfo.f +# ${FCL} -static-libcxa ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + +clean: + /bin/rm *.o *.il + +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} ${FFLAGS3} ${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 + +dfa.o : dfa.F + ${FC} -mp ${FFLAGS3} ${CPPFLAGS} dfa.F + + + diff --git a/source/unres/src_CSA_DiL/Makefile-DFA-OLDPARM.galera b/source/unres/src_CSA_DiL/Makefile-DFA-OLDPARM.galera new file mode 100644 index 0000000..a56aeb6 --- /dev/null +++ b/source/unres/src_CSA_DiL/Makefile-DFA-OLDPARM.galera @@ -0,0 +1,96 @@ +CPPFLAGS = -DLINUX -DUNRES -DMP -DMPI \ + -DPGI -DSPLITELE -DISNAN -DAMD64 \ + -DPROCOR \ + -DCRYST_BOND -DCRYST_THETA -DCRYST_SC +## -DMOMENT +#-DCO_BIAS +#-DCRYST_TOR +#-DDEBUG + +#INSTALL_DIR = /usr/local/mpich-1.2.0 +#INSTALL_DIR = /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh/ +INSTALL_DIR = /opt/mpi/mvapich +# +#FC= /usr/local/opt/intel/compiler60/ia32/bin/ifc +FC= ifort +FCL = ${INSTALL_DIR}/bin/mpif77 +CC = cc + +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 -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_dfa_csa-4P.exe +LIBS = -L$(INSTALL_DIR)/lib -lmpich -lpthread -g -d2 -CA -CB + +ARCH = LINUX +PP = /lib/cpp -P + +all: unresCSA + +.SUFFIXES: .F +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + + +object = unres_csa.o arcos.o cartprint.o chainbuild.o initialize_p.o \ + matmult.o readrtns_csa.o parmread.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 \ + gradient_p.o minimize_p.o sumsld.o \ + cored.o rmdd.o geomout_min.o readpdb.o \ + intcartderiv.o \ + MP.o printmat.o convert.o int_to_cart.o \ + dfa.o \ + together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ + indexx.o prng_32.o contact.o gen_rand_conf.o \ + sc_move.o test.o local_move.o rmsd.o fitsq.o elecont.o djacob.o \ + distfit.o banach.o + +unresCSA: ${object} + cc -o compinfo compinfo.c + ./compinfo + ${FC} ${FFLAGS} cinfo.f + ${FCL} -static-libcxa ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + +clean: + /bin/rm *.o *.il + +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 + +dfa.o : dfa.F + ${FC} -mp ${FFLAGS} ${CPPFLAGS} dfa.F diff --git a/source/unres/src_CSA_DiL/Makefile-DFA-OLDPARM.gfortran b/source/unres/src_CSA_DiL/Makefile-DFA-OLDPARM.gfortran new file mode 100644 index 0000000..33e528a --- /dev/null +++ b/source/unres/src_CSA_DiL/Makefile-DFA-OLDPARM.gfortran @@ -0,0 +1,103 @@ +CPPFLAGS = -DPROCOR -DLINUX -DG77 -DISNAN -DMP -DMPI -DUNRES \ + -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 = /usr/local/mpich-1.2.7p1-intel +INSTALL_DIR = /users/local/mpich2-1.3.1/ + + +FC= gfortran + +OPT = -O + +FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include +FFLAGS1 = -c -I$(INSTALL_DIR)/include +FFLAGS2 = -c -O0 -I$(INSTALL_DIR)/include +FFLAGS3 = -c -O -I$(INSTALL_DIR)/include +FFLAGSE = -c -O3 -I$(INSTALL_DIR)/include + + +BIN = ../bin/unres_dfa_csa_4P_gfortran.exe +LIBS = -lpthread -L$(INSTALL_DIR)/lib -lmpich -lmpl -lpthread + +ARCH = LINUX +PP = /lib/cpp -P + + +all: unres + +.SUFFIXES: .F +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + + +object = unres_csa.o arcos.o cartprint.o chainbuild.o initialize_p.o \ + matmult.o readrtns_csa.o parmread.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 \ + gradient_p.o minimize_p.o sumsld.o \ + cored.o rmdd.o geomout_min.o readpdb.o \ + intcartderiv.o \ + MP.o printmat.o convert.o int_to_cart.o \ + dfa.o \ + together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ + indexx.o prng_32.o contact.o gen_rand_conf.o \ + sc_move.o test.o local_move.o rmsd.o fitsq.o elecont.o djacob.o \ + distfit.o banach.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 + +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} ${FFLAGS3} ${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 + +dfa.o : dfa.F + ${FC} ${FFLAGS3} ${CPPFLAGS} dfa.F + + + diff --git a/source/unres/src_CSA_DiL/Makefile-DFA-OLDPARM.kias b/source/unres/src_CSA_DiL/Makefile-DFA-OLDPARM.kias new file mode 100644 index 0000000..54502d9 --- /dev/null +++ b/source/unres/src_CSA_DiL/Makefile-DFA-OLDPARM.kias @@ -0,0 +1,101 @@ +CPPFLAGS = -DPROCOR -DLINUX -DPGI -DISNAN -DMP -DMPI -DUNRES \ + -DSPLITELE -DAMD64 -DLANG0 \ + -DCRYST_BOND -DCRYST_THETA -DCRYST_SC +#-DCRYST_TOR +# -DPROCOR +# -DTSCSC +#-DTIMING \ +# -DMOMENT +#-DPARVEC +#-DPARINT -DPARINTDER + +INSTALL_DIR = /usr/local/mpich-1.2.7p1-intel +#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 -O0 -d2 -CA -CB -I$(INSTALL_DIR)/include +FFLAGS2 = -c -w -g -O0 -I$(INSTALL_DIR)/include +FFLAGS3 = -c -w -O3 -mp +FFLAGSE = -c -w -O3 -ipo -ipo_obj -opt_report -I$(INSTALL_DIR)/include + + +BIN = ../bin/unres_Tc_procor_050711_dfa_csa_4P_800.exe +LIBS = -lpthread -L$(INSTALL_DIR)/lib -lmpich + +ARCH = LINUX +PP = /lib/cpp -P + + +all: unres + +.SUFFIXES: .F +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + + +object = unres_csa.o arcos.o cartprint.o chainbuild.o initialize_p.o \ + matmult.o readrtns_csa.o parmread.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 \ + gradient_p.o minimize_p.o sumsld.o \ + cored.o rmdd.o geomout_min.o readpdb.o \ + intcartderiv.o \ + MP.o printmat.o convert.o int_to_cart.o \ + dfa.o \ + together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ + indexx.o prng_32.o contact.o gen_rand_conf.o \ + sc_move.o test.o local_move.o rmsd.o fitsq.o elecont.o djacob.o \ + distfit.o banach.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 + +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} ${FFLAGS3} ${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 + +dfa.o : dfa.F + ${FC} -mp ${FFLAGS3} ${CPPFLAGS} dfa.F + + + diff --git a/source/unres/src_CSA_DiL/Makefile-DFA-OLDPARM.piasek b/source/unres/src_CSA_DiL/Makefile-DFA-OLDPARM.piasek new file mode 100644 index 0000000..e18df8f --- /dev/null +++ b/source/unres/src_CSA_DiL/Makefile-DFA-OLDPARM.piasek @@ -0,0 +1,102 @@ +CPPFLAGS = -DPROCOR -DLINUX -DPGI -DISNAN -DMP -DMPI -DUNRES \ + -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 = /usr/local/mpich-1.2.7p1-intel +INSTALL_DIR = /users/local/mpi64/mpich-1.2.7p1/ + +FC= ifort + +OPT = -O3 -ip -w + +FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include +FFLAGS1 = -c -w -g -O0 -d2 -CA -CB -I$(INSTALL_DIR)/include +FFLAGS2 = -c -w -g -O0 -I$(INSTALL_DIR)/include +FFLAGS3 = -c -w -O3 -mp +FFLAGSE = -c -w -O3 -ipo -ipo_obj -opt_report -I$(INSTALL_DIR)/include + + +BIN = ../../../bin/unres/CSA/unres_csa_ifort_mpich-1.2.7p1.exe +LIBS = -lpthread -L$(INSTALL_DIR)/lib -lmpich + +ARCH = LINUX +PP = /lib/cpp -P + + +all: unres + +.SUFFIXES: .F +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + + +object = unres_csa.o arcos.o cartprint.o chainbuild.o initialize_p.o \ + matmult.o readrtns_csa.o parmread.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 \ + gradient_p.o minimize_p.o sumsld.o \ + cored.o rmdd.o geomout_min.o readpdb.o \ + intcartderiv.o \ + MP.o printmat.o convert.o int_to_cart.o \ + dfa.o \ + together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ + indexx.o prng_32.o contact.o gen_rand_conf.o \ + sc_move.o test.o local_move.o rmsd.o fitsq.o elecont.o djacob.o \ + distfit.o banach.o TMscore_subroutine.o minim_mult.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 + +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} ${FFLAGS3} ${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 + +dfa.o : dfa.F + ${FC} -mp ${FFLAGS3} ${CPPFLAGS} dfa.F + + + diff --git a/source/unres/src_CSA_DiL/Makefile-single_4P b/source/unres/src_CSA_DiL/Makefile-single_4P new file mode 100644 index 0000000..b521426 --- /dev/null +++ b/source/unres/src_CSA_DiL/Makefile-single_4P @@ -0,0 +1,91 @@ +CPPFLAGS = -DPROCOR -DLINUX -DPGI -DISNAN -DUNRES \ + -DSPLITELE -DAMD64 -DLANG0 -DPROCOR \ + -DCRYST_BOND -DCRYST_THETA -DCRYST_SC + +FC= ifort + +OPT = -O3 -ip -w + +FFLAGS = -c ${OPT} +FFLAGS1 = -c -w -g -O0 -d2 -CA -CB -I$(INSTALL_DIR)/include +FFLAGS2 = -c -w -g -O0 -I$(INSTALL_DIR)/include +FFLAGS3 = -c -w -O3 -mp +FFLAGSE = -c -w -O3 -ipo -ipo_obj -opt_report -I$(INSTALL_DIR)/include + + +BIN = ../../../bin/unres/CSA/unres_csa_ifort_single-1.2.7p1.exe +LIBS = + +ARCH = LINUX +PP = /lib/cpp -P + + +all: unres + +.SUFFIXES: .F +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + + +object = unres_csa.o arcos.o cartprint.o chainbuild.o initialize_p.o \ + matmult.o readrtns_csa.o parmread.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 \ + gradient_p.o minimize_p.o sumsld.o \ + cored.o rmdd.o geomout_min.o readpdb.o \ + intcartderiv.o \ + MP.o printmat.o convert.o int_to_cart.o \ + dfa.o \ + together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ + indexx.o prng_32.o contact.o gen_rand_conf.o \ + sc_move.o test.o local_move.o rmsd.o fitsq.o elecont.o djacob.o \ + distfit.o banach.o TMscore_subroutine.o minim_mult.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 + +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} ${FFLAGS3} ${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 + +dfa.o : dfa.F + ${FC} -mp ${FFLAGS3} ${CPPFLAGS} dfa.F + + + diff --git a/source/unres/src_CSA_DiL/Makefile_4P b/source/unres/src_CSA_DiL/Makefile_4P new file mode 100644 index 0000000..915eec2 --- /dev/null +++ b/source/unres/src_CSA_DiL/Makefile_4P @@ -0,0 +1,100 @@ +CPPFLAGS = -DPROCOR -DLINUX -DPGI -DISNAN -DMP -DMPI -DUNRES \ + -DSPLITELE -DAMD64 -DLANG0 -DPROCOR \ + -DCRYST_BOND -DCRYST_THETA -DCRYST_SC +# -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 -O0 -d2 -CA -CB -I$(INSTALL_DIR)/include +FFLAGS2 = -c -w -g -O0 -I$(INSTALL_DIR)/include +FFLAGS3 = -c -w -O3 -mp +FFLAGSE = -c -w -O3 -ipo -ipo_obj -opt_report -I$(INSTALL_DIR)/include + + +BIN = ../../../bin/unres/CSA/unres_csa_ifort_mpich-1.2.7p1.exe +LIBS = -lpthread -L$(INSTALL_DIR)/lib -lmpich + +ARCH = LINUX +PP = /lib/cpp -P + + +all: unres + +.SUFFIXES: .F +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + + +object = unres_csa.o arcos.o cartprint.o chainbuild.o initialize_p.o \ + matmult.o readrtns_csa.o parmread.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 \ + gradient_p.o minimize_p.o sumsld.o \ + cored.o rmdd.o geomout_min.o readpdb.o \ + intcartderiv.o \ + MP.o printmat.o convert.o int_to_cart.o \ + dfa.o \ + together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ + indexx.o prng_32.o contact.o gen_rand_conf.o \ + sc_move.o test.o local_move.o rmsd.o fitsq.o elecont.o djacob.o \ + distfit.o banach.o TMscore_subroutine.o minim_mult.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 + +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} ${FFLAGS3} ${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 + +dfa.o : dfa.F + ${FC} -mp ${FFLAGS3} ${CPPFLAGS} dfa.F + + + diff --git a/source/unres/src_CSA_DiL/Makefile_CASP3 b/source/unres/src_CSA_DiL/Makefile_CASP3 new file mode 100644 index 0000000..c9ff0be --- /dev/null +++ b/source/unres/src_CSA_DiL/Makefile_CASP3 @@ -0,0 +1,100 @@ +CPPFLAGS = -DLINUX -DPGI -DISNAN -DMP -DMPI -DUNRES \ + -DSPLITELE -DAMD64 -DLANG0 -DMOMENT \ + -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 -O0 -d2 -CA -CB -I$(INSTALL_DIR)/include +FFLAGS2 = -c -w -g -O0 -I$(INSTALL_DIR)/include +FFLAGS3 = -c -w -O3 -mp +FFLAGSE = -c -w -O3 -ipo -ipo_obj -opt_report -I$(INSTALL_DIR)/include + + +BIN = ../../../bin/unres/CSA/unres_csa-CASP3_ifort_mpich-1.2.7p1.exe +LIBS = -lpthread -L$(INSTALL_DIR)/lib -lmpich + +ARCH = LINUX +PP = /lib/cpp -P + + +all: unres + +.SUFFIXES: .F +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + + +object = unres_csa.o arcos.o cartprint.o chainbuild.o initialize_p.o \ + matmult.o readrtns_csa.o parmread.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 \ + gradient_p.o minimize_p.o sumsld.o \ + cored.o rmdd.o geomout_min.o readpdb.o \ + intcartderiv.o \ + MP.o printmat.o convert.o int_to_cart.o \ + dfa.o \ + together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ + indexx.o prng_32.o contact.o gen_rand_conf.o \ + sc_move.o test.o local_move.o rmsd.o fitsq.o elecont.o djacob.o \ + distfit.o banach.o TMscore_subroutine.o minim_mult.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 + +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} ${FFLAGS3} ${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 + +dfa.o : dfa.F + ${FC} -mp ${FFLAGS3} ${CPPFLAGS} dfa.F + + + diff --git a/source/unres/src_CSA_DiL/README.Juyong b/source/unres/src_CSA_DiL/README.Juyong new file mode 100644 index 0000000..b2dbf30 --- /dev/null +++ b/source/unres/src_CSA_DiL/README.Juyong @@ -0,0 +1,13 @@ +2010/12/20 + +0. added lines in the molread subroutine in readrtns_min.F file + to read dfa_weight functions, WDFA, "wdfa" variable is added in COMMON.FFIELD + +0-1. added lines in readrtns_min.F to print out dfa weights! +0-2. add subroutines to setup DFA variables & "READ fragment info" + -> init_dfa_vars + -> read_dfa_info + +1. added "gdfa_dist, gdfa_tor, gdfa_nei, gdfa_beta" to COMMON.DERIV + +2. changed n_ene in DIMENSIONS from 23 to 27, since DFA has four terms...... diff --git a/source/unres/src_CSA_DiL/TMscore_subroutine.f b/source/unres/src_CSA_DiL/TMscore_subroutine.f new file mode 100644 index 0000000..8e6ee9a --- /dev/null +++ b/source/unres/src_CSA_DiL/TMscore_subroutine.f @@ -0,0 +1,536 @@ +************************************************************************* +************************************************************************* +* This is a subroutine to compare two structures and find the +* superposition that has the maximum TM-score. +* Reference: Yang Zhang, Jeffrey Skolnick, Proteins 2004 57:702-10. +* +* Explanations: +* L1--Length of the first structure +* (x1(i),y1(i),z1(i))--coordinates of i'th residue at the first structure +* n1(i)--Residue sequence number of i'th residue at the first structure +* L2--Length of the second structure +* (x2(i),y2(i),z2(i))--coordinates of i'th residue at the second structure +* n2(i)--Residue sequence number of i'th residue at the second structure +* TM--TM-score of the comparison +* Rcomm--RMSD of two structures in the common aligned residues +* Lcomm--Length of the common aligned regions +* +* Note: +* 1, Always put native as the second structure, by which TM-score +* is normalized. +* 2, The returned (x1(i),y1(i),z1(i)) are the rotated structure after +* TM-score superposition. +************************************************************************* +************************************************************************* + subroutine TMscore(L1,x1,y1,z1,n1,L2,x2,y2,z2,n2,TM,Rcomm,Lcomm) + include 'DIMENSIONS' + PARAMETER(nmax=maxres) + common/stru/xt(nmax),yt(nmax),zt(nmax),xb(nmax),yb(nmax),zb(nmax) + common/nres/nresA(nmax),nresB(nmax),nseqA,nseqB + common/para/d,d0 + common/align/n_ali,iA(nmax),iB(nmax) + common/nscore/i_ali(nmax),n_cut ![1,n_ali],align residues for the score + dimension k_ali(nmax),k_ali0(nmax) + dimension L_ini(100),iq(nmax) + common/scores/score + double precision score,score_max + dimension xa(nmax),ya(nmax),za(nmax) + + dimension x1(nmax),y1(nmax),z1(nmax),n1(nmax) + dimension x2(nmax),y2(nmax),z2(nmax),n2(nmax) + +ccc RMSD: + double precision r_1(3,nmax),r_2(3,nmax),r_3(3,nmax),w(nmax) + double precision u(3,3),t(3),rms,drms !armsd is real + data w /nmax*1.0/ +ccc + +********* convert input data **************** + nseqA=L1 + do i=1,nseqA + xa(i)=x1(i) + ya(i)=y1(i) + za(i)=z1(i) + nresA(i)=n1(i) + enddo + nseqB=L2 + do i=1,L2 + xb(i)=x2(i) + yb(i)=y2(i) + zb(i)=z2(i) + nresB(i)=n2(i) + enddo + +****************************************************************** +* pickup the aligned residues: +****************************************************************** + k=0 + do i=1,nseqA + do j=1,nseqB + if(nresA(i).eq.nresB(j))then + k=k+1 + iA(k)=i + iB(k)=j + goto 205 + endif + enddo + 205 continue + enddo + n_ali=k !number of aligned residues + Lcomm=n_ali + if(n_ali.lt.1)then +c write(*,*)'There is no common residues in the input structures' + TM=0 + Rcomm=0 + return + endif + +************///// +* parameters: +***************** +*** d0-------------> + d0=1.24*(nseqB-15)**(1.0/3.0)-1.8 + if(d0.lt.0.5)d0=0.5 +*** d0_search -----> + d0_search=d0 + if(d0_search.gt.8)d0_search=8 + if(d0_search.lt.4.5)d0_search=4.5 +*** iterative parameters -----> + n_it=20 !maximum number of iterations + d_output=5 !for output alignment + n_init_max=6 !maximum number of L_init + n_init=0 + L_ini_min=4 + if(n_ali.lt.4)L_ini_min=n_ali + do i=1,n_init_max-1 + n_init=n_init+1 + L_ini(n_init)=n_ali/2**(n_init-1) + if(L_ini(n_init).le.L_ini_min)then + L_ini(n_init)=L_ini_min + goto 402 + endif + enddo + n_init=n_init+1 + L_ini(n_init)=L_ini_min + 402 continue + +****************************************************************** +* find the maximum score starting from local structures superposition +****************************************************************** + score_max=-1 !TM-score + do 333 i_init=1,n_init + L_init=L_ini(i_init) + iL_max=n_ali-L_init+1 + do 300 iL=1,iL_max !on aligned residues, [1,nseqA] + LL=0 + ka=0 + do i=1,L_init + k=iL+i-1 ![1,n_ali] common aligned + r_1(1,i)=xa(iA(k)) + r_1(2,i)=ya(iA(k)) + r_1(3,i)=za(iA(k)) + r_2(1,i)=xb(iB(k)) + r_2(2,i)=yb(iB(k)) + r_2(3,i)=zb(iB(k)) + LL=LL+1 + ka=ka+1 + k_ali(ka)=k + enddo + call u3b(w,r_1,r_2,LL,1,rms,u,t,ier) !u rotate r_1 to r_2 + if(i_init.eq.1)then !global superposition + armsd=dsqrt(rms/LL) + Rcomm=armsd + endif + do j=1,nseqA + xt(j)=t(1)+u(1,1)*xa(j)+u(1,2)*ya(j)+u(1,3)*za(j) + yt(j)=t(2)+u(2,1)*xa(j)+u(2,2)*ya(j)+u(2,3)*za(j) + zt(j)=t(3)+u(3,1)*xa(j)+u(3,2)*ya(j)+u(3,3)*za(j) + enddo + d=d0_search-1 + call score_fun !init, get scores, n_cut+i_ali(i) for iteration + if(score_max.lt.score)then + score_max=score + ka0=ka + do i=1,ka0 + k_ali0(i)=k_ali(i) + enddo + endif +*** iteration for extending ----------------------------------> + d=d0_search+1 + do 301 it=1,n_it + LL=0 + ka=0 + do i=1,n_cut + m=i_ali(i) ![1,n_ali] + r_1(1,i)=xa(iA(m)) + r_1(2,i)=ya(iA(m)) + r_1(3,i)=za(iA(m)) + r_2(1,i)=xb(iB(m)) + r_2(2,i)=yb(iB(m)) + r_2(3,i)=zb(iB(m)) + ka=ka+1 + k_ali(ka)=m + LL=LL+1 + enddo + call u3b(w,r_1,r_2,LL,1,rms,u,t,ier) !u rotate r_1 to r_2 + do j=1,nseqA + xt(j)=t(1)+u(1,1)*xa(j)+u(1,2)*ya(j)+u(1,3)*za(j) + yt(j)=t(2)+u(2,1)*xa(j)+u(2,2)*ya(j)+u(2,3)*za(j) + zt(j)=t(3)+u(3,1)*xa(j)+u(3,2)*ya(j)+u(3,3)*za(j) + enddo + call score_fun !get scores, n_cut+i_ali(i) for iteration + if(score_max.lt.score)then + score_max=score + ka0=ka + do i=1,ka + k_ali0(i)=k_ali(i) + enddo + endif + if(it.eq.n_it)goto 302 + if(n_cut.eq.ka)then + neq=0 + do i=1,n_cut + if(i_ali(i).eq.k_ali(i))neq=neq+1 + enddo + if(n_cut.eq.neq)goto 302 + endif + 301 continue !for iteration + 302 continue + 300 continue !for shift + 333 continue !for initial length, L_ali/M + +******** return the final rotation **************** + LL=0 + do i=1,ka0 + m=k_ali0(i) !record of the best alignment + r_1(1,i)=xa(iA(m)) + r_1(2,i)=ya(iA(m)) + r_1(3,i)=za(iA(m)) + r_2(1,i)=xb(iB(m)) + r_2(2,i)=yb(iB(m)) + r_2(3,i)=zb(iB(m)) + LL=LL+1 + enddo + call u3b(w,r_1,r_2,LL,1,rms,u,t,ier) !u rotate r_1 to r_2 + do j=1,nseqA + x1(j)=t(1)+u(1,1)*xa(j)+u(1,2)*ya(j)+u(1,3)*za(j) + y1(j)=t(2)+u(2,1)*xa(j)+u(2,2)*ya(j)+u(2,3)*za(j) + z1(j)=t(3)+u(3,1)*xa(j)+u(3,2)*ya(j)+u(3,3)*za(j) + enddo + TM=score_max + +c^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + return + END + +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c 1, collect those residues with dis +#include +#include +#include +#include + +main() +{ +FILE *in, *in1, *out; +int i,j,k,iv1,iv2,iv3; +char *p1,buf[500],buf1[500],buf2[100],buf3[100]; +struct utsname Name; +time_t Tp; + +in=fopen("cinfo.f","r"); +out=fopen("cinfo.f.new","w"); +if (fgets(buf,498,in) != NULL) + fprintf(out,"C DO NOT EDIT THIS FILE - IT HAS BEEN GENERATED BY COMPINFO.C\n"); +if (fgets(buf,498,in) != NULL) + sscanf(&buf[1],"%d %d %d",&iv1,&iv2,&iv3); +iv3++; +fprintf(out,"C %d %d %d\n",iv1,iv2,iv3); +fprintf(out," subroutine cinfo\n"); +fprintf(out," include 'COMMON.IOUNITS'\n"); +fprintf(out," write(iout,*)'++++ Compile info ++++'\n"); +fprintf(out," write(iout,*)'Version %d.%-d build %d'\n",iv1,iv2,iv3); +uname(&Name); +time(&Tp); +system("whoami > tmptmp"); +in1=fopen("tmptmp","r"); +if (fscanf(in1,"%s",buf1) != EOF) +{ +p1=ctime(&Tp); +p1[strlen(p1)-1]='\0'; +fprintf(out," write(iout,*)'compiled %s'\n",p1); +fprintf(out," write(iout,*)'compiled by %s@%s'\n",buf1,Name.nodename); +fprintf(out," write(iout,*)'OS name: %s '\n",Name.sysname); +fprintf(out," write(iout,*)'OS release: %s '\n",Name.release); +fprintf(out," write(iout,*)'OS version:',\n"); +fprintf(out," & ' %s '\n",Name.version); +fprintf(out," write(iout,*)'flags:'\n"); +} +system("rm tmptmp"); +fclose(in1); +in1=fopen("Makefile","r"); +while(fgets(buf,498,in1) != NULL) + { + if((p1=strchr(buf,'=')) != NULL && buf[0] != '#') + { + buf[strlen(buf)-1]='\0'; + if(strlen(buf) > 49) + { + buf[47]='\0'; + strcat(buf,"..."); + } + else + { + while(buf[strlen(buf)-1]=='\\') + { + strcat(buf,"\\"); + fprintf(out," write(iout,*)'%s'\n",buf); + if (fgets(buf,498,in1) != NULL) + buf[strlen(buf)-1]='\0'; + if(strlen(buf) > 49) + { + buf[47]='\0'; + strcat(buf,"..."); + } + } + } + + fprintf(out," write(iout,*)'%s'\n",buf); + } + } +fprintf(out," write(iout,*)'++++ End of compile info ++++'\n"); +fprintf(out," return\n"); +fprintf(out," end\n"); +fclose(out); +fclose(in1); +fclose(in); +system("mv cinfo.f.new cinfo.f"); +} diff --git a/source/unres/src_CSA_DiL/contact.f b/source/unres/src_CSA_DiL/contact.f new file mode 100644 index 0000000..a244d86 --- /dev/null +++ b/source/unres/src_CSA_DiL/contact.f @@ -0,0 +1,195 @@ + 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---------------------------------------------------------------------------- + diff --git a/source/unres/src_CSA_DiL/convert.f b/source/unres/src_CSA_DiL/convert.f new file mode 100644 index 0000000..dc0cccd --- /dev/null +++ b/source/unres/src_CSA_DiL/convert.f @@ -0,0 +1,196 @@ + 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------------------------------------------------------------------------- diff --git a/source/unres/src_CSA_DiL/cored.f b/source/unres/src_CSA_DiL/cored.f new file mode 100644 index 0000000..1cf25e5 --- /dev/null +++ b/source/unres/src_CSA_DiL/cored.f @@ -0,0 +1,3151 @@ + 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 diff --git a/source/unres/src_CSA_DiL/csa.f b/source/unres/src_CSA_DiL/csa.f new file mode 100644 index 0000000..a5149f2 --- /dev/null +++ b/source/unres/src_CSA_DiL/csa.f @@ -0,0 +1,366 @@ + subroutine make_array + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.CSA' + +ccccccccccccccccccccccccc +c Level-2: group +ccccccccccccccccccccccccc + + indg=0 + do k=1,numch +ccccccccccccccccccccccccccccccccccccccccc +! Groups the THETAs and the GAMMAs + do j=2,nres-1 + indg=indg+1 + if (j.lt.nres-1) then + ngroup(indg)=2 + else + ngroup(indg)=1 + endif + do i=1,ngroup(indg) + igroup(1,i,indg)=i + igroup(2,i,indg)=j + igroup(3,i,indg)=k + enddo + enddo +ccccccccccccccccccccccccccccccccccccccccc + enddo +! Groups the ALPHAs and the BETAs + do k=1,numch + do j=2,nres-1 + if(itype(j).ne.10) then + indg=indg+1 + ngroup(indg)=2 + do i=1,ngroup(indg) + igroup(1,i,indg)=i+2 + igroup(2,i,indg)=j + igroup(3,i,indg)=k + enddo + endif + enddo + enddo + + ntotgr=indg + write(iout,*) + write(iout,*) "# of groups: ",ntotgr + do i=1,ntotgr + write(iout,41) i,ngroup(i),((igroup(k,j,i),k=1,3),j=1,ngroup(i)) + enddo +! close(iout) + + 40 format(i3,3x,3i3) + 41 format(2i3,3x,6(3i3,2x)) + + return + end +ccccccccccccccccccccccccccccccccccccccccccccccccc +ccccccccccccccccccccccccccccccccccccccccccccccccc + subroutine make_ranvar(n,m,idum) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.BANK' +c al m=0 + print *,'HOHOHOHO Make_RanVar!!!!!',n,m + itrial=0 + do while(m.lt.n .and. itrial.le.10000) + itrial=itrial+1 + jeden=1 + call gen_rand_conf(jeden,*10) + call intout + m=m+1 + do j=2,nres-1 + dihang_in(1,j,1,m)=theta(j+1) + dihang_in(2,j,1,m)=phi(j+2) + dihang_in(3,j,1,m)=alph(j) + dihang_in(4,j,1,m)=omeg(j) + enddo + dihang_in(2,nres-1,1,m)=0.0d0 + goto 20 + 10 write (iout,*) 'Failed to generate conformation #',m+1, + & ' itrial=',itrial + 20 continue + enddo + print *,'Make_RanVar!!!!! m=',m,' itrial=',itrial + + return + end +ccccccccccccccccccccccccccccccccccccccccccccccccc +ccccccccccccccccccccccccccccccccccccccccccccccccc + subroutine make_ranvar_reg(n,idum) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.BANK' + include 'COMMON.GEO' + m=0 + print *,'HOHOHOHO Make_RanVar_reg!!!!!' + itrial=0 + do while(m.lt.n .and. itrial.le.10000) + itrial=itrial+1 + jeden=1 + call gen_rand_conf(jeden,*10) +! call intout + m=m+1 + do j=2,nres-1 + dihang_in(1,j,1,m)=theta(j+1) + dihang_in(2,j,1,m)=phi(j+2) + dihang_in(3,j,1,m)=alph(j) + dihang_in(4,j,1,m)=omeg(j) + if(m.le.n*0.1) then + dihang_in(1,j,1,m)=90.0*deg2rad + dihang_in(2,j,1,m)=50.0*deg2rad + endif + enddo + dihang_in(2,nres-1,1,m)=0.0d0 + goto 20 + 10 write (iout,*) 'Failed to generate conformation #',m+1, + & ' itrial=',itrial + 20 continue + enddo + print *,'Make_RanVar!!!!! m=',m,' itrial=',itrial + + return + end +ccccccccccccccccccccccccccccccccccccccccccccccccc +ccccccccccccccccccccccccccccccccccccccccccccccccc + subroutine from_pdb(n,idum) +c This subroutine stores the UNRES int variables generated from +c subroutine readpdb into the 1st conformation of in dihang_in. +c Subsequent n-1 conformations of dihang_in have identical values +c of theta and phi as the 1st conformation but random values for +c alph and omeg. +c The array cref (also generated from subroutine readpdb) is stored +c to crefjlee to be used for rmsd calculation in CSA, if necessary. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.BANK' + include 'COMMON.GEO' + + m=1 + do j=2,nres-1 + dihang_in(1,j,1,m)=theta(j+1) + dihang_in(2,j,1,m)=phi(j+2) + dihang_in(3,j,1,m)=alph(j) + dihang_in(4,j,1,m)=omeg(j) + enddo + dihang_in(2,nres-1,1,k)=0.0d0 + + do m=2,n + do k=2,nres-1 + dihang_in(1,k,1,m)=dihang_in(1,k,1,1) + dihang_in(2,k,1,m)=dihang_in(2,k,1,1) + if(dabs(dihang_in(3,k,1,1)).gt.1.d-6) then + dihang_in(3,k,1,m)=90.d0*ran1(idum)+90.d0 + dihang_in(3,k,1,m)=dihang_in(3,k,1,m)*deg2rad + endif + if(dabs(dihang_in(4,k,1,1)).gt.1.d-6) then + dihang_in(4,k,1,m)=360.d0*ran1(idum)-180.d0 + dihang_in(4,k,1,m)=dihang_in(4,k,1,m)*deg2rad + endif + enddo + enddo + +c Store cref to crefjlee (they are in COMMON.CHAIN). + do k=1,2*nres + do kk=1,3 + crefjlee(kk,k)=cref(kk,k) + enddo + enddo + + open(icsa_native_int,file=csa_native_int,status="old") + do m=1,n + write(icsa_native_int,*) m,e + write(icsa_native_int,200) + & (dihang_in(1,k,1,m)*rad2deg,k=2,nres-1) + write(icsa_native_int,200) + & (dihang_in(2,k,1,m)*rad2deg,k=2,nres-2) + write(icsa_native_int,200) + & (dihang_in(3,k,1,m)*rad2deg,k=2,nres-1) + write(icsa_native_int,200) + & (dihang_in(4,k,1,m)*rad2deg,k=2,nres-1) + enddo + + do k=1,nres + write(icsa_native_int,200) (crefjlee(i,k),i=1,3) + enddo + close(icsa_native_int) + + 200 format (8f10.4) + + return + end +ccccccccccccccccccccccccccccccccccccccccccccccccc +ccccccccccccccccccccccccccccccccccccccccccccccccc + subroutine from_int(n,mm,idum) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.BANK' + include 'COMMON.GEO' + include 'COMMON.CONTACTS' +#ifdef MOMENT + include 'COMMON.CONTACTS.MOMENT' +#endif + integer ilen + external ilen + logical fail + double precision energia(0:n_ene) + + open(icsa_native_int,file=csa_native_int,status="old") + read (icsa_native_int,*) + call read_angles(icsa_native_int,*10) + goto 11 + 10 write (iout,'(2a)') "CHUJ NASTAPIL - error in ", + & csa_native_int(:ilen(csa_native_int)) + 11 continue + call intout + do j=2,nres-1 + dihang_in(1,j,1,1)=theta(j+1) + dihang_in(2,j,1,1)=phi(j+2) + dihang_in(3,j,1,1)=alph(j) + dihang_in(4,j,1,1)=omeg(j) + enddo + dihang_in(2,nres-1,1,1)=0.0d0 + +c read(icsa_native_int,*) ind,e +c read(icsa_native_int,200) (dihang_in(1,k,1,1),k=2,nres-1) +c read(icsa_native_int,200) (dihang_in(2,k,1,1),k=2,nres-2) +c read(icsa_native_int,200) (dihang_in(3,k,1,1),k=2,nres-1) +c read(icsa_native_int,200) (dihang_in(4,k,1,1),k=2,nres-1) +c dihang_in(2,nres-1,1,1)=0.d0 + + maxsi=100 + maxcount_fail=100 + + do m=mm+2,n +c do k=2,nres-1 +c dihang_in(1,k,1,m)=dihang_in(1,k,1,1) +c dihang_in(2,k,1,m)=dihang_in(2,k,1,1) +c if(abs(dihang_in(3,k,1,1)).gt.1.d-3) then +c dihang_in(3,k,1,m)=90.d0*ran1(idum)+90.d0 +c endif +c if(abs(dihang_in(4,k,1,1)).gt.1.d-3) then +c dihang_in(4,k,1,m)=360.d0*ran1(idum)-180.d0 +c endif +c enddo +c call intout + fail=.true. + + icount_fail=0 + + DO WHILE (FAIL .AND. ICOUNT_FAIL .LE. MAXCOUNT_FAIL) + + do i=nnt,nct + if (itype(i).ne.10) then +cd print *,'i=',i,' itype=',itype(i),' theta=',theta(i+1) + fail=.true. + ii=0 + do while (fail .and. ii .le. maxsi) + call gen_side(itype(i),theta(i+1),alph(i),omeg(i),fail) + ii = ii+1 + enddo + endif + enddo + call chainbuild + call etotal(energia(0)) + fail = (energia(0).ge.1.0d20) + icount_fail=icount_fail+1 + + ENDDO + + if (icount_fail.gt.maxcount_fail) then + write (iout,*) + & 'Failed to generate non-overlaping near-native conf.', + & m + endif + + do j=2,nres-1 + dihang_in(1,j,1,m)=theta(j+1) + dihang_in(2,j,1,m)=phi(j+2) + dihang_in(3,j,1,m)=alph(j) + dihang_in(4,j,1,m)=omeg(j) + enddo + dihang_in(2,nres-1,1,m)=0.0d0 + enddo + +c do m=1,n +c write(icsa_native_int,*) m,e +c write(icsa_native_int,200) (dihang_in(1,k,1,m),k=2,nres-1) +c write(icsa_native_int,200) (dihang_in(2,k,1,m),k=2,nres-2) +c write(icsa_native_int,200) (dihang_in(3,k,1,m),k=2,nres-1) +c write(icsa_native_int,200) (dihang_in(4,k,1,m),k=2,nres-1) +c enddo +c close(icsa_native_int) + +c do m=mm+2,n +c do i=1,4 +c do j=2,nres-1 +c dihang_in(i,j,1,m)=dihang_in(i,j,1,m)*deg2rad +c enddo +c enddo +c enddo + + call dihang_to_c(dihang_in(1,1,1,1)) + +c Store c to cref (they are in COMMON.CHAIN). + do k=1,2*nres + do kk=1,3 + crefjlee(kk,k)=c(kk,k) + enddo + enddo + + call contact(.true.,ncont_ref,icont_ref,co) + +c do k=1,nres +c write(icsa_native_int,200) (crefjlee(i,k),i=1,3) +c enddo + close(icsa_native_int) + + 200 format (8f10.4) + + return + end +ccccccccccccccccccccccccccccccccccccccccccccccccc +ccccccccccccccccccccccccccccccccccccccccccccccccc + subroutine dihang_to_c(aarray) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CSA' + include 'COMMON.BANK' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + include 'COMMON.VAR' + + dimension aarray(mxang,maxres,mxch) + +c do i=4,nres +c phi(i)=dihang_in(1,i-2,1,1) +c enddo + do i=2,nres-1 + theta(i+1)=aarray(1,i,1) + phi(i+2)=aarray(2,i,1) + alph(i)=aarray(3,i,1) + omeg(i)=aarray(4,i,1) + enddo + + call chainbuild + + return + end +ccccccccccccccccccccccccccccccccccccccccccccccccc +ccccccccccccccccccccccccccccccccccccccccccccccccc diff --git a/source/unres/src_CSA_DiL/dfa.F b/source/unres/src_CSA_DiL/dfa.F new file mode 100644 index 0000000..576910c --- /dev/null +++ b/source/unres/src_CSA_DiL/dfa.F @@ -0,0 +1,3455 @@ + subroutine init_dfa_vars + + include 'DIMENSIONS' + include 'COMMON.INTERACT' + include 'COMMON.DFA' + + integer ii + +C Number of restraints + idisnum = 0 + iphinum = 0 + ithenum = 0 + ineinum = 0 + + idislis = 0 + iphilis = 0 + ithelis = 0 + ineilis = 0 + jneilis = 0 + jneinum = 0 + kshell = 0 + fnei = 0 +C For beta + nca = 0 + icaidx = 0 + +C real variables +CC WEIGHTS for each min + sccdist = 0.0d0 + fdist = 0.0d0 + sccphi = 0.0d0 + sccthe = 0.0d0 + sccnei = 0.0d0 + fphi1 = 0.0d0 + fphi2 = 0.0d0 + fthe1 = 0.0d0 + fthe2 = 0.0d0 +C energies + edfatot = 0.0d0 + edfadis = 0.0d0 + edfaphi = 0.0d0 + edfathe = 0.0d0 + edfanei = 0.0d0 + edfabet = 0.0d0 +C weights for each E term +C these should be identical with + dis_inc = 0.0d0 + phi_inc = 0.0d0 + the_inc = 0.0d0 + nei_inc = 0.0d0 + beta_inc = 0.0d0 + wshet = 0.0d0 +C precalculate exp table! +c dfaexp = 0.0d0 +c do ii = 1, 15001 +c dfaexp(ii) = exp(-ii*0.001d0 + 0.0005d0) +c end do + + ishiftca=nnt-1 + ilastca=nct + + print *,'ishiftca=',ishiftca,'ilastca=',ilastca + + return + end + + + subroutine read_dfa_info +C +C read fragment informations +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DFA' + + +C NOTE THAT FILENAMES are FIXED, CURRENTLY!! +C THIS SHOULD BE MODIFIED!! + + character*320 buffer + integer iodfa + parameter(iodfa=89) + + integer i, j, nval + integer ica1, ica2,ica3,ica4,ica5 + integer ishell, inca, itmp,iitmp + double precision wtmp +C +C READ DISTANCE +C + open(iodfa, file = 'dist_dfa.dat', status = 'old', err=33) + goto 34 + 33 write(iout,'(a)') 'Error opening dist_dfa.dat file' + stop + 34 continue + write(iout,'(a)') 'dist_dfa.dat is opened!' +C read title + read(iodfa, '(a)') buffer +C read number of restraints + read(iodfa, *) IDFADIS + read(iodfa, *) dis_inc + do i=1, idfadis + read(iodfa, '(i10,1x,i10,1x,i10)') ica1, ica2, nval + + idisnum(i)=nval + idislis(1,i)=ica1 + idislis(2,i)=ica2 + + do j=1, nval + read(iodfa,*) tmp + fdist(i,j) = tmp + enddo + + do j=1, nval + read(iodfa,*) tmp + sccdist(i,j) = tmp + enddo + + enddo + close(iodfa) + +C READ ANGLE RESTRAINTS +C PHI RESTRAINTS + open(iodfa, file='phi_dfa.dat',status='old',err=35) + goto 36 + 35 write(iout,'(a)') 'Error opening dist_dfa.dat file' + stop + + 36 continue + write(iout,'(a)') 'phi_dfa.dat is opened!' + +C READ TITLE + read(iodfa, '(a)') buffer +C READ NUMBER OF RESTRAINTS + READ(iodfa, *) IDFAPHI + read(iodfa,*) phi_inc + do i=1, idfaphi + read(iodfa,'(5(i10,1x),1x,i10)')ica1,ica2,ica3,ica4,ica5,nval + + iphinum(i)=nval + + iphilis(1,i)=ica1 + iphilis(2,i)=ica2 + iphilis(3,i)=ica3 + iphilis(4,i)=ica4 + iphilis(5,i)=ica5 + + do j=1, nval + read(iodfa,*) tmp1,tmp2 + fphi1(i,j) = tmp1 + fphi2(i,j) = tmp2 + enddo + + do j=1, nval + read(iodfa,*) tmp + sccphi(i,j) = tmp + enddo + + enddo + close(iodfa) + +C THETA RESTRAINTS + open(iodfa, file='theta_dfa.dat',status='old',err=41) + goto 42 + 41 write(iout,'(a)') 'Error opening dist_dfa.dat file' + stop + 42 continue + write(iout,'(a)') 'theta_dfa.dat is opened!' +C READ TITLE + read(iodfa, '(a)') buffer +C READ NUMBER OF RESTRAINTS + READ(iodfa, *) IDFATHE + read(iodfa,*) the_inc + + do i=1, idfathe + read(iodfa, '(5(i10,1x),1x,i10)')ica1,ica2,ica3,ica4,ica5,nval + + ithenum(i)=nval + + ithelis(1,i)=ica1 + ithelis(2,i)=ica2 + ithelis(3,i)=ica3 + ithelis(4,i)=ica4 + ithelis(5,i)=ica5 + + do j=1, nval + read(iodfa,*) tmp1,tmp2 + fthe1(i,j) = tmp1 + fthe2(i,j) = tmp2 + enddo + + do j=1, nval + read(iodfa,*) tmp + sccthe(i,j) = tmp + enddo + + enddo + close(iodfa) +C END of READING ANGLE RESTRAINT! + +C NUMBER OF NEIGHBOR CAs + open(iodfa,file='nei_dfa.dat',status='old',err=37) + goto 38 + 37 write(iout,'(a)') 'Error opening nei_dfa.dat file' + stop + 38 continue + write(iout,'(a)') 'nei_dfa.dat is opened!' +C READ TITLE + read(iodfa, '(a)') buffer +C READ NUMBER OF RESTRAINTS + READ(iodfa, *) idfanei + read(iodfa,*) nei_inc + + do i=1, idfanei + read(iodfa,'(2(i10,1x),i10)')ica1,ishell,nval + + ineilis(i)=ica1 + kshell(i)=ishell + ineinum(i)=nval + + do j=1, nval + read(iodfa,*) inca + fnei(i,j) = inca +C write(*,*) 'READ NEI:',i,j,fnei(i,j) + enddo + + do j=1, nval + read(iodfa,*) tmp + sccnei(i,j) = tmp + enddo + + enddo + close(iodfa) +C END OF NEIGHBORING CA + +C READ BETA RESTRAINT + open(iodfa, file='beta_dfa.dat',status='old',err=39) + goto 40 + 39 write(iout,'(a)') 'Error opening beta_dfa.dat file' + stop + 40 continue + write(iout,'(a)') 'beta_dfa.dat is opened!' + + read(iodfa,'(a)') buffer + read(iodfa,*) itmp + read(iodfa,*) beta_inc + + do i=1,itmp + read(iodfa,*) ica1, iitmp + do j=1,itmp + read(iodfa,*) wtmp + wshet(i,j) = wtmp +c write(*,*) 'BETA:',i,j,wtmp,wshet(i,j) + enddo + enddo + + close(iodfa) +C END OF BETA RESTRAINT + + return + END + + subroutine edfad(edfadis) + + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.DFA' + + double precision edfadis + integer i, iatm1, iatm2,idiff + double precision ckk, sckk,dist,texp + double precision jix,jiy,jiz,ep,fp,scc + + edfadis=0 + gdfad=0.0d0 + + do i=1, idfadis + + iatm1=idislis(1,i)+ishiftca + iatm2=idislis(2,i)+ishiftca + idiff = abs(iatm1-iatm2) + + JIX=c(1,iatm2)-c(1,iatm1) + JIY=c(2,iatm2)-c(2,iatm1) + JIZ=c(3,iatm2)-c(3,iatm1) + DIST=SQRT(JIX*JIX+JIY*JIY+JIZ*JIZ) + + ckk=ck(idiff) + sckk=sck(idiff) + + scc = 0.0d0 + ep = 0.0d0 + fp = 0.0d0 + + do j=1,idisnum(i) + + dd = dist-fdist(i,j) + dtmp = dd*dd/ckk + if (dtmp.ge.15.0d0) then + texp = 0.0d0 + else +c texp = dfaexp( idint(dtmp*1000)+1 )/sckk + texp = exp(-dtmp)/sckk + endif + + ep=ep+sccdist(i,j)*texp + fp=fp+sccdist(i,j)*texp*dd*2.0d0/ckk + scc=scc+sccdist(i,j) +C write(*,'(2i8,6f12.5)') i, j, dist, +C & fdist(i,j), ep, fp, sccdist(i,j), scc + + enddo + + ep = -ep/scc + fp = fp/scc + + +c IF(ABS(EP).lt.1.0d-20)THEN +c EP=0.0D0 +c ENDIF +c IF (ABS(FP).lt.1.0d-20) THEN +c FP=0.0D0 +c ENDIF + + edfadis=edfadis+ep*dis_inc*wwdist + + gdfad(1,iatm1) = gdfad(1,iatm1)-jix/dist*fp*dis_inc*wwdist + gdfad(2,iatm1) = gdfad(2,iatm1)-jiy/dist*fp*dis_inc*wwdist + gdfad(3,iatm1) = gdfad(3,iatm1)-jiz/dist*fp*dis_inc*wwdist + + gdfad(1,iatm2) = gdfad(1,iatm2)+jix/dist*fp*dis_inc*wwdist + gdfad(2,iatm2) = gdfad(2,iatm2)+jiy/dist*fp*dis_inc*wwdist + gdfad(3,iatm2) = gdfad(3,iatm2)+jiz/dist*fp*dis_inc*wwdist + + enddo + + return + end + + subroutine edfat(edfator) +C DFA torsion angle + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.DFA' + + integer i,j,ii,iii + integer iatom(5) + double precision aphi(2),athe(2),tdx(5),tdy(5),tdz(5) + double precision cwidth, cwidth2 + PARAMETER(CWIDTH=0.1D0,CWIDTH2=0.2D0,PAI=3.14159265358979323846D0) + + edfator= 0.0d0 + enephi = 0.0d0 + enethe = 0.0d0 + gdfat(:,:) = 0.0d0 + +C START OF PHI ANGLE + do i=1, idfaphi + + aphi = 0.0d0 + do iii=1,5 + iatom(iii)=iphilis(iii,i)+ishiftca + enddo + +C ANGLE VECTOR CALCULTION + RIX=C(1,IATOM(2))-C(1,IATOM(1)) + RIY=C(2,IATOM(2))-C(2,IATOM(1)) + RIZ=C(3,IATOM(2))-C(3,IATOM(1)) + + RIPX=C(1,IATOM(3))-C(1,IATOM(2)) + RIPY=C(2,IATOM(3))-C(2,IATOM(2)) + RIPZ=C(3,IATOM(3))-C(3,IATOM(2)) + + RIPPX=C(1,IATOM(4))-C(1,IATOM(3)) + RIPPY=C(2,IATOM(4))-C(2,IATOM(3)) + RIPPZ=C(3,IATOM(4))-C(3,IATOM(3)) + + RIP3X=C(1,IATOM(5))-C(1,IATOM(4)) + RIP3Y=C(2,IATOM(5))-C(2,IATOM(4)) + RIP3Z=C(3,IATOM(5))-C(3,IATOM(4)) + + GIX=RIY*RIPZ-RIZ*RIPY + GIY=RIZ*RIPX-RIX*RIPZ + GIZ=RIX*RIPY-RIY*RIPX + + GIPX=RIPY*RIPPZ-RIPZ*RIPPY + GIPY=RIPZ*RIPPX-RIPX*RIPPZ + GIPZ=RIPX*RIPPY-RIPY*RIPPX + + CIPX=C(1,IATOM(3))-C(1,IATOM(1)) + CIPY=C(2,IATOM(3))-C(2,IATOM(1)) + CIPZ=C(3,IATOM(3))-C(3,IATOM(1)) + + CIPPX=C(1,IATOM(4))-C(1,IATOM(2)) + CIPPY=C(2,IATOM(4))-C(2,IATOM(2)) + CIPPZ=C(3,IATOM(4))-C(3,IATOM(2)) + + CIP3X=C(1,IATOM(5))-C(1,IATOM(3)) + CIP3Y=C(2,IATOM(5))-C(2,IATOM(3)) + CIP3Z=C(3,IATOM(5))-C(3,IATOM(3)) + + DGI=SQRT(GIX*GIX+GIY*GIY+GIZ*GIZ) + DGIP=SQRT(GIPX*GIPX+GIPY*GIPY+GIPZ*GIPZ) + DRIPP=SQRT(RIPPX*RIPPX+RIPPY*RIPPY+RIPPZ*RIPPZ) + DRIP3=SQRT(RIP3X*RIP3X+RIP3Y*RIP3Y+RIP3Z*RIP3Z) + +C END OF ANGLE VECTOR CALCULTION + + TDOT=GIX*RIPPX+GIY*RIPPY+GIZ*RIPPZ + APHI(1)=TDOT/(DGI*DRIPP) + TDOT=GIPX*RIP3X+GIPY*RIP3Y+GIPZ*RIP3Z + APHI(2)=TDOT/(DGIP*DRIP3) + + ephi = 0.0d0 + tfphi1=0.0d0 + tfphi2=0.0d0 + scc=0.0d0 + + do j=1, iphinum(i) + DDPS1=APHI(1)-FPHI1(i,j) + DDPS2=APHI(2)-FPHI2(i,j) + + DTMP = (DDPS1**2+DDPS2**2)/CWIDTH2 + + if (dtmp.ge.15.0d0) then + ps_tmp = 0.0d0 + else +c ps_tmp = dfaexp(idint(dtmp*1000)+1) + ps_tmp = exp(-dtmp) + endif + + ephi=ephi+sccphi(i,j)*ps_tmp + + tfphi1=tfphi1+sccphi(i,j)*ddps1/cwidth*ps_tmp + tfphi2=tfphi2+sccphi(i,j)*ddps2/cwidth*ps_tmp + + scc=scc+sccphi(i,j) +C write(*,'(2i8,8f12.6)')i,j,aphi(1),fphi1(i,j), +C & aphi(2),fphi2(i,j),tfphi1,tfphi2,ephi,sccphi(i,j) + ENDDO + + ephi=-ephi/scc*phi_inc*wwangle + tfphi1=tfphi1/scc*phi_inc*wwangle + tfphi2=tfphi2/scc*phi_inc*wwangle + + IF (ABS(EPHI).LT.1d-20) THEN + EPHI=0.0D0 + ENDIF + IF (ABS(TFPHI1).LT.1d-20) THEN + TFPHI1=0.0D0 + ENDIF + IF (ABS(TFPHI2).LT.1d-20) THEN + TFPHI2=0.0D0 + ENDIF + +C FORCE DIRECTION CALCULATION + TDX(1:5)=0.0D0 + TDY(1:5)=0.0D0 + TDZ(1:5)=0.0D0 + + DM1=1.0d0/(DGI*DRIPP) + + GIRPP=GIX*RIPPX+GIY*RIPPY+GIZ*RIPPZ + DM2=GIRPP/(DGI**3*DRIPP) + DM3=GIRPP/(DGI*DRIPP**3) + + DM4=1.0d0/(DGIP*DRIP3) + + GIRP3=GIPX*RIP3X+GIPY*RIP3Y+GIPZ*RIP3Z + DM5=GIRP3/(DGIP**3*DRIP3) + DM6=GIRP3/(DGIP*DRIP3**3) +C FIRST ATOM BY PHI1 + TDX(1)=(RIPZ*RIPPY-RIPY*RIPPZ)*DM1 + & +( GIZ* RIPY- GIY* RIPZ)*DM2 + TDY(1)=(RIPX*RIPPZ-RIPZ*RIPPX)*DM1 + & +( GIX* RIPZ- GIZ* RIPX)*DM2 + TDZ(1)=(RIPY*RIPPX-RIPX*RIPPY)*DM1 + & +( GIY* RIPX- GIX* RIPY)*DM2 + TDX(1)=TDX(1)*TFPHI1 + TDY(1)=TDY(1)*TFPHI1 + TDZ(1)=TDZ(1)*TFPHI1 +C SECOND ATOM BY PHI1 + TDX(2)=(CIPY*RIPPZ-CIPZ*RIPPY)*DM1 + & -(CIPY*GIZ-CIPZ*GIY)*DM2 + TDY(2)=(CIPZ*RIPPX-CIPX*RIPPZ)*DM1 + & -(CIPZ*GIX-CIPX*GIZ)*DM2 + TDZ(2)=(CIPX*RIPPY-CIPY*RIPPX)*DM1 + & -(CIPX*GIY-CIPY*GIX)*DM2 + TDX(2)=TDX(2)*TFPHI1 + TDY(2)=TDY(2)*TFPHI1 + TDZ(2)=TDZ(2)*TFPHI1 +C SECOND ATOM BY PHI2 + TDX(2)=TDX(2)+ + & ((RIPPZ*RIP3Y-RIPPY*RIP3Z)*DM4 + & +( GIPZ*RIPPY- GIPY*RIPPZ)*DM5)*TFPHI2 + TDY(2)=TDY(2)+ + & ((RIPPX*RIP3Z-RIPPZ*RIP3X)*DM4 + & +( GIPX*RIPPZ- GIPZ*RIPPX)*DM5)*TFPHI2 + TDZ(2)=TDZ(2)+ + & ((RIPPY*RIP3X-RIPPX*RIP3Y)*DM4 + & +( GIPY*RIPPX- GIPX*RIPPY)*DM5)*TFPHI2 +C THIRD ATOM BY PHI1 + TDX(3)=(-GIX+RIPPY*RIZ-RIPPZ*RIY)*DM1 + & -(GIY*RIZ-RIY*GIZ)*DM2+RIPPX*DM3 + TDY(3)=(-GIY+RIPPZ*RIX-RIPPX*RIZ)*DM1 + & -(GIZ*RIX-RIZ*GIX)*DM2+RIPPY*DM3 + TDZ(3)=(-GIZ+RIPPX*RIY-RIPPY*RIX)*DM1 + & -(GIX*RIY-RIX*GIY)*DM2+RIPPZ*DM3 + TDX(3)=TDX(3)*TFPHI1 + TDY(3)=TDY(3)*TFPHI1 + TDZ(3)=TDZ(3)*TFPHI1 +C THIRD ATOM BY PHI2 + TDX(3)=TDX(3)+ + & ((CIPPY*RIP3Z-CIPPZ*RIP3Y)*DM4 + & -(CIPPY*GIPZ-CIPPZ*GIPY)*DM5)*TFPHI2 + TDY(3)=TDY(3)+ + & ((CIPPZ*RIP3X-CIPPX*RIP3Z)*DM4 + & -(CIPPZ*GIPX-CIPPX*GIPZ)*DM5)*TFPHI2 + TDZ(3)=TDZ(3)+ + & ((CIPPX*RIP3Y-CIPPY*RIP3X)*DM4 + & -(CIPPX*GIPY-CIPPY*GIPX)*DM5)*TFPHI2 +C FOURTH ATOM BY PHI1 + TDX(4)=(GIX*DM1-RIPPX*DM3)*TFPHI1 + TDY(4)=(GIY*DM1-RIPPY*DM3)*TFPHI1 + TDZ(4)=(GIZ*DM1-RIPPZ*DM3)*TFPHI1 +C FOURTH ATOM BY PHI2 + TDX(4)=TDX(4)+ + & ((-GIPX+RIP3Y*RIPZ-RIP3Z*RIPY)*DM4 + & -( GIPY*RIPZ-RIPY*GIPZ)*DM5 + & + RIP3X*DM6)*TFPHI2 + TDY(4)=TDY(4)+ + & ((-GIPY+RIP3Z*RIPX-RIP3X*RIPZ)*DM4 + & -( GIPZ*RIPX-RIPZ*GIPX)*DM5 + & + RIP3Y*DM6)*TFPHI2 + TDZ(4)=TDZ(4)+ + & ((-GIPZ+RIP3X*RIPY-RIP3Y*RIPX)*DM4 + & -( GIPX*RIPY-RIPX*GIPY)*DM5 + & + RIP3Z*DM6)*TFPHI2 +C FIFTH ATOM BY PHI2 + TDX(5)=(GIPX*DM4-RIP3X*DM6)*TFPHI2 + TDY(5)=(GIPY*DM4-RIP3Y*DM6)*TFPHI2 + TDZ(5)=(GIPZ*DM4-RIP3Z*DM6)*TFPHI2 +C END OF FORCE DIRECTION +c force calcuation + DO II=1,5 + gdfat(1,IATOM(II))=gdfat(1,IATOM(II))+TDX(II) + gdfat(2,IATOM(II))=gdfat(2,IATOM(II))+TDY(II) + gdfat(3,IATOM(II))=gdfat(3,IATOM(II))+TDZ(II) + ENDDO +c energy calculation + enephi = enephi + ephi +c end of single assignment statement + ENDDO +C END OF PHI RESTRAINT + +C START OF THETA ANGLE + do i=1, idfathe + + athe = 0.0d0 + do iii=1,5 + iatom(iii)=ithelis(iii,i)+ishiftca + enddo + + +C ANGLE VECTOR CALCULTION + RIX=C(1,IATOM(2))-C(1,IATOM(1)) + RIY=C(2,IATOM(2))-C(2,IATOM(1)) + RIZ=C(3,IATOM(2))-C(3,IATOM(1)) + + RIPX=C(1,IATOM(3))-C(1,IATOM(2)) + RIPY=C(2,IATOM(3))-C(2,IATOM(2)) + RIPZ=C(3,IATOM(3))-C(3,IATOM(2)) + + RIPPX=C(1,IATOM(4))-C(1,IATOM(3)) + RIPPY=C(2,IATOM(4))-C(2,IATOM(3)) + RIPPZ=C(3,IATOM(4))-C(3,IATOM(3)) + + RIP3X=C(1,IATOM(5))-C(1,IATOM(4)) + RIP3Y=C(2,IATOM(5))-C(2,IATOM(4)) + RIP3Z=C(3,IATOM(5))-C(3,IATOM(4)) + + GIX=RIY*RIPZ-RIZ*RIPY + GIY=RIZ*RIPX-RIX*RIPZ + GIZ=RIX*RIPY-RIY*RIPX + + GIPX=RIPY*RIPPZ-RIPZ*RIPPY + GIPY=RIPZ*RIPPX-RIPX*RIPPZ + GIPZ=RIPX*RIPPY-RIPY*RIPPX + + GIPPX=RIPPY*RIP3Z-RIPPZ*RIP3Y + GIPPY=RIPPZ*RIP3X-RIPPX*RIP3Z + GIPPZ=RIPPX*RIP3Y-RIPPY*RIP3X + + CIPX=C(1,IATOM(3))-C(1,IATOM(1)) + CIPY=C(2,IATOM(3))-C(2,IATOM(1)) + CIPZ=C(3,IATOM(3))-C(3,IATOM(1)) + + CIPPX=C(1,IATOM(4))-C(1,IATOM(2)) + CIPPY=C(2,IATOM(4))-C(2,IATOM(2)) + CIPPZ=C(3,IATOM(4))-C(3,IATOM(2)) + + CIP3X=C(1,IATOM(5))-C(1,IATOM(3)) + CIP3Y=C(2,IATOM(5))-C(2,IATOM(3)) + CIP3Z=C(3,IATOM(5))-C(3,IATOM(3)) + + DGI=SQRT(GIX*GIX+GIY*GIY+GIZ*GIZ) + DGIP=SQRT(GIPX*GIPX+GIPY*GIPY+GIPZ*GIPZ) + DGIPP=SQRT(GIPPX*GIPPX+GIPPY*GIPPY+GIPPZ*GIPPZ) + DRIPP=SQRT(RIPPX*RIPPX+RIPPY*RIPPY+RIPPZ*RIPPZ) + DRIP3=SQRT(RIP3X*RIP3X+RIP3Y*RIP3Y+RIP3Z*RIP3Z) +C END OF ANGLE VECTOR CALCULTION + + TDOT=GIX*GIPX+GIY*GIPY+GIZ*GIPZ + ATHE(1)=TDOT/(DGI*DGIP) + TDOT=GIPX*GIPPX+GIPY*GIPPY+GIPZ*GIPPZ + ATHE(2)=TDOT/(DGIP*DGIPP) + + ETHE=0.0D0 + TFTHE1=0.0D0 + TFTHE2=0.0D0 + SCC=0.0D0 + TH_TMP=0.0d0 + + do j=1,ithenum(i) + ddth1=athe(1)-fthe1(i,j) !cos(the1)-cos(the1_ref) + ddth2=athe(2)-fthe2(i,j) !cos(the2)-cos(the2_ref) + dtmp= (ddth1**2+ddth2**2)/cwidth2 + if ( dtmp .ge. 15.0d0) then + th_tmp = 0.0d0 + else +c th_tmp = dfaexp ( idint(dtmp*1000)+1 ) + th_tmp = exp(-dtmp) + end if + + ethe=ethe+sccthe(i,j)*th_tmp + + tfthe1=tfthe1+sccthe(i,j)*ddth1/cwidth*th_tmp !-dv/dcos(the1) + tfthe2=tfthe2+sccthe(i,j)*ddth2/cwidth*th_tmp !-dv/dcos(the2) + scc=scc+sccthe(i,j) +C write(*,'(2i8,8f12.6)')i,j,athe(1),fthe1(i,j), +C & athe(2),fthe2(i,j),tfthe1,tfthe2,ethe,sccthe(i,j) + enddo + + ethe=-ethe/scc*the_inc*wwangle + tfthe1=tfthe1/scc*the_inc*wwangle + tfthe2=tfthe2/scc*the_inc*wwangle + + IF (ABS(ETHE).LT.TENM20) THEN + ETHE=0.0D0 + ENDIF + IF (ABS(TFTHE1).LT.TENM20) THEN + TFTHE1=0.0D0 + ENDIF + IF (ABS(TFTHE2).LT.TENM20) THEN + TFTHE2=0.0D0 + ENDIF + + TDX(1:5)=0.0D0 + TDY(1:5)=0.0D0 + TDZ(1:5)=0.0D0 + + DM1=1.0d0/(DGI*DGIP) + DM2=(GIX*GIPX+GIY*GIPY+GIZ*GIPZ)/(DGI**3*DGIP) + DM3=(GIX*GIPX+GIY*GIPY+GIZ*GIPZ)/(DGI*DGIP**3) + + DM4=1.0d0/(DGIP*DGIPP) + DM5=(GIPX*GIPPX+GIPY*GIPPY+GIPZ*GIPPZ)/(DGIP**3*DGIPP) + DM6=(GIPX*GIPPX+GIPY*GIPPY+GIPZ*GIPPZ)/(DGIP*DGIPP**3) + +C FIRST ATOM BY THETA1 + TDX(1)=((RIPZ*GIPY-RIPY*GIPZ)*DM1 + & -(GIY*RIPZ-GIZ*RIPY)*DM2)*TFTHE1 + TDY(1)=((-RIPZ*GIPX+RIPX*GIPZ)*DM1 + & -(-GIX*RIPZ+GIZ*RIPX)*DM2)*TFTHE1 + TDZ(1)=((RIPY*GIPX-RIPX*GIPY)*DM1 + & -(GIX*RIPY-GIY*RIPX)*DM2)*TFTHE1 +C SECOND ATOM BY THETA1 + TDX(2)=((CIPY*GIPZ-CIPZ*GIPY-RIPPY*GIZ+RIPPZ*GIY)*DM1 + & -(CIPY*GIZ-CIPZ*GIY)*DM2 + & +(RIPPY*GIPZ-RIPPZ*GIPY)*DM3)*TFTHE1 + TDY(2)=((CIPZ*GIPX-CIPX*GIPZ-RIPPZ*GIX+RIPPX*GIZ)*DM1 + & -(CIPZ*GIX-CIPX*GIZ)*DM2 + & +(RIPPZ*GIPX-RIPPX*GIPZ)*DM3)*TFTHE1 + TDZ(2)=((CIPX*GIPY-CIPY*GIPX-RIPPX*GIY+RIPPY*GIX)*DM1 + & -(CIPX*GIY-CIPY*GIX)*DM2 + & +(RIPPX*GIPY-RIPPY*GIPX)*DM3)*TFTHE1 +C SECOND ATOM BY THETA2 + TDX(2)=TDX(2)+ + & ((RIPPZ*GIPPY-RIPPY*GIPPZ)*DM4 + & -(GIPY*RIPPZ-GIPZ*RIPPY)*DM5)*TFTHE2 + TDY(2)=TDY(2)+ + & ((-RIPPZ*GIPPX+RIPPX*GIPPZ)*DM4 + & -(-GIPX*RIPPZ+GIPZ*RIPPX)*DM5)*TFTHE2 + TDZ(2)=TDZ(2)+ + & ((RIPPY*GIPPX-RIPPX*GIPPY)*DM4 + & -(GIPX*RIPPY-GIPY*RIPPX)*DM5)*TFTHE2 +C THIRD ATOM BY THETA1 + TDX(3)=((GIPY*RIZ-GIPZ*RIY-GIY*CIPPZ+GIZ*CIPPY)*DM1 + & -(GIY*RIZ-GIZ*RIY)*DM2 + & -(CIPPY*GIPZ-CIPPZ*GIPY)*DM3) *TFTHE1 + TDY(3)=((GIPZ*RIX-GIPX*RIZ-GIZ*CIPPX+GIX*CIPPZ)*DM1 + & -(GIZ*RIX-GIX*RIZ)*DM2 + & -(CIPPZ*GIPX-CIPPX*GIPZ)*DM3) *TFTHE1 + TDZ(3)=((GIPX*RIY-GIPY*RIX-GIX*CIPPY+GIY*CIPPX)*DM1 + & -(GIX*RIY-GIY*RIX)*DM2 + & -(CIPPX*GIPY-CIPPY*GIPX)*DM3) *TFTHE1 +C THIRD ATOM BY THETA2 + TDX(3)=TDX(3)+ + & ((CIPPY*GIPPZ-CIPPZ*GIPPY-RIP3Y*GIPZ+RIP3Z*GIPY)*DM4 + & -(CIPPY*GIPZ-CIPPZ*GIPY)*DM5 + & +(RIP3Y*GIPpZ-RIP3Z*GIPpY)*DM6) *TFTHE2 + TDY(3)=TDY(3)+ + & ((CIPPZ*GIPPX-CIPPX*GIPPZ-RIP3Z*GIPX+RIP3X*GIPZ)*DM4 + & -(CIPPZ*GIPX-CIPPX*GIPZ)*DM5 + & +(RIP3Z*GIPpX-RIP3X*GIPpZ)*DM6) *TFTHE2 + TDZ(3)=TDZ(3)+ + & ((CIPPX*GIPPY-CIPPY*GIPPX-RIP3X*GIPY+RIP3Y*GIPX)*DM4 + & -(CIPPX*GIPY-CIPPY*GIPX)*DM5 + & +(RIP3X*GIPpY-RIP3Y*GIPpX)*DM6) *TFTHE2 +C FOURTH ATOM BY THETA1 + TDX(4)=-((GIZ*RIPY-GIY*RIPZ)*DM1 + & -(GIPZ*RIPY-GIPY*RIPZ)*DM3) *TFTHE1 + TDY(4)=-((GIX*RIPZ-GIZ*RIPX)*DM1 + & -(GIPX*RIPZ-GIPZ*RIPX)*DM3) *TFTHE1 + TDZ(4)=-((GIY*RIPX-GIX*RIPY)*DM1 + & -(GIPY*RIPX-GIPX*RIPY)*DM3) *TFTHE1 +C FOURTH ATOM BY THETA2 + TDX(4)=TDX(4)+ + & ((GIPPY*RIPZ-GIPPZ*RIPY-GIPY*CIP3Z+GIPZ*CIP3Y)*DM4 + & -(GIPY*RIPZ-GIPZ*RIPY)*DM5 + & -(CIP3Y*GIPPZ-CIP3Z*GIPPY)*DM6)*TFTHE2 + TDY(4)=TDY(4)+ + & ((GIPPZ*RIPX-GIPPX*RIPZ-GIPZ*CIP3X+GIPX*CIP3Z)*DM4 + & -(GIPZ*RIPX-GIPX*RIPZ)*DM5 + & -(CIP3Z*GIPPX-CIP3X*GIPPZ)*DM6)*TFTHE2 + TDZ(4)=TDZ(4)+ + & ((GIPPX*RIPY-GIPPY*RIPX-GIPX*CIP3Y+GIPY*CIP3X)*DM4 + & -(GIPX*RIPY-GIPY*RIPX)*DM5 + & -(CIP3X*GIPPY-CIP3Y*GIPPX)*DM6)*TFTHE2 +C FIFTH ATOM BY THETA2 + TDX(5)=-((GIPZ*RIPPY-GIPY*RIPPZ)*DM4 + & -(GIPPZ*RIPPY-GIPPY*RIPPZ)*DM6)*TFTHE2 + TDY(5)=-((GIPX*RIPPZ-GIPZ*RIPPX)*DM4 + & -(GIPPX*RIPPZ-GIPPZ*RIPPX)*DM6)*TFTHE2 + TDZ(5)=-((GIPY*RIPPX-GIPX*RIPPY)*DM4 + & -(GIPPY*RIPPX-GIPPX*RIPPY)*DM6)*TFTHE2 +C !! END OF FORCE DIRECTION!!!! + DO II=1,5 + gdfat(1,iatom(II))=gdfat(1,iatom(II))+TDX(II) + gdfat(2,iatom(II))=gdfat(2,iatom(II))+TDY(II) + gdfat(3,iatom(II))=gdfat(3,iatom(II))+TDZ(II) + ENDDO +C energy calculation + enethe = enethe + ethe + ENDDO + + edfator = enephi + enethe + + RETURN + END + + subroutine edfan(edfanei) +C DFA neighboring CA restraint + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.DFA' + + integer i,j,imin + integer kshnum, n1atom + + double precision enenei,tmp_n + double precision pai,hpai + double precision jix,jiy,jiz,ndiff,snorm_nei + double precision t2dx(maxres),t2dy(maxres),t2dz(maxres) + double precision dr,dr2,half,ntmp,dtmp + + parameter(dr=0.25d0,dr2=0.50d0,half=0.50d0) + parameter(pai=3.14159265358979323846D0) + parameter(hpai=1.5707963267948966D0) + parameter(snorm_nei=0.886226925452758D0) + + edfanei = 0.0d0 + enenei = 0.0d0 + gdfan = 0.0d0 + +c print*, 's1:', s1(:) +c print*, 's2:', s2(:) + + do i=1, idfanei + + kshnum=kshell(i) + n1atom=ineilis(i)+ishiftca +C write(*,*) 'kshnum,n1atom:', kshnum, n1atom + + tmp_n=0.0d0 + ftmp=0.0d0 + dnei=0.0d0 + dist=0.0d0 + t1dx=0.0d0 + t1dy=0.0d0 + t1dz=0.0d0 + t2dx=0.0d0 + t2dy=0.0d0 + t2dz=0.0d0 + + do j = ishiftca+1, ilastca + + if (n1atom.eq.j) cycle + + jix=c(1,j)-c(1,n1atom) + jiy=c(2,j)-c(2,n1atom) + jiz=c(3,j)-c(3,n1atom) + dist=sqrt(jix*jix+jiy*jiy+jiz*jiz) + +c write(*,*) n1atom, j, dist + + if(kshnum.ne.1)then + if (dist.lt.s1(kshnum).and. + & dist.gt.s2(kshnum-1)) then + + tmp_n=tmp_n+1.0d0 + +c write(*,*) 'case1:',tmp_n + + t1dx=t1dx+0.0d0 + t1dy=t1dy+0.0d0 + t1dz=t1dz+0.0d0 + t2dx(j)=0.0d0 + t2dy(j)=0.0d0 + t2dz(j)=0.0d0 + + elseif(dist.ge.s1(kshnum).and. + & dist.le.s2(kshnum)) then + + dnei=(dist-s1(kshnum))/dr2*pai + tmp_n=tmp_n + half*(1+cos(dnei)) +c write(*,*) 'case2:',tmp_n + ftmp=-pai*sin(dnei)/dr2/dist/2.0d0 +c center atom + t1dx=t1dx+jix*ftmp + t1dy=t1dy+jiy*ftmp + t1dz=t1dz+jiz*ftmp +c neighbor atoms + t2dx(j)=-jix*ftmp + t2dy(j)=-jiy*ftmp + t2dz(j)=-jiz*ftmp +c + elseif(dist.ge.s1(kshnum-1).and. + & dist.le.s2(kshnum-1)) then + dnei=(dist-s1(kshnum-1))/dr2*pai + tmp_n=tmp_n + 1.0d0 - half*(1+cos(dnei)) +c write(*,*) 'case3:',tmp_n + ftmp = hpai*sin(dnei)/dr2/dist +c center atom + t1dx=t1dx+jix*ftmp + t1dy=t1dy+jiy*ftmp + t1dz=t1dz+jiz*ftmp +c neighbor atoms + t2dx(j)=-jix*ftmp + t2dy(j)=-jiy*ftmp + t2dz(j)=-jiz*ftmp + + endif + + elseif(kshnum.eq.1) then + + if(dist.lt.s1(kshnum))then + + tmp_n=tmp_n+1.0d0 +c write(*,*) 'case4:',tmp_n + t1dx=t1dx+0.0d0 + t1dy=t1dy+0.0d0 + t1dz=t1dz+0.0d0 + t2dx(j)=0.0d0 + t2dy(j)=0.0d0 + t2dz(j)=0.0d0 + + elseif(dist.ge.s1(kshnum).and. + & dist.le.s2(kshnum))then + + dnei=(dist-s1(kshnum))/dr2*pai + tmp_n=tmp_n + half*(1+cos(dnei)) +c write(*,*) 'case5:',tmp_n + ftmp = -hpai*sin(dnei)/dr2/dist +c center atom + t1dx=t1dx+jix*ftmp + t1dy=t1dy+jiy*ftmp + t1dz=t1dz+jiz*ftmp +c neighbor atoms + t2dx(j)=-jix*ftmp + t2dy(j)=-jiy*ftmp + t2dz(j)=-jiz*ftmp + + endif + endif + enddo + + scc=0.0d0 + enei=0.0d0 + tmp_fnei=0.0d0 + ndiff=0.0d0 + + do imin=1,ineinum(i) + + ndiff = tmp_n-fnei(i,imin) + dtmp = ndiff*ndiff + + if (dtmp.ge.15.0d0) then + ntmp = 0.0d0 + else +c ntmp = dfaexp( idint(dtmp*1000) + 1 ) + ntmp = exp(-dtmp) + end if + + enei=enei+sccnei(i,imin)*ntmp + tmp_fnei=tmp_fnei- + & sccnei(i,imin)*ntmp*ndiff*2.0d0 + scc=scc+sccnei(i,imin) + +c write(*,'(a,1x,2i8,f12.7,i8,3f12.7)')'NEI:',i,imin,tmp_n, +c & fnei(i,imin),sccnei(i,imin),enei,scc + enddo + + enei=-enei/scc*snorm_nei*nei_inc*wwnei + tmp_fnei=tmp_fnei/scc*snorm_nei*nei_inc*wwnei + +c if (abs(enei).lt.1.0d-20)then +c enei=0.0d0 +c endif +c if (abs(tmp_fnei).lt.1.0d-20) then +c tmp_fnei=0.0d0 +c endif + +c force calculation + t1dx=t1dx*tmp_fnei + t1dy=t1dy*tmp_fnei + t1dz=t1dz*tmp_fnei + + do j=ishiftca+1,ilastca + t2dx(j)=t2dx(j)*tmp_fnei + t2dy(j)=t2dy(j)*tmp_fnei + t2dz(j)=t2dz(j)*tmp_fnei + enddo + + gdfan(1,n1atom)=gdfan(1,n1atom)+t1dx + gdfan(2,n1atom)=gdfan(2,n1atom)+t1dy + gdfan(3,n1atom)=gdfan(3,n1atom)+t1dz + + do j=ishiftca+1,ilastca + gdfan(1,j)=gdfan(1,j)+t2dx(j) + gdfan(2,j)=gdfan(2,j)+t2dy(j) + gdfan(3,j)=gdfan(3,j)+t2dz(j) + enddo +c energy calculation + + enenei=enenei+enei + + enddo + + edfanei=enenei + + return + end + + subroutine edfab(edfabeta) + + implicit real*8 (a-h,o-z) + + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.DFA' + + real*8 PAI + parameter(PAI=3.14159265358979323846D0) + parameter (maxca=800) +C sheet variables + real*8 bx(maxres),by(maxres),bz(maxres) + real*8 vbet(maxres,maxres) + real*8 shetfx(maxres),shetfy(maxres),shetfz(maxres) + real*8 shefx(maxres,12),shefy(maxres,12),shefz(maxres,12) + real*8 vbeta,vbetp,vbetm + real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, + & c00,s00,ulnex,dnex + real*8 dp45,dm45,w_beta + + real*8 cph(maxca),cth(maxca) + real*8 atx(maxca),aty(maxca),atz(maxca) + real*8 atmx(maxca),atmy(maxca),atmz(maxca) + real*8 atmmx(maxca),atmmy(maxca),atmmz(maxca) + real*8 atm3x(maxca),atm3y(maxca),atm3z(maxca) + real*8 sth(maxca) + real*8 astx(maxca),asty(maxca),astz(maxca) + real*8 astmx(maxca),astmy(maxca),astmz(maxca) + real*8 astmmx(maxca),astmmy(maxca),astmmz(maxca) + real*8 astm3x(maxca),astm3y(maxca),astm3z(maxca) + + real*8 atxnum(maxca),atynum(maxca),atznum(maxca), + & astxnum(maxca),astynum(maxca),astznum(maxca), + & atmxnum(maxca),atmynum(maxca),atmznum(maxca), + & astmxnum(maxca),astmynum(maxca),astmznum(maxca), + & atmmxnum(maxca),atmmynum(maxca),atmmznum(maxca), + & astmmxnum(maxca),astmmynum(maxca),astmmznum(maxca), + & atm3xnum(maxca),atm3ynum(maxca),atm3znum(maxca), + & astm3xnum(maxca),astm3ynum(maxca),astm3znum(maxca), + & cth_orig(maxca),sth_orig(maxca) + + common /sheca/ bx,by,bz + common /shee/ vbeta,vbet,vbetp,vbetm + common /shetf/ shetfx,shetfy,shetfz + common /shef/ shefx, shefy, shefz + common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, + & c00,s00,ulnex,dnex + common /sheconst/ dp45,dm45,w_beta + + common /angvt/ atx,aty,atz,atmx,atmy,atmz,atmmx,atmmy, + $ atmmz,atm3x,atm3y,atm3z + common /angvt2/ astx,asty,astz,astmx,astmy,astmz,astmmx,astmmy, + $ astmmz,astm3x,astm3y,astm3z + + common /coscos/ cph,cth + common /sinsin/ sth + +C End of sheet variables + + integer i,j + double precision enebet + + enebet=0.0d0 + bx=0.0d0;by=0.0d0;bz=0.0d0 + shetfx=0.0d0;shetfy=0.0d0;shetfz=0.0d0 + + gdfab=0.0d0 + + do i=ishiftca+1,ilastca + bx(i-ishiftca)=c(1,i) + by(i-ishiftca)=c(2,i) + bz(i-ishiftca)=c(3,i) + enddo + +c do i=1,ilastca-ishiftca +c read(99,*) bx(i),by(i),bz(i) +c enddo +c close(99) + + dca=0.25d0**2 + dshe=0.3d0**2 + ULHB=5.0D0 + ULDHB=5.0D0 + ULNEX=COS(60.0D0/180.0D0*PAI) + + DLHB=1.0D0 + DLDHB=1.0D0 + + DNEX=0.3D0**2 + + C00=COS((1.0D0+10.0D0/180.0D0)*PAI) + S00=SIN((1.0D0+10.0D0/180.0D0)*PAI) + + W_BETA=0.5D0 + DP45=W_BETA + DM45=W_BETA + +C END OF INITIALIZATION + + nca=ilastca-ishiftca + + call angvectors(nca) + call sheetforce(nca,wshet) + +c end of sheet energy and force + + do j=1,nca + shetfx(j)=shetfx(j)*beta_inc + shetfy(j)=shetfy(j)*beta_inc + shetfz(j)=shetfz(j)*beta_inc +c write(*,*)'SHETF:',shetfx(j),shetfy(j),shetfz(j) + enddo + + vbeta=vbeta*beta_inc + enebet=vbeta + edfabeta=enebet + + do j=1,nca + gdfab(1,j+ishiftca)=gdfab(1,j+ishiftca)-shetfx(j) + gdfab(2,j+ishiftca)=gdfab(2,j+ishiftca)-shetfy(j) + gdfab(3,j+ishiftca)=gdfab(3,j+ishiftca)-shetfz(j) + enddo + +#ifdef DEBUG1 + do j=1,nca + write(*,'(5x,i5,10x,3f10.5)') j,bx(j),by(j),bz(j) + enddo + + + gdfab=0 + dinc=0.001 + do j=1,nca + cth_orig(j)=cth(j) + sth_orig(j)=sth(j) + enddo + + do j=1,nca + + bx(j)=bx(j)+dinc + call angvectors(nca) + bx(j)=bx(j)-2*dinc + call angvectors(nca) + atxnum(j)=0.5*(cth(j)-cth_orig(j))/dinc + astxnum(j)=0.5*(sth(j)-sth_orig(j))/dinc + if (j.gt.1) then + atmxnum(j)=0.5*(cth(j-1)-cth_orig(j-1))/dinc + astmxnum(j)=0.5*(sth(j-1)-sth_orig(j-1))/dinc + endif + if (j.gt.2) then + atmmxnum(j)=0.5*(cth(j-2)-cth_orig(j-2))/dinc + astmmxnum(j)=0.5*(sth(j-2)-sth_orig(j-2))/dinc + endif + if (j.gt.3) then + atm3xnum(j)=0.5*(cth(j-3)-cth_orig(j-3))/dinc + astm3xnum(j)=0.5*(sth(j-3)-sth_orig(j-3))/dinc + endif + bx(j)=bx(j)+dinc + by(j)=by(j)+dinc + call angvectors(nca) + by(j)=by(j)-2*dinc + call angvectors(nca) + by(j)=by(j)+dinc + atynum(j)=0.5*(cth(j)-cth_orig(j))/dinc + astynum(j)=0.5*(sth(j)-sth_orig(j))/dinc + if (j.gt.1) then + atmynum(j)=0.5*(cth(j-1)-cth_orig(j-1))/dinc + astmynum(j)=0.5*(sth(j-1)-sth_orig(j-1))/dinc + endif + if (j.gt.2) then + atmmynum(j)=0.5*(cth(j-2)-cth_orig(j-2))/dinc + astmmynum(j)=0.5*(sth(j-2)-sth_orig(j-2))/dinc + endif + if (j.gt.3) then + atm3ynum(j)=0.5*(cth(j-3)-cth_orig(j-3))/dinc + astm3ynum(j)=0.5*(sth(j-3)-sth_orig(j-3))/dinc + endif + + bz(j)=bz(j)+dinc + call angvectors(nca) + bz(j)=bz(j)-2*dinc + call angvectors(nca) + bz(j)=bz(j)+dinc + + atznum(j)=0.5*(cth(j)-cth_orig(j))/dinc + astznum(j)=0.5*(sth(j)-sth_orig(j))/dinc + if (j.gt.1) then + atmznum(j)=0.5*(cth(j-1)-cth_orig(j-1))/dinc + astmznum(j)=0.5*(sth(j-1)-sth_orig(j-1))/dinc + endif + if (j.gt.2) then + atmmznum(j)=0.5*(cth(j-2)-cth_orig(j-2))/dinc + astmmznum(j)=0.5*(sth(j-2)-sth_orig(j-2))/dinc + endif + if (j.gt.3) then + atm3znum(j)=0.5*(cth(j-3)-cth_orig(j-3))/dinc + astm3znum(j)=0.5*(sth(j-3)-sth_orig(j-3))/dinc + endif + + enddo + + do i=1,nca + write (*,'(2i5,a2,6f10.5)') + & i,1,"x",atxnum(i),atx(i),atxnum(i)/atx(i), + & astxnum(i),astx(i),astxnum(i)/astx(i), + & i,1,"y",atynum(i),aty(i),atynum(i)/aty(i), + & astynum(i),asty(i),astynum(i)/asty(i), + & i,1,"z",atznum(i),atz(i),atznum(i)/atz(i), + & astznum(i),astz(i),astznum(i)/astz(i), + & i,2,"x",atmxnum(i),atmx(i),atmxnum(i)/atmx(i), + & astmxnum(i),astmx(i),astmxnum(i)/astmx(i), + & i,2,"y",atmynum(i),atmy(i),atmynum(i)/atmy(i), + & astmynum(i),astmy(i),astmynum(i)/astmy(i), + & i,2,"z",atmznum(i),atmz(i),atmznum(i)/atmz(i), + & astmznum(i),astmz(i),astmznum(i)/astmz(i), + & i,3,"x",atmmxnum(i),atmmx(i),atmmxnum(i)/atmmx(i), + & astmmxnum(i),astmmx(i),astmmxnum(i)/astmmx(i), + & i,3,"y",atmmynum(i),atmmy(i),atmmynum(i)/atmmy(i), + & astmmynum(i),astmmy(i),astmmynum(i)/astmmy(i), + & i,3,"z",atmmznum(i),atmmz(i),atmmznum(i)/atmmz(i), + & astmmznum(i),astmmz(i),astmmznum(i)/astmmz(i), + & i,4,"x",atm3xnum(i),atm3x(i),atm3xnum(i)/atm3x(i), + & astm3xnum(i),astm3x(i),astm3xnum(i)/astm3x(i), + & i,4,"y",atm3ynum(i),atm3y(i),atm3ynum(i)/atm3y(i), + & astm3ynum(i),astm3y(i),astm3ynum(i)/astm3y(i), + & i,4,"z",atm3znum(i),atm3z(i),atm3znum(i)/atm3z(i), + & astm3znum(i),astm3z(i),astm3znum(i)/astm3z(i), + & i,0," ",cth_orig(i),sth_orig(i) + enddo + + + gdfab=0 + dinc=0.001 + + do j=1,nca + + bx(j)=bx(j)+dinc + call angvectors(nca) + call sheetforce(nca,wshet) + vbeta1=vbeta*beta_inc + bx(j)=bx(j)-2*dinc + call angvectors(nca) + call sheetforce(nca,wshet) + vbeta2=vbeta*beta_inc + gdfab(1,j)=(vbeta2-vbeta1)/dinc/2 + bx(j)=bx(j)+dinc + + by(j)=by(j)+dinc + call angvectors(nca) + call sheetforce(nca,wshet) + vbeta1=vbeta*beta_inc + by(j)=by(j)-2*dinc + call angvectors(nca) + call sheetforce(nca,wshet) + vbeta2=vbeta*beta_inc + gdfab(2,j)=(vbeta2-vbeta1)/dinc/2 + by(j)=by(j)+dinc + + bz(j)=bz(j)+dinc + call angvectors(nca) + call sheetforce(nca,wshet) + vbeta1=vbeta*beta_inc + bz(j)=bz(j)-2*dinc + call angvectors(nca) + call sheetforce(nca,wshet) + vbeta2=vbeta*beta_inc + gdfab(3,j)=(vbeta2-vbeta1)/dinc/2 + bz(j)=bz(j)+dinc + + + enddo + + + call angvectors(nca) + call sheetforce(nca,wshet) + do j=1,nca + shetfx(j)=shetfx(j)*beta_inc + shetfy(j)=shetfy(j)*beta_inc + shetfz(j)=shetfz(j)*beta_inc + enddo + + + write(*,*) 'xyz analytical and numerical gradient' + do j=1,nca + write(*,'(5x,i5,10x,6f10.5)') j,-shetfx(j),-shetfy(j),-shetfz(j) + & ,(-gdfab(i,j),i=1,3) + enddo + + do j=1,nca + write(*,'(5x,i5,10x,3f10.2)') j,shetfx(j)/gdfab(1,j), + & shetfy(j)/gdfab(2,j), + & shetfz(j)/gdfab(3,j) + enddo + + stop +#endif + + return + end +C------------------------------------------------------------------------------- + subroutine angvectors(nca) +c implicit real*4(a-h,o-z) + implicit none + integer nca + integer maxca + parameter(maxca=800) + real*8 pai,zero + parameter(PAI=3.14159265358979323846D0,zero=0.0d0) + + real*8 bx(maxca),by(maxca),bz(maxca) + real*8 dis(maxca,maxca) + real*8 apx(maxca),apy(maxca),apz(maxca) + real*8 apmx(maxca),apmy(maxca),apmz(maxca) + real*8 apmmx(maxca),apmmy(maxca),apmmz(maxca) + real*8 apm3x(maxca),apm3y(maxca),apm3z(maxca) + real*8 atx(maxca),aty(maxca),atz(maxca) + real*8 atmx(maxca),atmy(maxca),atmz(maxca) + real*8 atmmx(maxca),atmmy(maxca),atmmz(maxca) + real*8 atm3x(maxca),atm3y(maxca),atm3z(maxca) + real*8 astx(maxca),asty(maxca),astz(maxca) + real*8 astmx(maxca),astmy(maxca),astmz(maxca) + real*8 astmmx(maxca),astmmy(maxca),astmmz(maxca) + real*8 astm3x(maxca),astm3y(maxca),astm3z(maxca) + real*8 sth(maxca) + real*8 cph(maxca),cth(maxca) + real*8 ulcos(maxca) + real*8 p,c + integer i, ip, ipp, ip3, j + real*8 rx(maxca, maxca), ry(maxca, maxca), rz(maxca, maxca) + real*8 rix, riy, riz, ripx, ripy, ripz, rippx, rippy, rippz + real*8 gix, giy, giz, gipx, gipy, gipz, gippx, gippy, gippz + real*8 cix, ciy, ciz, cipx, cipy, cipz + real*8 gpcrp_x, gpcrp_y, gpcrp_z, d_gpcrp, gpcrp__g + real*8 d10, d11, d12, d13, d20, d21, d22, d23, d24 + real*8 d30, d31, d32, d33, d34, d35, d40, d41, d42, d43 + real*8 d_gcr, d_gcr3, d_gmcrim,d_gmcrim3,dgmmcrimm,d_gmmcrimm3 + real*8 dg, dg3, dg30, dgm, dgm3, dgmm, dgmm3, dgp, dri + real*8 dri3, drim, drim3, drimm, drip, dripp, g3gmm, g3rim + real*8 g3x, g3y, g3z, d_gmmcrimm, g3rim_,gcr__gm + real*8 gcr_x,gcr_y,gcr_z,ggm,ggp,gmcrim__gmm + real*8 gmcrim_x,gmcrim_y,gmcrim_z,gmmcrimm__gmmm + real*8 gmmcrimm_x,gmmcrimm_y,gmmcrimm_z,gmmgm,gmmr + real*8 gmmx,gmmy,gmmz,gmrp,gmx,gmy,gmz,gpx,gpy,gpz + real*8 grpp,gx,gy,gz + real*8 rim3x,rim3y,rim3z,rimmx,rimmy,rimmz,rimx,rimy,rimz + real*8 sd10,sd11,sd20,sd21,sd22,sd30,sd31,sd32,sd40,sd41 + integer inb,nmax,iselect + + common /sheca/ bx,by,bz + common /difvec/ rx, ry, rz + common /ulang/ ulcos + common /phys1/ inb,nmax,iselect + common /phys4/ p,c + common /kyori2/ dis + common /angvp/ apx,apy,apz,apmx,apmy,apmz,apmmx,apmmy, + & apmmz,apm3x,apm3y,apm3z + common /angvt/ atx,aty,atz,atmx,atmy,atmz,atmmx,atmmy, + & atmmz,atm3x,atm3y,atm3z + common /coscos/ cph,cth + common /angvt2/ astx,asty,astz,astmx,astmy,astmz,astmmx,astmmy, + & astmmz,astm3x,astm3y,astm3z + common /sinsin/ sth +C------------------------------------------------------------------------------- +c write(*,*) 'inside angvectors' +C initialize + p=0.1d0 + c=1.0d0 + inb=nca + cph=zero; cth=zero; sth=zero + apx=zero;apy=zero;apz=zero;apmx=zero;apmy=zero;apmz=zero + apmmx=zero;apmmy=zero;apmmz=zero;apm3x=zero;apm3y=zero;apm3z=zero + atx=zero;aty=zero;atz=zero;atmx=zero;atmy=zero;atmz=zero + atmmx=zero;atmmy=zero;atmmz=zero;atm3x=zero;atm3y=zero;atm3z=zero + astx=zero;asty=zero;astz=zero;astmx=zero;astmy=zero;astmz=zero + astmmx=zero;astmmy=zero;astmmz=zero;astm3x=zero;astm3y=zero + astm3z=zero +C end of initialize +C r[x,y,z] calc and distance calculation + rx=zero;ry=zero;rz=zero + + do i=1,inb + do j=1,inb + rx(i,j)=bx(j)-bx(i) + ry(i,j)=by(j)-by(i) + rz(i,j)=bz(j)-bz(i) + dis(i,j)=sqrt(rx(i,j)**2+ry(i,j)**2+rz(i,j)**2) +c write(*,*) 'rx(i,j):',i,j,rx(i,j),bx(j),bx(i) +c write(*,*) 'ry(i,j):',i,j,ry(i,j),by(j),by(i) +c write(*,*) 'rz(i,j):',i,j,rz(i,j),bz(j),bz(i) +c write(*,*) 'dis(i,j):',i,j,dis(i,j) + enddo + enddo +c end of r[x,y,z] calc +C cos calc + do i=1,inb-2 + ip=i+1 + ipp=i+2 + + if(dis(i,ip).ge.1.0e-8.and.dis(ip,ipp).ge.1.0e-8) then + ulcos(i)=rx(i,ip)*rx(ip,ipp)+ry(i,ip)*ry(ip,ipp) + $ +rz(i,ip)*rz(ip,ipp) + ulcos(i)=ulcos(i)/(dis(i,ip)*dis(ip,ipp)) + endif + enddo +c end of virtual bond angle +c write(*,*) 'inside angvectors1' +crc do i=1,inb-3 + do i=1,inb + ip=i+1 + ipp=i+2 + ip3=i+3 + rix=bx(ip)-bx(i) + riy=by(ip)-by(i) + riz=bz(ip)-bz(i) + ripx=bx(ipp)-bx(ip) + ripy=by(ipp)-by(ip) + ripz=bz(ipp)-bz(ip) + rippx=bx(ip3)-bx(ipp) + rippy=by(ip3)-by(ipp) + rippz=bz(ip3)-bz(ipp) + + gx=riy*ripz-riz*ripy + gy=riz*ripx-rix*ripz + gz=rix*ripy-riy*ripx + gpx=ripy*rippz-ripz*rippy + gpy=ripz*rippx-ripx*rippz + gpz=ripx*rippy-ripy*rippx + gpcrp_x=gpy*ripz-gpz*ripy + gpcrp_y=gpz*ripx-gpx*ripz + gpcrp_z=gpx*ripy-gpy*ripx + d_gpcrp=sqrt(gpcrp_x**2+gpcrp_y**2+gpcrp_z**2) + gpcrp__g=gx*gpy*ripz+gpx*ripy*gz+ripx*gpz*gy + & -gz*gpy*ripx-gpz*ripy*gx-ripz*gpx*gy + + if(i.ge.2) then + rimx=bx(i)-bx(i-1) + rimy=by(i)-by(i-1) + rimz=bz(i)-bz(i-1) + gmx=rimy*riz-rimz*riy + gmy=rimz*rix-rimx*riz + gmz=rimx*riy-rimy*rix + dgm=sqrt(gmx**2+gmy**2+gmz**2) + dgm3=dgm**3 + ggm=gmx*gx+gmy*gy+gmz*gz + gmrp=gmx*ripx+gmy*ripy+gmz*ripz + drim=dis(i-1,i) + drim3=drim**3 + gcr_x=gy*riz-gz*riy + gcr_y=gz*rix-gx*riz + gcr_z=gx*riy-gy*rix + d_gcr=sqrt(gcr_x**2+gcr_y**2+gcr_z**2) + d_gcr3=d_gcr**3 + gcr__gm=gmx*gy*riz+gx*riy*gmz+rix*gz*gmy + & -gmz*gy*rix-gz*riy*gmx-riz*gx*gmy + endif +c write(*,*) 'inside angvectors2' + if(i.ge.3) then + rimmx=bx(i-1)-bx(i-2) + rimmy=by(i-1)-by(i-2) + rimmz=bz(i-1)-bz(i-2) + drimm=dis(i-2,i-1) + gmmx=rimmy*rimz-rimmz*rimy + gmmy=rimmz*rimx-rimmx*rimz + gmmz=rimmx*rimy-rimmy*rimx + dgmm=sqrt(gmmx**2+gmmy**2+gmmz**2) + dgmm3=dgmm**3 + gmmgm=gmmx*gmx+gmmy*gmy+gmmz*gmz + gmmr=gmmx*rix+gmmy*riy+gmmz*riz + gmcrim_x=gmy*rimz-gmz*rimy + gmcrim_y=gmz*rimx-gmx*rimz + gmcrim_z=gmx*rimy-gmy*rimx + d_gmcrim=sqrt(gmcrim_x**2+gmcrim_y**2+gmcrim_z**2) + d_gmcrim3=d_gmcrim**3 + gmcrim__gmm=gmmx*gmy*rimz+gmx*rimy*gmmz+rimx*gmz*gmmy + & -gmmz*gmy*rimx-gmz*rimy*gmmx-rimz*gmx*gmmy + endif + + if(i.ge.4) then + rim3x=bx(i-2)-bx(i-3) + rim3y=by(i-2)-by(i-3) + rim3z=bz(i-2)-bz(i-3) + g3x=rim3y*rimmz-rim3z*rimmy + g3y=rim3z*rimmx-rim3x*rimmz + g3z=rim3x*rimmy-rim3y*rimmx + dg30=sqrt(g3x**2+g3y**2+g3z**2) + g3gmm=g3x*gmmx+g3y*gmmy+g3z*gmmz + g3rim_=g3x*rimx+g3y*rimy+g3z*rimz +cc********************************************************************** + gmmcrimm_x=gmmy*rimmz-gmmz*rimmy + gmmcrimm_y=gmmz*rimmx-gmmx*rimmz + gmmcrimm_z=gmmx*rimmy-gmmy*rimmx + d_gmmcrimm=sqrt(gmmcrimm_x**2+gmmcrimm_y**2+gmmcrimm_z**2) + d_gmmcrimm3=d_gmmcrimm**3 + gmmcrimm__gmmm=g3x*gmmy*rimmz+gmmx*rimmy*g3z+rimmx*gmmz*g3y + & -g3z*gmmy*rimmx-gmmz*rimmy*g3x-rimmz*gmmx*g3y + endif + + dri=dis(i,i+1) + drip=dis(i+1,i+2) + dripp=dis(i+2,i+3) + dri3=dri**3 + dg=sqrt(gx**2+gy**2+gz**2) + dgp=sqrt(gpx**2+gpy**2+gpz**2) + dg3=dg**3 + + ggp=gx*gpx+gy*gpy+gz*gpz + grpp=gx*rippx+gy*rippy+gz*rippz + + if(dg.gt.0.0D0.and.dripp.gt.0.0D0.and.dgp.gt.0.0D0 + & .and.d_gpcrp.gt.0.0D0) then + cph(i)=grpp/dg/dripp + cth(i)=ggp/dg/dgp + sth(i)=gpcrp__g/d_gpcrp/dg + else +c + cph(i)=1.0D0 + cth(i)=1.0D0 + sth(i)=0.0D0 + endif + +c write(*,*) 'inside angvectors3' + + if(dgp.gt.0.0D0.and.dg3.gt.0.0D0 + & .and.dripp.gt.0.0D0.and.d_gpcrp.gt.0.0D0) then + d10=1.0D0/(dg*dgp) + d11=ggp/(dg3*dgp) + d12=1.0D0/(dg*dripp) + d13=grpp/(dg3*dripp) + sd10=1.0D0/(d_gpcrp*dg) + sd11=gpcrp__g/(d_gpcrp*dg3) + else + d10=0.0D0 + d11=0.0D0 + d12=0.0D0 + d13=0.0D0 + sd10=0.0D0 + sd11=0.0D0 + endif + + atx(i)=(ripz*gpy-ripy*gpz)*d10 + & -(gy*ripz-gz*ripy)*d11 + aty(i)=(ripx*gpz-ripz*gpx)*d10 + & -(gz*ripx-gx*ripz)*d11 + atz(i)=(ripy*gpx-ripx*gpy)*d10 + & -(gx*ripy-gy*ripx)*d11 + astx(i)=sd10*(-gpx*ripy**2+ripx*gpz*ripz + & +ripy*gpy*ripx-gpx*ripz**2) + & -sd11*(gy*ripz-gz*ripy) + asty(i)=sd10*(-gpy*ripz**2+gpx*ripy*ripx + & -gpy*ripx**2+gpz*ripy*ripz) + & -sd11*(-gx*ripz+gz*ripx) + astz(i)=sd10*(ripy*gpy*ripz-gpz*ripx**2 + & -gpz*ripy**2+ripz*gpx*ripx) + & -sd11*(gx*ripy-gy*ripx) + apx(i)=(ripz*rippy-ripy*rippz)*d12 + & -(gy*ripz-gz*ripy)*d13 + apy(i)=(ripx*rippz-ripz*rippx)*d12 + & -(gz*ripx-gx*ripz)*d13 + apz(i)=(ripy*rippx-ripx*rippy)*d12 + & -(gx*ripy-gy*ripx)*d13 + + if(i.ge.2) then + cix=bx(ip)-bx(i-1) + ciy=by(ip)-by(i-1) + ciz=bz(ip)-bz(i-1) + cipx=bx(ipp)-bx(i) + cipy=by(ipp)-by(i) + cipz=bz(ipp)-bz(i) + ripx=bx(ipp)-bx(ip) + ripy=by(ipp)-by(ip) + ripz=bz(ipp)-bz(ip) + if(dgm3.gt.0.0D0.and.dg3.gt.0.0D0.and.drip.gt.0.0D0 + & .and.d_gcr3.gt.0.0D0) then + d20=1.0D0/(dg*dgm) + d21=ggm/(dgm3*dg) + d22=ggm/(dgm*dg3) + d23=1.0D0/(dgm*drip) + d24=gmrp/(dgm3*drip) + sd20=1.0D0/(d_gcr*dgm) + sd21=gcr__gm/(d_gcr3*dgm) + sd22=gcr__gm/(d_gcr*dgm3) + else + d20=0.0D0 + d21=0.0D0 + d22=0.0D0 + d23=0.0D0 + d24=0.0D0 + sd20=0.0D0 + sd21=0.0D0 + sd22=0.0D0 + endif + atmx(i)=(ciy*gz-ciz*gy-ripy*gmz+ripz*gmy)*d20 + & -(ciy*gmz-ciz*gmy)*d21 + & +(ripy*gz-ripz*gy)*d22 + atmy(i)=(ciz*gx-cix*gz-ripz*gmx+ripx*gmz)*d20 + & -(ciz*gmx-cix*gmz)*d21 + & +(ripz*gx-ripx*gz)*d22 + atmz(i)=(cix*gy-ciy*gx-ripx*gmy+ripy*gmx)*d20 + & -(cix*gmy-ciy*gmx)*d21 + & +(ripx*gy-ripy*gx)*d22 +cc********************************************************************** + astmx(i)=sd20*(gmx*ripz*riz+gx*riy*ciy-gz*gmy + & -rix*ripy*gmy-rix*gz*ciz-ciy*gy*rix-gmz*ripz*rix + & +gmz*gy+ripy*riy*gmx+riz*gx*ciz) + & -sd21*(gcr_x*(ripz*riz+ripy*riy)+gcr_y*(-ripy*rix-gz) + & +gcr_z*(-ripz*rix+gy)) + & -sd22*(-gmy*ciz+gmz*ciy) + + astmy(i)=sd20*(ciz*gy*riz-ripz*riy*gmz-gx*gmz-gx*riy*cix + & +rix*ripx*gmy+cix*gy*rix-ripx*riy*gmx+gz*gmx-gz*riy*ciz + & +riz*ripz*gmy) + & -sd21*(gcr_x*(-ripx*riy+gz)+gcr_y*(ripx*rix+ripz*riz) + & -gcr_z*(ripz*riy+gx)) + & -sd22*(gmx*ciz-gmz*cix) + + astmz(i)=sd20*(-ciy*gy*riz-gmx*ripx*riz-gmx*gy+ripy*riy*gmz + & +rix*gz*cix+gmz*ripx*rix+gz*riy*ciy+gx*gmy-riz*ripy*gmy + & -riz*gx*cix) + & -sd21*(gcr_x*(-ripx*riz-gy)+gcr_y*(-ripy*riz+gx) + & +gcr_z*(ripy*riy+ripx*rix)) + & -sd22*(-gmx*ciy+gmy*cix) +cc********************************************************************** + apmx(i)=(ciy*ripz-ripy*ciz)*d23 + & -(ciy*gmz-ciz*gmy)*d24 + apmy(i)=(ciz*ripx-ripz*cix)*d23 + & -(ciz*gmx-cix*gmz)*d24 + apmz(i)=(cix*ripy-ripx*ciy)*d23 + & -(cix*gmy-ciy*gmx)*d24 + endif + + if(i.ge.3) then + if(dgm3.gt.0.0D0.and.dgmm3.gt.0.0D0.and.dri3.gt.0.0D0 + & .and.d_gmcrim3.gt.0.0D0) then + d30=1.0D0/(dgm*dgmm) + d31=gmmgm/(dgm3*dgmm) + d32=gmmgm/(dgm*dgmm3) + d33=1.0D0/(dgmm*dri) + d34=gmmr/(dgmm3*dri) + d35=gmmr/(dgmm*dri3) + sd30=1.0D0/(d_gmcrim*dgmm) + sd31=gmcrim__gmm/(d_gmcrim3*dgmm) + sd32=gmcrim__gmm/(d_gmcrim*dgmm3) + else + d30=0.0D0 + d31=0.0D0 + d32=0.0D0 + d33=0.0D0 + d34=0.0D0 + d35=0.0D0 + sd30=0.0D0 + sd31=0.0D0 + sd32=0.0D0 + endif + +c write(*,*) 'inside angvectors4' + +cc********************************************************************** + atmmx(i)=(ciy*gmmz-ciz*gmmy-rimmy*gmz+rimmz*gmy)*d30 + & -(ciy*gmz-ciz*gmy)*d31 + & -(gmmy*rimmz-gmmz*rimmy)*d32 + atmmy(i)=(ciz*gmmx-cix*gmmz-rimmz*gmx+rimmx*gmz)*d30 + & -(ciz*gmx-cix*gmz)*d31 + & -(gmmz*rimmx-gmmx*rimmz)*d32 + atmmz(i)=(cix*gmmy-ciy*gmmx-rimmx*gmy+rimmy*gmx)*d30 + & -(cix*gmy-ciy*gmx)*d31 + & -(gmmx*rimmy-gmmy*rimmx)*d32 +cc********************************************************************** + astmmx(i)=sd30*(-gmmx*ciz*rimz-gmx*rimy*rimmy + & +gmz*gmmy+rimx*ciy*gmmy+rimx*gmz*rimmz + & +rimmy*gmy*rimx+gmmz*ciz*rimx-gmmz*gmy + & -ciy*rimy*gmmx-rimz*gmx*rimmz) + & -sd31*(gmcrim_x*(-ciz*rimz-ciy*rimy) + & +gmcrim_y*(ciy*rimx+gmz)+gmcrim_z*(ciz*rimx-gmy)) + & -sd32*(gmmy*rimmz-rimmy*gmmz) + + astmmy(i)=sd30*(-rimmz*gmy*rimz+ciz*rimy*gmmz + & +gmx*gmmz+gmx*rimy*rimmx-rimx*cix*gmmy + & -rimmx*gmy*rimx+cix*rimy*gmmx-gmz*gmmx + & +gmz*rimy*rimmz-rimz*ciz*gmmy) + & -sd31*(gmcrim_x*(cix*rimy-gmz) + & +gmcrim_y*(-cix*rimx-ciz*rimz)+gmcrim_z*(ciz*rimy+gmx)) + & -sd32*(-gmmx*rimmz+rimmx*gmmz) + + astmmz(i)=sd30*(rimmy*gmy*rimz+gmmx*cix*rimz + & +gmmx*gmy-ciy*rimy*gmmz-rimx*gmz*rimmx + & -gmmz*cix*rimx-gmz*rimy*rimmy-gmx*gmmy + & +rimz*ciy*gmmy+rimz*gmx*rimmx) + & -sd31*(gmcrim_x*(cix*rimz+gmy) + & +gmcrim_y*(ciy*rimz-gmx)+gmcrim_z*(-ciy*rimy-cix*rimx)) + & -sd32*(gmmx*rimmy-rimmx*gmmy) +c********************************************************************** + apmmx(i)=(riy*rimmz-riz*rimmy-gmmx)*d33 + & -(gmmy*rimmz-gmmz*rimmy)*d34 + & +rix*d35 + apmmy(i)=(riz*rimmx-rix*rimmz-gmmy)*d33 + & -(gmmz*rimmx-gmmx*rimmz)*d34 + & +riy*d35 + apmmz(i)=(rix*rimmy-riy*rimmx-gmmz)*d33 + & -(gmmx*rimmy-gmmy*rimmx)*d34 + & +riz*d35 + endif + + if(i.ge.4) then + if(dg30.gt.0.0D0.and.dgmm3.gt.0.0D0 + & .and.drim3.gt.0.0D0 + & .and.d_gmmcrimm3.gt.0.0D0) then + d40=1.0D0/(dg30*dgmm) + d41=g3gmm/(dg30*dgmm3) + d42=1.0D0/(dg30*drim) + d43=g3rim_/(dg30*drim3) + sd40=1.0D0/(dg30*d_gmmcrimm) + sd41=gmmcrimm__gmmm/(d_gmmcrimm3*dg30) + else + d40=0.0D0 + d41=0.0D0 + d42=0.0D0 + d43=0.0D0 + sd40=0.0D0 + sd41=0.0D0 + endif + atm3x(i)=(g3y*rimmz-g3z*rimmy)*d40 + & -(gmmy*rimmz-gmmz*rimmy)*d41 + atm3y(i)=(g3z*rimmx-g3x*rimmz)*d40 + & -(gmmz*rimmx-gmmx*rimmz)*d41 + atm3z(i)=(g3x*rimmy-g3y*rimmx)*d40 + & -(gmmx*rimmy-gmmy*rimmx)*d41 +cc********************************************************************** + astm3x(i)=sd40*(g3x*rimmz**2-rimmx*rimmy*g3y + & -g3z*rimmz*rimmx+rimmy**2*g3x) + & -sd41*(gmmcrimm_x*(rimmz**2+rimmy**2) + & -gmmcrimm_y*rimmy*rimmx-gmmcrimm_z*rimmz*rimmx) + + astm3y(i)=sd40*(-rimmz*rimmy*g3z+rimmx**2*g3y + & -rimmx*rimmy*g3x+rimmz**2*g3y) + & -sd41*(-gmmcrimm_x*rimmx*rimmy + & +gmmcrimm_y*(rimmx**2+rimmz**2)-gmmcrimm_z*rimmz*rimmy) + +c & +gmmcrimm_y*(rimmx**2+rimmz**2)-gmmcrimm_z*rimmz*rimmx) + + astm3z(i)=sd40*(-g3x*rimmx*rimmz+rimmy**2*g3z + & +g3z*rimmx**2-rimmz*rimmy*g3y) + & -sd41*(-gmmcrimm_x*rimmx*rimmz-gmmcrimm_y*rimmy*rimmz + & +gmmcrimm_z*(rimmy**2+rimmx**2)) +c********************************************************************** + apm3x(i)=g3x*d42-rimx*d43 + apm3y(i)=g3y*d42-rimy*d43 + apm3z(i)=g3z*d42-rimz*d43 + endif + enddo +c******************************************************************************* + +c write(*,*) 'inside angvectors5' + +c do i=inb-2,inb + do i=1,0 + rimx=bx(i)-bx(i-1) + rimy=by(i)-by(i-1) + rimz=bz(i)-bz(i-1) + rimmx=bx(i-1)-bx(i-2) + rimmy=by(i-1)-by(i-2) + rimmz=bz(i-1)-bz(i-2) + rim3x=bx(i-2)-bx(i-3) + rim3y=by(i-2)-by(i-3) + rim3z=bz(i-2)-bz(i-3) + gmmx=rimmy*rimz-rimmz*rimy + gmmy=rimmz*rimx-rimmx*rimz + gmmz=rimmx*rimy-rimmy*rimx + g3x=rim3y*rimmz-rim3z*rimmy + g3y=rim3z*rimmx-rim3x*rimmz + g3z=rim3x*rimmy-rim3y*rimmx + + dg30=sqrt(g3x**2+g3y**2+g3z**2) + g3gmm=g3x*gmmx+g3y*gmmy+g3z*gmmz + dgmm=sqrt(gmmx**2+gmmy**2+gmmz**2) + dgmm3=dgmm**3 + drim=dis(i-1,i) + drimm=dis(i-2,i-1) + drim3=drim**3 + g3rim_=g3x*rimx+g3y*rimy+g3z*rimz +cc********************************************************************** + gmmcrimm_x=gmmy*rimmz-gmmz*rimmy + gmmcrimm_y=gmmz*rimmx-gmmx*rimmz + gmmcrimm_z=gmmx*rimmy-gmmy*rimmx + d_gmmcrimm=sqrt(gmmcrimm_x**2+gmmcrimm_y**2+gmmcrimm_z**2) + d_gmmcrimm3=d_gmmcrimm**3 + gmmcrimm__gmmm=g3x*gmmy*rimmz+gmmx*rimmy*g3z+rimmx*gmmz*g3y + & -g3z*gmmy*rimmx-gmmz*rimmy*g3x-rimmz*gmmx*g3y + + if(dg30.gt.0.0D0.and.dgmm3.gt.0.0D0 + & .and.drim3.gt.0.0D0 + & .and.d_gmmcrimm3.gt.0.0D0) then + d40=1.0D0/(dg30*dgmm) + d41=g3gmm/(dg30*dgmm3) + d42=1.0D0/(dg30*drim) + d43=g3rim_/(dg30*drim3) + sd40=1.0D0/(dg30*d_gmmcrimm) + sd41=gmmcrimm__gmmm/(d_gmmcrimm3*dg30) + else + d40=0.0D0 + d41=0.0D0 + d42=0.0D0 + d43=0.0D0 + sd40=0.0D0 + sd41=0.0D0 + endif + atm3x(i)=(g3y*rimmz-g3z*rimmy)*d40 + & -(gmmy*rimmz-gmmz*rimmy)*d41 + atm3y(i)=(g3z*rimmx-g3x*rimmz)*d40 + & -(gmmz*rimmx-gmmx*rimmz)*d41 + atm3z(i)=(g3x*rimmy-g3y*rimmx)*d40 + & -(gmmx*rimmy-gmmy*rimmx)*d41 +cc********************************************************************** + astm3x(i)=sd40*(g3x*rimmz**2-rimmx*rimmy*g3y + & -g3z*rimmz*rimmx+rimmy**2*g3x) + & -sd41*(gmmcrimm_x*(rimmz**2+rimmy**2) + & -gmmcrimm_y*rimmy*rimmx-gmmcrimm_z*rimmz*rimmx) + + astm3y(i)=sd40*(-rimmz*rimmy*g3z+rimmx**2*g3y + & -rimmx*rimmy*g3x+rimmz**2*g3y) + & -sd41*(-gmmcrimm_x*rimmx*rimmy + & +gmmcrimm_y*(rimmx**2+rimmz**2)-gmmcrimm_z*rimmz*rimmx) + + astm3z(i)=sd40*(-g3x*rimmx*rimmz+rimmy**2*g3z + & +g3z*rimmx**2-rimmz*rimmy*g3y) + & -sd41*(-gmmcrimm_x*rimmx*rimmz-gmmcrimm_y*rimmy*rimmz + & +gmmcrimm_z*(rimmy**2+rimmx**2)) +cc********************************************************************** + apm3x(i)=g3x*d42-rimx*d43 + apm3y(i)=g3y*d42-rimy*d43 + apm3z(i)=g3z*d42-rimz*d43 + + if(i.le.inb-1) then + ip=i+1 + rix=bx(ip)-bx(i) + riy=by(ip)-by(i) + riz=bz(ip)-bz(i) + cix=bx(ip)-bx(i-1) + ciy=by(ip)-by(i-1) + ciz=bz(ip)-bz(i-1) + gmx=rimy*riz-rimz*riy + gmy=rimz*rix-rimx*riz + gmz=rimx*riy-rimy*rix + dgm=sqrt(gmx**2+gmy**2+gmz**2) + dgm3=dgm**3 + dri=dis(i,i+1) + dri3=dri**3 + gmmgm=gmmx*gmx+gmmy*gmy+gmmz+gmz + gmmr=gmmx*rix+gmmy*riy+gmmz*riz + gmcrim_x=gmy*rimz-gmz*rimy + gmcrim_y=gmz*rimx-gmx*rimz + gmcrim_z=gmx*rimy-gmy*rimx + d_gmcrim=sqrt(gmcrim_x**2+gmcrim_y**2+gmcrim_z**2) + d_gmcrim3=d_gmcrim**3 + gmcrim__gmm=gmmx*gmy*rimz+gmx*rimy*gmmz+rimx*gmz*gmmy + & -gmmz*gmy*rimx-gmz*rimy*gmmx-rimz*gmx*gmmy + + if(dgm3.gt.0.0D0.and. + & dgmm3.gt.0.0D0.and.dri3.gt.0.0D0 + & .and.d_gmcrim3.gt.0.0D0) then + d30=1.0D0/(dgm*dgmm) + d31=gmmgm/(dgm3*dgmm) + d32=gmmgm/(dgm*dgmm3) + d33=1.0D0/(dgmm*dri) + d34=gmmr/(dgmm3*dri) + d35=gmmr/(dgmm*dri3) + sd30=1.0D0/(d_gmcrim*dgmm) + sd31=gmcrim__gmm/(d_gmcrim3*dgmm) + sd32=gmcrim__gmm/(d_gmcrim*dgmm3) + + else + d30=0.0D0 + d31=0.0D0 + d32=0.0D0 + d33=0.0D0 + d34=0.0D0 + d35=0.0D0 + sd30=0.0D0 + sd31=0.0D0 + sd32=0.0D0 + endif +cc********************************************************************** + atmmx(i)=(ciy*gmmz-ciz*gmmy-rimmy*gmz+rimmz*gmy)*d30 + & -(ciy*gmz-ciz*gmy)*d31 + & -(gmmy*rimmz-gmmz*rimmy)*d32 + atmmy(i)=(ciz*gmmx-cix*gmmz-rimmz*gmx+rimmx*gmz)*d30 + & -(ciz*gmx-cix*gmz)*d31 + & -(gmmz*rimmx-gmmx*rimmz)*d32 + atmmz(i)=(cix*gmmy-ciy*gmmx-rimmx*gmy+rimmy*gmx)*d30 + & -(cix*gmy-ciy*gmx)*d31 + & -(gmmx*rimmy-gmmy*rimmx)*d32 +cc********************************************************************** + astmmx(i)=sd30*(-gmmx*ciz*rimz-gmx*rimy*rimmy + & +gmz*gmmy+rimx*ciy*gmmy+rimx*gmz*rimmz + & +rimmy*gmy*rimx+gmmz*ciz*rimx-gmmz*gmy + & -ciy*rimy*gmmx-rimz*gmx*rimmz) + & -sd31*(gmcrim_x*(-ciz*rimz-ciy*rimy) + & +gmcrim_y*(ciy*rimx+gmz)+gmcrim_z*(ciz*rimx-gmy)) + & -sd32*(gmmy*rimmz-rimmy*gmmz) + + astmmy(i)=sd30*(-rimmz*gmy*rimz+ciz*rimy*gmmz + & +gmx*gmmz+gmx*rimy*rimmx-rimx*cix*gmmy + & -rimmx*gmy*rimx+cix*rimy*gmmx-gmz*gmmx + & +gmz*rimy*rimmz-rimz*ciz*gmmy) + & -sd31*(gmcrim_x*(cix*rimy-gmz) + & +gmcrim_y*(-cix*rimx-ciz*rimz)+gmcrim_z*(ciz*rimy+gmx)) + & -sd32*(-gmmx*rimmz+rimmx*gmmz) + + astmmz(i)=sd30*(rimmy*gmy*rimz+gmmx*cix*rimz + & +gmmx*gmy-ciy*rimy*gmmz-rimx*gmz*rimmx + & -gmmz*cix*rimx-gmz*rimy*rimmy-gmx*gmmy + & +rimz*ciy*gmmy+rimz*gmx*rimmx) + & -sd31*(gmcrim_x*(cix*rimz+gmy) + & +gmcrim_y*(ciy*rimz-gmx)+gmcrim_z*(-ciy*rimy-cix*rimx)) + & -sd32*(gmmx*rimmy-rimmx*gmmy) +cc********************************************************************** + apmmx(i)=(riy*rimmz-riz*rimmy-gmmx)*d33 + & -(gmmy*rimmz-gmmz*rimmy)*d34 + & +rix*d35 + apmmy(i)=(riz*rimmx-rix*rimmz-gmmy)*d33 + & -(gmmz*rimmx-gmmx*rimmz)*d34 + & +riy*d35 + apmmz(i)=(rix*rimmy-riy*rimmx-gmmz)*d33 + & -(gmmx*rimmy-gmmy*rimmx)*d34 + & +riz*d35 + endif + +c write(*,*) 'inside angvectors6' + + if(i.eq.inb-2) then + ipp=i+2 + ripx=bx(ipp)-bx(ip) + ripy=by(ipp)-by(ip) + ripz=bz(ipp)-bz(ip) + cipx=bx(ipp)-bx(i) + cipy=by(ipp)-by(i) + cipz=bz(ipp)-bz(i) + gx=riy*ripz-riz*ripy + gy=riz*ripx-rix*ripz + gz=rix*ripy-riy*ripx + ggm=gmx*gx+gmy*gy+gmz*gz + gmrp=gmx*ripx+gmy*ripy+gmz*ripz + dg=sqrt(gx**2+gy**2+gz**2) + dg3=dg**3 + drip=dis(i+1,i+2) + gcr_x=gy*riz-gz*riy + gcr_y=gz*rix-gx*riz + gcr_z=gx*riy-gy*rix + d_gcr=sqrt(gcr_x**2+gcr_y**2+gcr_z**2) + d_gcr3=d_gcr**3 + gcr__gm=gmx*gy*riz+gx*riy*gmz+rix*gz*gmy + & -gmz*gy*rix-gz*riy*gmx-riz*gx*gmy + if(dgm3.gt.0.0D0.and. + & dg3.gt.0.0D0.and.drip.gt.0.0D0.and.d_gcr3.gt.0.0D0 + & ) then + d20=1.0D0/(dg*dgm) + d21=ggm/(dgm3*dg) + d22=ggm/(dgm*dg3) + d23=1.0D0/(dgm*drip) + d24=gmrp/(dgm3*drip) + sd20=1.0D0/(d_gcr*dgm) + sd21=gcr__gm/(d_gcr3*dgm) + sd22=gcr__gm/(d_gcr*dgm3) + else + d20=0.0D0 + d21=0.0D0 + d22=0.0D0 + d23=0.0D0 + d24=0.0D0 + sd20=0.0D0 + sd21=0.0D0 + sd22=0.0D0 + endif + atmx(i)=(ciy*gz-ciz*gy-ripy*gmz+ripz*gmy)*d20 + & -(ciy*gmz-ciz*gmy)*d21 + & +(ripy*gz-ripz*gy)*d22 + atmy(i)=(ciz*gx-cix*gz-ripz*gmx+ripx*gmz)*d20 + & -(ciz*gmx-cix*gmz)*d21 + & +(ripz*gx-ripx*gz)*d22 + atmz(i)=(cix*gy-ciy*gx-ripx*gmy+ripy*gmx)*d20 + & -(cix*gmy-ciy*gmx)*d21 + & +(ripx*gy-ripy*gx)*d22 +cc********************************************************************** + astmx(i)=sd20*(gmx*ripz*riz+gx*riy*ciy-gz*gmy + & -rix*ripy*gmy-rix*gz*ciz-ciy*gy*rix-gmz*ripz*rix + & +gmz*gy+ripy*riy*gmx+riz*gx*ciz) + & -sd21*(gcr_x*(ripz*riz+ripy*riy)+gcr_y*(-ripy*rix-gz) + & +gcr_z*(-ripz*rix+gy)) + & -sd22*(-gmy*ciz+gmz*ciy) + + astmy(i)=sd20*(ciz*gy*riz-ripz*riy*gmz-gx*gmz-gx*riy*cix + & +rix*ripx*gmy+cix*gy*rix-ripx*riy*gmx+gz*gmx-gz*riy*ciz + & +riz*ripz*gmy) + & -sd21*(gcr_x*(-ripx*riy+gz)+gcr_y*(ripx*rix+ripz*riz) + & -gcr_z*(ripz*riy+gx)) + & -sd22*(gmx*ciz-gmz*cix) + + astmz(i)=sd20*(-ciy*gy*riz-gmx*ripx*riz-gmx*gy+ripy*riy*gmz + & +rix*gz*cix+gmz*ripx*rix+gz*riy*ciy+gx*gmy-riz*ripy*gmy + & -riz*gx*cix) + & -sd21*(gcr_x*(-ripx*riz-gy)+gcr_y*(-ripy*riz+gx) + & +gcr_z*(ripy*riy+ripx*rix)) + & -sd22*(-gmx*ciy+gmy*cix) +cc********************************************************************** +c + apmx(i)=(ciy*ripz-ripy*ciz)*d23 + & -(ciy*gmz-ciz*gmy)*d24 + apmy(i)=(ciz*ripx-ripz*cix)*d23 + & -(ciz*gmx-cix*gmz)*d24 + apmz(i)=(cix*ripy-ripx*ciy)*d23 + & -(cix*gmy-ciy*gmx)*d24 + + endif + enddo + + return + end +c END of angvectors +c------------------------------------------------------------------------------- +C--------------------------------------------------------------------------------- + subroutine sheetforce(nca,wshet) + implicit none +C JYLEE +c this should be matched with dfa.fcm + integer maxca + parameter(maxca=800) +cc********************************************************************** + integer nca + integer i,k + integer inb,nmax,iselect + +c real*8 dfaexp(15001) + + real*8 vbeta,vbetp,vbetm + real*8 shefx(maxca,12) + real*8 shefy(maxca,12),shefz(maxca,12) + real*8 shetfx(maxca),shetfy(maxca),shetfz(maxca) + real*8 vbet(maxca,maxca) + real*8 wshet(maxca,maxca) + real*8 bx(maxca),by(maxca),bz(maxca) + + common /sheca/ bx,by,bz + common /phys1/ inb,nmax,iselect + common /shef/ shefx,shefy,shefz + common /shee/ vbeta,vbet,vbetp,vbetm + common /shetf/ shetfx,shetfy,shetfz + + inb=nca + do i=1,inb + shetfx(i)=0.0D0 + shetfy(i)=0.0D0 + shetfz(i)=0.0D0 + enddo + + do k=1,12 + do i=1,inb + shefx(i,k)=0.0D0 + shefy(i,k)=0.0D0 + shefz(i,k)=0.0D0 + enddo + enddo + + call sheetene(nca,wshet) + call sheetforce1 + + 887 format(a,1x,i6,3x,f12.8) + 888 format(a,1x,i4,1x,i4,3x,f12.8) + 889 format(a,1x,i4,3x,f12.8) + !write(2,*) 'coord : ' + do i=1,inb + !write(2,887) 'bx:',i,bx(i) + !write(2,887) 'by:',i,by(i) + !write(2,887) 'bz:',i,bz(i) + enddo + !write(2,*) 'After sheetforce1' + do i=1,inb + do k=1,12 + !write(2,888) 'shefx :',i,k,shefx(i,k) + !write(2,888) 'shefy :',i,k,shefy(i,k) + !write(2,888) 'shefz :',i,k,shefz(i,k) + enddo + enddo + + call sheetforce5 + + !write(2,*) 'After sheetforce5' + do i=1,inb + do k=1,12 + !write(2,888) 'shefx :',i,k,shefx(i,k) + !write(2,888) 'shefy :',i,k,shefy(i,k) + !write(2,888) 'shefz :',i,k,shefz(i,k) + enddo + enddo + + call sheetforce6 + + !write(2,*) 'After sheetforce6' + do i=1,inb + do k=1,12 + !write(2,888) 'shefx :',i,k,shefx(i,k) + !write(2,888) 'shefy :',i,k,shefy(i,k) + !write(2,888) 'shefz :',i,k,shefz(i,k) + enddo + enddo + + call sheetforce11 + + !write(2,*) 'After sheetforce11' + do i=1,inb + do k=1,12 + !write(2,888) 'shefx :',i,k,shefx(i,k) + !write(2,888) 'shefy :',i,k,shefy(i,k) + !write(2,888) 'shefz :',i,k,shefz(i,k) + enddo + enddo + + call sheetforce12 + + !write(2,*) 'After sheetforce12' + do i=1,inb + do k=1,12 + !write(2,888) 'shefx :',i,k,shefx(i,k) + !write(2,888) 'shefy :',i,k,shefy(i,k) + !write(2,888) 'shefz :',i,k,shefz(i,k) + enddo + enddo + + do i=1,inb + do k=1,12 + shetfx(i)=shetfx(i)+shefx(i,k) + shetfy(i)=shetfy(i)+shefy(i,k) + shetfz(i)=shetfz(i)+shefz(i,k) + enddo + enddo + !write(2,*) 'Beta Finished' + do i=1,inb + !write(2,889) 'shetfx : ',i,shetfx(i) + !write(2,889) 'shetfy : ',i,shetfy(i) + !write(2,889) 'shetfz : ',i,shetfz(i) + enddo + + return + end +C end sheetforce +c------------------------------------------------------------------------------- + subroutine sheetene(nca,wshet) + implicit none + integer maxca + parameter(maxca=800) +cc****************************************************************************** + +c real*8 dfaexp(15001) + real*8 dtmp1, dtmp2, dtmp3 + + real*8 vbet(maxca,maxca) + real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) + real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) + real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) + real*8 pin1(maxca,maxca),pin2(maxca,maxca) + real*8 pin3(maxca,maxca),pin4(maxca,maxca) + real*8 pina1(maxca,maxca),pina2(maxca,maxca) + real*8 pina3(maxca,maxca),pina4(maxca,maxca) + real*8 cph(maxca),cth(maxca) + real*8 rx(maxca,maxca) + real*8 ry(maxca,maxca),rz(maxca,maxca) + real*8 bx(maxca),by(maxca),bz(maxca) + real*8 dis(maxca,maxca) + real*8 ulcos(maxca) +cc********************************************************************** + real*8 astx(maxca),asty(maxca),astz(maxca) + real*8 astmx(maxca),astmy(maxca),astmz(maxca) + real*8 astmmx(maxca),astmmy(maxca),astmmz(maxca) + real*8 astm3x(maxca),astm3y(maxca),astm3z(maxca) + real*8 sth(maxca) + real*8 wshet(maxca,maxca) + real*8 dp45, dm45, w_beta + real*8 c00, s00, ulnex, dnex, dca,dlhb,ulhb,dshe,dldhb,uldhb + integer nca + integer i,ip,ipp,j,jp,jpp,inb,nmax,iselect + real*8 uum, uup + real*8 vbeta,vbetp,vbetm,y,y1,y2,yshe1,yshe2,yy1,yy2 + + common /sheca/ bx,by,bz + common /phys1/ inb,nmax,iselect + common /kyori2/ dis + common /difvec/ rx,ry,rz + common /coscos/ cph,cth + common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, + & c00,s00,ulnex,dnex + common /sheconst/ dp45,dm45,w_beta + common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 + common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 + common /shee/ vbeta,vbet,vbetp,vbetm + common /ulang/ ulcos +cc********************************************************************** + common /angvt2/ astx,asty,astz,astmx,astmy,astmz,astmmx,astmmy, + & astmmz,astm3x,astm3y,astm3z + common /sinsin/ sth + + real*8 r_pair_mat(maxca,maxca) +ci integer istrand(maxca,maxca) +ci integer istrand_p(maxca,maxca),istrand_m(maxca,maxca) +ci common /shetest/ istrand,istrand_p,istrand_m + common /beta_p/ r_pair_mat +C------------------------------------------------------------------------------- + r_pair_mat = 0.0d0 + do i=1,inb + do j=1,inb + r_pair_mat(i,j)=wshet(i,j) +c write(*,*) 'r_pair_mat :',i,j,r_pair_mat(i,j) + enddo + enddo +c stop +c + vbeta=0.0D0 + vbetp=0.0D0 + vbetm=0.0D0 + + do i=1,inb-7 + do j=i+4,inb-3 + ip=i+1 + ipp=i+2 + jp=j+1 + jpp=j+2 +cc********************************************************************** + y1=(cth(i)*c00+sth(i)*s00-1.0D0)**2 + & +(cth(j)*c00+sth(j)*s00-1.0D0)**2 + y1=-0.5d0*y1/dca + y2=(ulcos(i)-ulnex)**2+(ulcos(ip)-ulnex)**2 + & +(ulcos(j)-ulnex)**2+(ulcos(jp)-ulnex)**2 + y2=-0.5d0*y2/dnex + +cdebug y2=0 + + y=y1+y2 + +ci if(y.ge.-4) then +ci istrand(i,j)=1 +ci else +ci istrand(i,j)=0 +ci endif + +ci if(istrand(i,j).eq.1) then + + yy1=-0.5d0*(dis(ip,jp)-ulhb)**2/dlhb + yy2=-0.5d0*(dis(ipp,jpp)-ulhb)**2/dlhb + + + pin1(i,j)=(rx(ip,jp)*rx(ip,ipp)+ry(ip,jp)*ry(ip,ipp) + $ +rz(ip,jp)*rz(ip,ipp))/(dis(ip,jp)*dis(ip,ipp)) + pin2(i,j)=(rx(ip,jp)*rx(jp,jpp)+ry(ip,jp)*ry(jp,jpp) + $ +rz(ip,jp)*rz(jp,jpp))/(dis(ip,jp)*dis(jp,jpp)) + pin3(i,j)=(rx(ipp,jpp)*rx(ip,ipp)+ry(ipp,jpp)*ry(ip,ipp) + $ +rz(ipp,jpp)*rz(ip,ipp))/(dis(ipp,jpp)*dis(ip,ipp)) + pin4(i,j)=(rx(ipp,jpp)*rx(jp,jpp)+ry(ipp,jpp)*ry(jp,jpp) + $ +rz(ipp,jpp)*rz(jp,jpp))/(dis(ipp,jpp)*dis(jp,jpp)) + + yshe1=pin1(i,j)**2+pin2(i,j)**2 + yshe1=-0.5d0*yshe1/dshe + yshe2=pin3(i,j)**2+pin4(i,j)**2 + yshe2=-0.5d0*yshe2/dshe + +ci if((yshe1+yshe2).ge.-4) then +ci istrand_p(i,j)=1 +ci else +ci istrand_p(i,j)=0 +ci endif + + +C write(*,*) 'rx(i,j):',i,j,rx(i,j),bx(j),bx(i) +C write(*,*) 'ry(i,j):',i,j,ry(i,j),by(j),by(i) +C write(*,*) 'rz(i,j):',i,j,rz(i,j),bz(j),bz(i) +C write(*,*) 'dis(i,j):',i,j,dis(i,j) +C write(*,*) 'rx(ip,jp):',ip,jp,bx(ip),bx(jp),rx(ip,jp) +C write(*,*) 'rx(ip,ipp):',ip,ipp,bx(ip),bx(ipp),rx(ip,ipp) +C write(*,*) 'pin1:',pin1(i,j) +C write(*,*) 'pin2:',pin2(i,j) +C write(*,*) 'pin3:',pin3(i,j) +C write(*,*) 'pin4:',pin4(i,j) + +C write(*,*) 'y:',y +C write(*,*) 'yy1:',yy1 +C write(*,*) 'yy2:',yy2 +C write(*,*) 'yshe1:',yshe1 +C write(*,*) 'yshe2:',yshe2 +c + +ci if (istrand_p(i,j).eq.1) then + +cd yy1=0 +cd yy2=0 +cd yshe1=0 +cd yshe2=0 + dtmp1 = y+yy1+yshe1 + dtmp2 = y+yy2+yshe2 + dtmp3 = y+yy1+yy2+yshe1+yshe2 + +C write(*,*)'1', i,j,dtmp1,dtmp2,dtmp3 +C write(*,*)'2', y,yy1,yy2 +C write(*,*)'3', yshe1,yshe2 + +cc if (dtmp3.le.-35.0d0) then +c vbetap(i,j)=-dp45*exp(dtmp3) +cc vbetap(i,j)=0.0d0 +cc else +c vbetap(i,j)=-dp45*dfaexp(idint(-dtmp3*1000)+1) + vbetap(i,j)=-dp45*exp(dtmp3) +cc end if + +cc if (dtmp1.le.-35.0d0) then +c vbetap1(i,j)=-r_pair_mat(i+1,j+1)*exp(dtmp1) +cc vbetap1(i,j)=0.0d0 +cc else +c vbetap1(i,j)=-r_pair_mat(i+1,j+1) +c $ *dfaexp(idint(-dtmp1*1000)+1) + vbetap1(i,j)=-r_pair_mat(i+1,j+1)*exp(dtmp1) +cc end if + +cc if (dtmp2.le.-35.0d0) then +C vbetap2(i,j)=-r_pair_mat(i+2,j+2)*exp(dtmp2) +cc vbetap2(i,j)=0.0d0 +cc else +c vbetap2(i,j)=-r_pair_mat(i+2,j+2) +c $ *dfaexp(idint(-dtmp2*1000)+1) + vbetap2(i,j)=-r_pair_mat(i+2,j+2)*exp(dtmp2) +cc end if + +c vbetap(i,j)=-dp45*exp(y+yy1+yy2+yshe1+yshe2) +c vbetap1(i,j)=-r_pair_mat(i+1,j+1)*exp(y+yy1+yshe1) +c vbetap2(i,j)=-r_pair_mat(i+2,j+2)*exp(y+yy2+yshe2) + +! write(*,*) 'r_pair_mat>',i+1,j+1,r_pair_mat(i+1,j+1) +! write(*,*) 'r_pair_mat>',i+2,j+2,r_pair_mat(i+2,j+2) + +ci elseif (istrand_p(i,j).eq.0)then +ci vbetap(i,j)=0 +ci vbetap1(i,j)=0 +ci vbetap2(i,j)=0 +ci endif + + yy1=-0.5d0*(dis(ip,jpp)-ulhb)**2/dlhb + yy2=-0.5d0*(dis(ipp,jp)-ulhb)**2/dlhb + + pina1(i,j)=(rx(ip,jpp)*rx(ip,ipp)+ry(ip,jpp)*ry(ip,ipp) + $ +rz(ip,jpp)*rz(ip,ipp))/(dis(ip,jpp)*dis(ip,ipp)) + pina2(i,j)=(rx(ip,jpp)*rx(jp,jpp)+ry(ip,jpp)*ry(jp,jpp) + $ +rz(ip,jpp)*rz(jp,jpp))/(dis(ip,jpp)*dis(jp,jpp)) + pina3(i,j)=(rx(jp,ipp)*rx(ip,ipp)+ry(jp,ipp)*ry(ip,ipp) + $ +rz(jp,ipp)*rz(ip,ipp))/(dis(jp,ipp)*dis(ip,ipp)) + pina4(i,j)=(rx(jp,ipp)*rx(jp,jpp)+ry(jp,ipp)*ry(jp,jpp) + $ +rz(jp,ipp)*rz(jp,jpp))/(dis(jp,ipp)*dis(jp,jpp)) + + yshe1=pina1(i,j)**2+pina2(i,j)**2 + yshe1=-0.5d0*yshe1/dshe + yshe2=pina3(i,j)**2+pina4(i,j)**2 + yshe2=-0.5d0*yshe2/dshe + +ci if((yshe1+yshe2).ge.-4) then +ci istrand_m(i,j)=1 +ci else +ci istrand_m(i,j)=0 +ci endif + + +C write(*,*) 'pina1:',pina1(i,j) +C write(*,*) 'pina2:',pina2(i,j) +C write(*,*) 'pina3:',pina3(i,j) +C write(*,*) 'pina4:',pina4(i,j) +C write(*,*) 'yshe1:',yshe1 +C write(*,*) 'yshe2:',yshe2 +C write(*,*) 'dshe:',dshe + +ci if (istrand_m(i,j).eq.1) then + +cd yy1=0 +cd yy2=0 +cd yshe1=0 +cd yshe2=0 + + dtmp3=y+yy1+yy2+yshe1+yshe2 + dtmp1=y+yy1+yshe1 + dtmp2=y+yy2+yshe2 + +cc if(dtmp3 .le. -35.0d0) then +c vbetam(i,j)=-dm45*exp(dtmp3) +cc vbetam(i,j)=0.0d0 +cc else +c vbetam(i,j)=-dm45*dfaexp(idint(-dtmp3*1000)+1) + vbetam(i,j)=-dm45*exp(dtmp3) +cc end if + +cc if(dtmp1 .le. -35.0d0) then +c vbetam1(i,j)=-r_pair_mat(i+1,j+2)*exp(dtmp1) +cc vbetam1(i,j)=0.0d0 +cc else +c vbetam1(i,j)=-r_pair_mat(i+1,j+2) +c $ *dfaexp(idint(-dtmp1*1000)+1) + vbetam1(i,j)=-r_pair_mat(i+1,j+2)*exp(dtmp1) +cc end if + +cc if(dtmp2.le.-35.0d0) then +c vbetam2(i,j)=-r_pair_mat(i+2,j+1)*exp(dtmp2) +cc vbetam2(i,j)=0.0d0 +cc else +c vbetam2(i,j)=-r_pair_mat(i+2,j+1) +c $ *dfaexp(idint(-dtmp2*1000)+1) + vbetam2(i,j)=-r_pair_mat(i+2,j+1)*exp(dtmp2) +cc end if + +ci elseif (istrand_m(i,j).eq.0)then +ci vbetam(i,j)=0 +ci vbetam1(i,j)=0 +ci vbetam2(i,j)=0 +ci endif + + +c vbetam(i,j)=-dm45*exp(y+yy1+yy2+yshe1+yshe2) +c vbetam1(i,j)=-r_pair_mat(i+1,j+2)*exp(y+yy1+yshe1) +c vbetam2(i,j)=-r_pair_mat(i+2,j+1)*exp(y+yy2+yshe2) + +! write(*,*) 'r_pair_mat>',i+1,j+2,r_pair_mat(i+1,j+2) +! write(*,*) 'r_pair_mat>',i+2,j+1,r_pair_mat(i+2,j+1) + + uup = vbetap(i,j)+vbetap1(i,j)+vbetap2(i,j) + uum = vbetam(i,j)+vbetam1(i,j)+vbetam2(i,j) + +c write(*,*) 'uup,uum:', uup, uum + +c uup=vbetap1(i,j)+vbetap2(i,j) +c uum=vbetam1(i,j)+vbetam2(i,j) + + vbet(i,j)=uup+uum + vbetp=vbetp+uup + vbetm=vbetm+uum + vbeta=vbeta+vbet(i,j) + +ci elseif(istrand(i,j).eq.0)then +ci vbet(i,j)=0 +ci endif + +c write(*,*) 'uup,uum:',uup,uum +c write(*,*) 'vbetap(i,j):',vbetap(i,j) +c write(*,*) 'vbetap1(i,j):',vbetap1(i,j) +c write(*,*) 'vbetap2(i,j):',vbetap2(i,j) +c write(*,*) 'vbetam(i,j):',vbetam(i,j) +c write(*,*) 'vbetam1(i,j):',vbetam1(i,j) +c write(*,*) 'vbetam2(i,j):',vbetam2(i,j) +c write(*,*) 'uup:',uup +c write(*,*) 'uum:',uum +c write(*,*) 'vbetp:',vbetp +c write(*,*) 'vbetm:',vbetm +c write(*,*) 'vbet(i,j):',vbet(i,j) +c stop + + enddo + enddo + +! do i=1,inb-7 +! do j=i+4,inb-3 +! write(*,*) 'I,J:', i,j +! write(*,*) 'vbetap(i,j):',vbetap(i,j) +! write(*,*) 'vbetap1(i,j):',vbetap1(i,j) +! write(*,*) 'vbetap2(i,j):',vbetap2(i,j) +! write(*,*) 'vbetam(i,j):',vbetam(i,j) +! write(*,*) 'vbetam1(i,j):',vbetam1(i,j) +! write(*,*) 'vbetam2(i,j):',vbetam2(i,j) +! write(*,*) 'vbet(i,j):',vbet(i,j) +! enddo +! enddo + + return + end +c------------------------------------------------------------------------------- + subroutine sheetforce1 + implicit none + integer maxca + parameter(maxca=800) +cc********************************************************************** + real*8 vbet(maxca,maxca) + real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) + real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) + real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) + real*8 cph(maxca),cth(maxca) + real*8 rx(maxca,maxca) + real*8 ry(maxca,maxca),rz(maxca,maxca) + real*8 bx(maxca),by(maxca),bz(maxca) + real*8 dis(maxca,maxca) + real*8 shefx(maxca,12) + real*8 shefy(maxca,12),shefz(maxca,12) + real*8 atx(maxca),aty(maxca),atz(maxca) + real*8 atmx(maxca),atmy(maxca),atmz(maxca) + real*8 atmmx(maxca),atmmy(maxca),atmmz(maxca) + real*8 atm3x(maxca),atm3y(maxca),atm3z(maxca) + real*8 apx(maxca),apy(maxca),apz(maxca) + real*8 apmx(maxca),apmy(maxca),apmz(maxca) + real*8 apmmx(maxca),apmmy(maxca),apmmz(maxca) + real*8 apm3x(maxca),apm3y(maxca),apm3z(maxca) + real*8 ulcos(maxca) + real*8 astx(maxca),asty(maxca),astz(maxca) + real*8 astmx(maxca),astmy(maxca),astmz(maxca) + real*8 astmmx(maxca),astmmy(maxca),astmmz(maxca) + real*8 astm3x(maxca),astm3y(maxca),astm3z(maxca) + real*8 sth(maxca) + real*8 w_beta,dp45, dm45 + real*8 vbeta, vbetp, vbetm + real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, + $ c00,s00,ulnex,dnex + integer inb,nmax,iselect + + common /phys1/ inb,nmax,iselect + common /kyori2/ dis + common /difvec/ rx,ry,rz + common /coscos/ cph,cth + common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, + $ c00,s00,ulnex,dnex + common /sheconst/ dp45,dm45,w_beta + common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 + common /angvt/ atx,aty,atz,atmx,atmy,atmz,atmmx,atmmy, + $ atmmz,atm3x,atm3y,atm3z + common /angvp/ apx,apy,apz,apmx,apmy,apmz,apmmx,apmmy, + $ apmmz,apm3x,apm3y,apm3z + common /shef/ shefx,shefy,shefz + common /shee/ vbeta,vbet,vbetp,vbetm + common /ulang/ ulcos +c c********************************************************************** + common /angvt2/ astx,asty,astz,astmx,astmy,astmz,astmmx,astmmy, + $ astmmz,astm3x,astm3y,astm3z + common /sinsin/ sth +C-------------------------------------------------------------------------------- +c local variables + integer i,j,im3,imm,im,ip,ipp,jm,jmm,jm3,jp,jpp + real*8 c1,v1,cc1,dmm,dmm__,fx,fy,fz,c2,v2,dmm1 + real*8 c3,v3,cc2,cc3,dmm3,dmm3__,c4,v4,c7,v7,cc7,c8,v8,cc8 + real*8 c9,v9,cc9,dmm9,dmm9__,c10,v10,dmm2,dmm1__,dmm2_1,dmm2_2 + real*8 dmm7,dmm8,dmm7__,dmm8_1,dmm8_2 +C-------------------------------------------------------------------------------- + do i=4,inb-4 + im3=i-3 + imm=i-2 + im=i-1 + c1=(cth(im3)*c00+sth(im3)*s00-1)/dca + v1=0.0D0 + do j=i+1,inb-3 + v1=v1+vbet(im3,j) + enddo + cc1=(ulcos(imm)-ulnex)/dnex + dmm=cc1/(dis(imm,im)*dis(im,i)) + dmm__=cc1*ulcos(imm)/dis(im,i)**2 + fx=rx(imm,im)*dmm-rx(im,i)*dmm__ + fy=ry(imm,im)*dmm-ry(im,i)*dmm__ + fz=rz(imm,im)*dmm-rz(im,i)*dmm__ +cd fx=0 +cd fy=0 +cd fz=0 + fx=fx+(atm3x(i)*c00+astm3x(i)*s00)*c1 + fy=fy+(atm3y(i)*c00+astm3y(i)*s00)*c1 + fz=fz+(atm3z(i)*c00+astm3z(i)*s00)*c1 + shefx(i,1)=fx*v1 + shefy(i,1)=fy*v1 + shefz(i,1)=fz*v1 + enddo + + do i=3,inb-5 + imm=i-2 + im=i-1 + ip=i+1 + c2=(cth(imm)*c00+sth(imm)*s00-1)/dca + v2=0.0D0 + do j=i+2,inb-3 + v2=v2+vbet(imm,j) + enddo + cc1=(ulcos(imm)-ulnex)/dnex + cc2=(ulcos(im)-ulnex)/dnex + dmm1=cc1/(dis(imm,im)*dis(im,i)) + dmm2=cc2/(dis(im,i)*dis(i,ip)) + dmm1__=cc1*ulcos(imm)/dis(im,i)**2 + dmm2_1=cc2*ulcos(im)/dis(im,i)**2 + dmm2_2=cc2*ulcos(im)/dis(i,ip)**2 +cc********************************************************************** + fx=rx(imm,im)*dmm1-rx(im,i)*dmm1__+rx(i,ip)*dmm2-rx(im,i)*dmm2 + $ -rx(im,i)*dmm2_1+rx(i,ip)*dmm2_2 + fy=ry(imm,im)*dmm1-ry(im,i)*dmm1__+ry(i,ip)*dmm2-ry(im,i)*dmm2 + $ -ry(im,i)*dmm2_1+ry(i,ip)*dmm2_2 + fz=rz(imm,im)*dmm1-rz(im,i)*dmm1__+rz(i,ip)*dmm2-rz(im,i)*dmm2 + $ -rz(im,i)*dmm2_1+rz(i,ip)*dmm2_2 +cd fx=0 +cd fy=0 +cd fz=0 + fx=fx+(atmmx(i)*c00+astmmx(i)*s00)*c2 + fy=fy+(atmmy(i)*c00+astmmy(i)*s00)*c2 + fz=fz+(atmmz(i)*c00+astmmz(i)*s00)*c2 + shefx(i,2)=fx*v2 + shefy(i,2)=fy*v2 + shefz(i,2)=fz*v2 + enddo + do i=2,inb-6 + im=i-1 + ip=i+1 + ipp=i+2 + c3=(cth(im)*c00+sth(im)*s00-1)/dca + v3=0.0D0 + do j=i+3,inb-3 + v3=v3+vbet(im,j) + enddo + cc2=(ulcos(im)-ulnex)/dnex + cc3=(ulcos(i)-ulnex)/dnex + dmm2=cc2/(dis(im,i)*dis(i,ip)) + dmm3=cc3/(dis(i,ip)*dis(ip,ipp)) + dmm2_1=cc2*ulcos(im)/dis(im,i)**2 + dmm2_2=cc2*ulcos(im)/dis(i,ip)**2 + dmm3__=cc3*ulcos(i)/dis(i,ip)**2 + fx=-rx(ip,ipp)*dmm3+rx(i,ip)*dmm2-rx(im,i)*dmm2 + $ -rx(im,i)*dmm2_1+rx(i,ip)*dmm2_2+rx(i,ip)*dmm3__ + fy=-ry(ip,ipp)*dmm3+ry(i,ip)*dmm2-ry(im,i)*dmm2 + $ -ry(im,i)*dmm2_1+ry(i,ip)*dmm2_2+ry(i,ip)*dmm3__ + fz=-rz(ip,ipp)*dmm3+rz(i,ip)*dmm2-rz(im,i)*dmm2 + $ -rz(im,i)*dmm2_1+rz(i,ip)*dmm2_2+rz(i,ip)*dmm3__ +cd fx=0 +cd fy=0 +cd fz=0 + fx=fx+(atmx(i)*c00+astmx(i)*s00)*c3 + fy=fy+(atmy(i)*c00+astmy(i)*s00)*c3 + fz=fz+(atmz(i)*c00+astmz(i)*s00)*c3 + shefx(i,3)=fx*v3 + shefy(i,3)=fy*v3 + shefz(i,3)=fz*v3 + enddo + do i=1,inb-7 + ip=i+1 + ipp=i+2 + c4=(cth(i)*c00+sth(i)*s00-1)/dca + v4=0.0D0 + do j=i+4,inb-3 + v4=v4+vbet(i,j) + enddo + cc3=(ulcos(i)-ulnex)/dnex + dmm3=cc3/(dis(i,ip)*dis(ip,ipp)) + dmm3__=cc3*ulcos(i)/dis(i,ip)**2 + fx=-rx(ip,ipp)*dmm3+rx(i,ip)*dmm3__ + fy=-ry(ip,ipp)*dmm3+ry(i,ip)*dmm3__ + fz=-rz(ip,ipp)*dmm3+rz(i,ip)*dmm3__ +cd fx=0 +cd fy=0 +cd fz=0 + fx=fx+(atx(i)*c00+astx(i)*s00)*c4 + fy=fy+(aty(i)*c00+asty(i)*s00)*c4 + fz=fz+(atz(i)*c00+astz(i)*s00)*c4 + shefx(i,4)=fx*v4 + shefy(i,4)=fy*v4 + shefz(i,4)=fz*v4 + enddo + do j=8,inb + jm3=j-3 + jmm=j-2 + jm=j-1 + c7=(cth(jm3)*c00+sth(jm3)*s00-1)/dca + v7=0.0D0 + do i=1,j-7 + v7=v7+vbet(i,jm3) + enddo + cc7=(ulcos(jmm)-ulnex)/dnex + dmm=cc7/(dis(jmm,jm)*dis(jm,j)) + dmm__=cc7*ulcos(jmm)/dis(jm,j)**2 + fx=rx(jmm,jm)*dmm-rx(jm,j)*dmm__ + fy=ry(jmm,jm)*dmm-ry(jm,j)*dmm__ + fz=rz(jmm,jm)*dmm-rz(jm,j)*dmm__ +cd fx=0 +cd fy=0 +cd fz=0 + fx=fx+(atm3x(j)*c00+astm3x(j)*s00)*c7 + fy=fy+(atm3y(j)*c00+astm3y(j)*s00)*c7 + fz=fz+(atm3z(j)*c00+astm3z(j)*s00)*c7 + shefx(j,7)=fx*v7 + shefy(j,7)=fy*v7 + shefz(j,7)=fz*v7 + enddo + do j=7,inb-1 + jm=j-1 + jmm=j-2 + jp=j+1 + c8=(cth(jmm)*c00+sth(jmm)*s00-1)/dca + v8=0.0D0 + do i=1,j-6 + v8=v8+vbet(i,jmm) + enddo + cc7=(ulcos(jmm)-ulnex)/dnex + cc8=(ulcos(jm)-ulnex)/dnex + dmm7=cc7/(dis(jmm,jm)*dis(jm,j)) + dmm8=cc8/(dis(jm,j)*dis(j,jp)) + dmm7__=cc7*ulcos(jmm)/dis(jm,j)**2 + dmm8_1=cc8*ulcos(jm)/dis(jm,j)**2 + dmm8_2=cc8*ulcos(jm)/dis(j,jp)**2 + fx=rx(jmm,jm)*dmm7+rx(j,jp)*dmm8-rx(jm,j)*dmm8 + $ -rx(jm,j)*dmm7__-rx(jm,j)*dmm8_1+rx(j,jp)*dmm8_2 + fy=ry(jmm,jm)*dmm7+ry(j,jp)*dmm8-ry(jm,j)*dmm8 + $ -ry(jm,j)*dmm7__-ry(jm,j)*dmm8_1+ry(j,jp)*dmm8_2 + fz=rz(jmm,jm)*dmm7+rz(j,jp)*dmm8-rz(jm,j)*dmm8 + $ -rz(jm,j)*dmm7__-rz(jm,j)*dmm8_1+rz(j,jp)*dmm8_2 +cd fx=0 +cd fy=0 +cd fz=0 + fx=fx+(atmmx(j)*c00+astmmx(j)*s00)*c8 + fy=fy+(atmmy(j)*c00+astmmy(j)*s00)*c8 + fz=fz+(atmmz(j)*c00+astmmz(j)*s00)*c8 + shefx(j,8)=fx*v8 + shefy(j,8)=fy*v8 + shefz(j,8)=fz*v8 + enddo + + do j=6,inb-2 + jm=j-1 + jp=j+1 + jpp=j+2 + c9=(cth(jm)*c00+sth(jm)*s00-1)/dca + v9=0.0D0 + do i=1,j-5 + v9=v9+vbet(i,jm) + enddo + cc8=(ulcos(jm)-ulnex)/dnex + cc9=(ulcos(j)-ulnex)/dnex + dmm8=cc8/(dis(jm,j)*dis(j,jp)) + dmm9=cc9/(dis(j,jp)*dis(jp,jpp)) + dmm8_1=cc8*ulcos(jm)/dis(jm,j)**2 + dmm8_2=cc8*ulcos(jm)/dis(j,jp)**2 + dmm9__=cc9*ulcos(j)/dis(j,jp)**2 + fx=-rx(jp,jpp)*dmm9+rx(j,jp)*dmm8-rx(jm,j)*dmm8 + $ -rx(jm,j)*dmm8_1+rx(j,jp)*dmm8_2+rx(j,jp)*dmm9__ + fy=-ry(jp,jpp)*dmm9+ry(j,jp)*dmm8-ry(jm,j)*dmm8 + $ -ry(jm,j)*dmm8_1+ry(j,jp)*dmm8_2+ry(j,jp)*dmm9__ + fz=-rz(jp,jpp)*dmm9+rz(j,jp)*dmm8-rz(jm,j)*dmm8 + $ -rz(jm,j)*dmm8_1+rz(j,jp)*dmm8_2+rz(j,jp)*dmm9__ +cd fx=0 +cd fy=0 +cd fz=0 + fx=fx+(atmx(j)*c00+astmx(j)*s00)*c9 + fy=fy+(atmy(j)*c00+astmy(j)*s00)*c9 + fz=fz+(atmz(j)*c00+astmz(j)*s00)*c9 + shefx(j,9)=fx*v9 + shefy(j,9)=fy*v9 + shefz(j,9)=fz*v9 + enddo + + do j=5,inb-3 + jp=j+1 + jpp=j+2 + c10=(cth(j)*c00+sth(j)*s00-1)/dca + v10=0.0D0 + do i=1,j-4 + v10=v10+vbet(i,j) + enddo + cc9=(ulcos(j)-ulnex)/dnex + dmm9=cc9/(dis(j,jp)*dis(jp,jpp)) + dmm9__=cc9*ulcos(j)/dis(j,jp)**2 + fx=-rx(jp,jpp)*dmm9+rx(j,jp)*dmm9__ + fy=-ry(jp,jpp)*dmm9+ry(j,jp)*dmm9__ + fz=-rz(jp,jpp)*dmm9+rz(j,jp)*dmm9__ +cd fx=0 +cd fy=0 +cd fz=0 + fx=fx+(atx(j)*c00+astx(j)*s00)*c10 + fy=fy+(aty(j)*c00+asty(j)*s00)*c10 + fz=fz+(atz(j)*c00+astz(j)*s00)*c10 + shefx(j,10)=fx*v10 + shefy(j,10)=fy*v10 + shefz(j,10)=fz*v10 + enddo + + return + end +c---------------------------------------------------------------------------- + subroutine sheetforce5 + implicit none + integer maxca + parameter(maxca=800) +cc********************************************************************** + real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) + real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) + real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) + real*8 pin1(maxca,maxca),pin2(maxca,maxca) + real*8 pin3(maxca,maxca),pin4(maxca,maxca) + real*8 pina1(maxca,maxca),pina2(maxca,maxca) + real*8 pina3(maxca,maxca),pina4(maxca,maxca) + real*8 rx(maxca,maxca) + real*8 ry(maxca,maxca),rz(maxca,maxca) + real*8 bx(maxca),by(maxca),bz(maxca) + real*8 dis(maxca,maxca) + real*8 shefx(maxca,12),shefy(maxca,12) + real*8 shefz(maxca,12) + real*8 dp45,dm45,w_beta + real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, + $ c00,s00,ulnex,dnex + integer inb,nmax,iselect +cc********************************************************************** + common /phys1/ inb,nmax,iselect + common /kyori2/ dis + common /difvec/ rx,ry,rz + common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, + $ c00,s00,ulnex,dnex + common /sheconst/ dp45,dm45,w_beta + common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 + common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 + common /shef/ shefx,shefy,shefz +ci integer istrand(maxca,maxca) +ci integer istrand_p(maxca,maxca),istrand_m(maxca,maxca) +ci common /shetest/ istrand,istrand_p,istrand_m +c******************************************************************************** +c local variables + integer i,imm,im,jp,jpp,j + real*8 yy1,y1x,y1y,y1z,y11x,y11y,y11z,yy33,yyy3,yy3,y3x,y3y,y3z + real*8 yy44,yyy4a,yyy4b,yy4,y4x,y4y,y4z,yy55,yyy5,yy5,y5x,y5y,y5z + real*8 sx,sy,sz,sx1,sy1,sz1,sx2,sy2,sz2,y6x,y6y,y6z + real*8 y66x,y66y,y66z,yy6,yyy4,yyy5a,yyy5b + real*8 yy88,yyy8a,yyy8b,yy8,y8x,y8y,y8z,yy99,yyy9,yy9,y9x,y9y,y9z + real*8 yy1010,yyy10,yy10,y10x,y10y,y10z,yyy8,yyy9a,yyy9b +c******************************************************************************** + do i=3,inb-5 + imm=i-2 + im=i-1 + do j=i+2,inb-3 + jp=j+1 + jpp=j+2 + +ci if(istrand(imm,j).eq.1 +ci & .and.(istrand_p(imm,j)+istrand_m(imm,j)).ge.1) then + + + yy1=-(dis(i,jpp)-ulhb)/dlhb + y1x=rx(jpp,i)/dis(i,jpp) + y1y=ry(jpp,i)/dis(i,jpp) + y1z=rz(jpp,i)/dis(i,jpp) + y11x=yy1*y1x + y11y=yy1*y1y + y11z=yy1*y1z + + yy33=1.0D0/(dis(im,jp)*dis(im,i)) + yyy3=pin1(imm,j)/(dis(im,i)**2) + yy3=-pin1(imm,j)/dshe + y3x=(yy33*rx(im,jp)-yyy3*rx(im,i))*yy3 + y3y=(yy33*ry(im,jp)-yyy3*ry(im,i))*yy3 + y3z=(yy33*rz(im,jp)-yyy3*rz(im,i))*yy3 + + yy44=1.0D0/(dis(i,jpp)*dis(im,i)) + yyy4a=pin3(imm,j)/(dis(i,jpp)**2) + yyy4b=pin3(imm,j)/(dis(im,i)**2) + yy4=-pin3(imm,j)/dshe + y4x=(yy44*(rx(i,jpp)-rx(im,i))+yyy4a*rx(i,jpp) + $ -yyy4b*rx(im,i))*yy4 + y4y=(yy44*(ry(i,jpp)-ry(im,i))+yyy4a*ry(i,jpp) + $ -yyy4b*ry(im,i))*yy4 + y4z=(yy44*(rz(i,jpp)-rz(im,i))+yyy4a*rz(i,jpp) + $ -yyy4b*rz(im,i))*yy4 + + + yy55=1.0D0/(dis(i,jpp)*dis(jp,jpp)) + yyy5=pin4(imm,j)/(dis(i,jpp)**2) + yy5=-pin4(imm,j)/dshe + y5x=(-yy55*rx(jp,jpp)+yyy5*rx(i,jpp))*yy5 + y5y=(-yy55*ry(jp,jpp)+yyy5*ry(i,jpp))*yy5 + y5z=(-yy55*rz(jp,jpp)+yyy5*rz(i,jpp))*yy5 + + sx=y11x+y3x+y4x+y5x + sy=y11y+y3y+y4y+y5y + sz=y11z+y3z+y4z+y5z + + sx1=y3x + sy1=y3y + sz1=y3z + sx2=y11x+y4x+y5x + sy2=y11y+y4y+y5y + sz2=y11z+y4z+y5z + + shefx(i,5)=shefx(i,5)-sx*vbetap(imm,j) + $ -sx1*vbetap1(imm,j)-sx2*vbetap2(imm,j) + shefy(i,5)=shefy(i,5)-sy*vbetap(imm,j) + $ -sy1*vbetap1(imm,j)-sy2*vbetap2(imm,j) + shefz(i,5)=shefz(i,5)-sz*vbetap(imm,j) + $ -sz1*vbetap1(imm,j)-sz2*vbetap2(imm,j) + +! shefx(i,5)=shefx(i,5) +! $ -sx1*vbetap1(imm,j)-sx2*vbetap2(imm,j) +! shefy(i,5)=shefy(i,5) +! $ -sy1*vbetap1(imm,j)-sy2*vbetap2(imm,j) +! shefz(i,5)=shefz(i,5) +! $ -sz1*vbetap1(imm,j)-sz2*vbetap2(imm,j) + + yy6=-(dis(i,jp)-uldhb)/dldhb + y6x=rx(jp,i)/dis(i,jp) + y6y=ry(jp,i)/dis(i,jp) + y6z=rz(jp,i)/dis(i,jp) + y66x=yy6*y6x + y66y=yy6*y6y + y66z=yy6*y6z + + yy88=1.0D0/(dis(im,jpp)*dis(im,i)) + yyy8=pina1(imm,j)/(dis(im,i)**2) + yy8=-pina1(imm,j)/dshe + y8x=(yy88*rx(im,jpp)-yyy8*rx(im,i))*yy8 + y8y=(yy88*ry(im,jpp)-yyy8*ry(im,i))*yy8 + y8z=(yy88*rz(im,jpp)-yyy8*rz(im,i))*yy8 + + yy99=1.0D0/(dis(jp,i)*dis(im,i)) + yyy9a=pina3(imm,j)/(dis(jp,i)**2) + yyy9b=pina3(imm,j)/(dis(im,i)**2) + yy9=-pina3(imm,j)/dshe + y9x=(yy99*(rx(jp,i)+rx(im,i))-yyy9a*rx(jp,i) + $ -yyy9b*rx(im,i))*yy9 + y9y=(yy99*(ry(jp,i)+ry(im,i))-yyy9a*ry(jp,i) + $ -yyy9b*ry(im,i))*yy9 + y9z=(yy99*(rz(jp,i)+rz(im,i))-yyy9a*rz(jp,i) + $ -yyy9b*rz(im,i))*yy9 + + yy1010=1.0D0/(dis(jp,i)*dis(jp,jpp)) + yyy10=pina4(imm,j)/(dis(jp,i)**2) + yy10=-pina4(imm,j)/dshe + y10x=(yy1010*rx(jp,jpp)-yyy10*rx(jp,i))*yy10 + y10y=(yy1010*ry(jp,jpp)-yyy10*ry(jp,i))*yy10 + y10z=(yy1010*rz(jp,jpp)-yyy10*rz(jp,i))*yy10 + + sx=y66x+y8x+y9x+y10x + sy=y66y+y8y+y9y+y10y + sz=y66z+y8z+y9z+y10z + + sx1=y8x + sy1=y8y + sz1=y8z + sx2=y66x+y9x+y10x + sy2=y66y+y9y+y10y + sz2=y66z+y9z+y10z + + shefx(i,5)=shefx(i,5)-sx*vbetam(imm,j) + $ -sx1*vbetam1(imm,j)-sx2*vbetam2(imm,j) + shefy(i,5)=shefy(i,5)-sy*vbetam(imm,j) + $ -sy1*vbetam1(imm,j)-sy2*vbetam2(imm,j) + shefz(i,5)=shefz(i,5)-sz*vbetam(imm,j) + $ -sz1*vbetam1(imm,j)-sz2*vbetam2(imm,j) + +! shefx(i,5)=shefx(i,5) +! $ -sx1*vbetam1(imm,j)-sx2*vbetam2(imm,j) +! shefy(i,5)=shefy(i,5) +! $ -sy1*vbetam1(imm,j)-sy2*vbetam2(imm,j) +! shefz(i,5)=shefz(i,5) +! $ -sz1*vbetam1(imm,j)-sz2*vbetam2(imm,j) + +ci endif + + enddo + enddo + + return + end +c--------------------------------------------------------------------------c + subroutine sheetforce6 + implicit none + integer maxca + parameter(maxca=800) +cc********************************************************************** + real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) + real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) + real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) + real*8 pin1(maxca,maxca),pin2(maxca,maxca) + real*8 pin3(maxca,maxca),pin4(maxca,maxca) + real*8 pina1(maxca,maxca),pina2(maxca,maxca) + real*8 pina3(maxca,maxca),pina4(maxca,maxca) + real*8 rx(maxca,maxca) + real*8 ry(maxca,maxca),rz(maxca,maxca) + real*8 bx(maxca),by(maxca),bz(maxca) + real*8 dis(maxca,maxca) + real*8 shefx(maxca,12),shefy(maxca,12) + real*8 shefz(maxca,12) + real*8 dp45,dm45,w_beta + real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, + $ c00,s00,ulnex,dnex + integer inb,nmax,iselect +cc********************************************************************** + common /phys1/ inb,nmax,iselect + common /kyori2/ dis + common /difvec/ rx,ry,rz + common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, + $ c00,s00,ulnex,dnex + common /sheconst/ dp45,dm45,w_beta + common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 + common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 + common /shef/ shefx,shefy,shefz +ci integer istrand(maxca,maxca) +ci integer istrand_p(maxca,maxca),istrand_m(maxca,maxca) +ci common /shetest/ istrand,istrand_p,istrand_m +cc********************************************************************** +C local variables + integer i,imm,im,jp,jpp,j,ip + real*8 yy1,y1x,y1y,y1z,y11x,y11y,y11z,yy33,yyy3,yy3,y3x,y3y,y3z + real*8 yy44,yyy4a,yyy4b,yy4,y4x,y4y,y4z,yy55,yyy5,yy5,y5x,y5y,y5z + real*8 sx,sy,sz,sx1,sy1,sz1,sx2,sy2,sz2,y6x,y6y,y6z,y66x,y66y + real*8 yy88,yyy8a,yyy8b,yy8,y8x,y8y,y8z,yy99,yyy9,yy9,y9x,y9y,y9z + real*8 yy1010,yyy10,yy10,y10x,y10y,y10z,yyy8,yyy9a,yyy9b,yyy4 + real*8 yyy3a,yyy3b,y66z,yy6,yyy5a,yyy5b +C******************************************************************************** + do i=2,inb-6 + ip=i+1 + im=i-1 + do j=i+3,inb-3 + jp=j+1 + jpp=j+2 + +ci if(istrand(im,j).eq.1 +ci & .and.(istrand_p(im,j)+istrand_m(im,j)).ge.1) then + + + yy1=-(dis(i,jp)-ulhb)/dlhb + y1x=rx(jp,i)/dis(i,jp) + y1y=ry(jp,i)/dis(i,jp) + y1z=rz(jp,i)/dis(i,jp) + y11x=yy1*y1x + y11y=yy1*y1y + y11z=yy1*y1z + + yy33=1.0D0/(dis(i,jp)*dis(i,ip)) + yyy3a=pin1(im,j)/(dis(i,jp)**2) + yyy3b=pin1(im,j)/(dis(i,ip)**2) + yy3=-pin1(im,j)/dshe + y3x=(-yy33*(rx(i,ip)+rx(i,jp))+yyy3a*rx(i,jp) + $ +yyy3b*rx(i,ip))*yy3 + y3y=(-yy33*(ry(i,ip)+ry(i,jp))+yyy3a*ry(i,jp) + $ +yyy3b*ry(i,ip))*yy3 + y3z=(-yy33*(rz(i,ip)+rz(i,jp))+yyy3a*rz(i,jp) + $ +yyy3b*rz(i,ip))*yy3 + + yy44=1.0D0/(dis(i,jp)*dis(jp,jpp)) + yyy4=pin2(im,j)/(dis(i,jp)**2) + yy4=-pin2(im,j)/dshe + y4x=(-yy44*rx(jp,jpp)+yyy4*rx(i,jp))*yy4 + y4y=(-yy44*ry(jp,jpp)+yyy4*ry(i,jp))*yy4 + y4z=(-yy44*rz(jp,jpp)+yyy4*rz(i,jp))*yy4 + + yy55=1.0D0/(dis(ip,jpp)*dis(i,ip)) + yyy5=pin3(im,j)/(dis(i,ip)**2) + yy5=-pin3(im,j)/dshe + y5x=(-yy55*rx(ip,jpp)+yyy5*rx(i,ip))*yy5 + y5y=(-yy55*ry(ip,jpp)+yyy5*ry(i,ip))*yy5 + y5z=(-yy55*rz(ip,jpp)+yyy5*rz(i,ip))*yy5 + + sx=y11x+y3x+y4x+y5x + sy=y11y+y3y+y4y+y5y + sz=y11z+y3z+y4z+y5z + + sx1=y11x+y3x+y4x + sy1=y11y+y3y+y4y + sz1=y11z+y3z+y4z + sx2=y5x + sy2=y5y + sz2=y5z + + shefx(i,6)=shefx(i,6)-sx*vbetap(im,j) + $ -sx1*vbetap1(im,j)-sx2*vbetap2(im,j) + shefy(i,6)=shefy(i,6)-sy*vbetap(im,j) + $ -sy1*vbetap1(im,j)-sy2*vbetap2(im,j) + shefz(i,6)=shefz(i,6)-sz*vbetap(im,j) + $ -sz1*vbetap1(im,j)-sz2*vbetap2(im,j) +! shefx(i,6)=shefx(i,6) +! $ -sx1*vbetap1(im,j)-sx2*vbetap2(im,j) +! shefy(i,6)=shefy(i,6) +! $ -sy1*vbetap1(im,j)-sy2*vbetap2(im,j) +! shefz(i,6)=shefz(i,6) +! $ -sz1*vbetap1(im,j)-sz2*vbetap2(im,j) + + yy6=-(dis(jpp,i)-uldhb)/dldhb + y6x=rx(jpp,i)/dis(jpp,i) + y6y=ry(jpp,i)/dis(jpp,i) + y6z=rz(jpp,i)/dis(jpp,i) + y66x=yy6*y6x + y66y=yy6*y6y + y66z=yy6*y6z + + yy88=1.0D0/(dis(i,jpp)*dis(i,ip)) + yyy8a=pina1(im,j)/(dis(i,jpp)**2) + yyy8b=pina1(im,j)/(dis(i,ip)**2) + yy8=-pina1(im,j)/dshe + y8x=(-yy88*(rx(i,jpp)+rx(i,ip))+yyy8a*rx(i,jpp) + $ +yyy8b*rx(i,ip))*yy8 + y8y=(-yy88*(ry(i,jpp)+ry(i,ip))+yyy8a*ry(i,jpp) + $ +yyy8b*ry(i,ip))*yy8 + y8z=(-yy88*(rz(i,jpp)+rz(i,ip))+yyy8a*rz(i,jpp) + $ +yyy8b*rz(i,ip))*yy8 + + yy99=1.0D0/(dis(i,jpp)*dis(jp,jpp)) + yyy9=pina2(im,j)/(dis(i,jpp)**2) + yy9=-pina2(im,j)/dshe + y9x=(-yy99*rx(jp,jpp)+yyy9*rx(i,jpp))*yy9 + y9y=(-yy99*ry(jp,jpp)+yyy9*ry(i,jpp))*yy9 + y9z=(-yy99*rz(jp,jpp)+yyy9*rz(i,jpp))*yy9 + + yy1010=1.0D0/(dis(jp,ip)*dis(i,ip)) + yyy10=pina3(im,j)/(dis(i,ip)**2) + yy10=-pina3(im,j)/dshe + y10x=(-yy1010*rx(jp,ip)+yyy10*rx(i,ip))*yy10 + y10y=(-yy1010*ry(jp,ip)+yyy10*ry(i,ip))*yy10 + y10z=(-yy1010*rz(jp,ip)+yyy10*rz(i,ip))*yy10 + + sx=y66x+y8x+y9x+y10x + sy=y66y+y8y+y9y+y10y + sz=y66z+y8z+y9z+y10z + + sx1=y66x+y8x+y9x + sy1=y66y+y8y+y9y + sz1=y66z+y8z+y9z + sx2=y10x + sy2=y10y + sz2=y10z + + shefx(i,6)=shefx(i,6)-sx*vbetam(im,j) + $ -sx1*vbetam1(im,j)-sx2*vbetam2(im,j) + shefy(i,6)=shefy(i,6)-sy*vbetam(im,j) + $ -sy1*vbetam1(im,j)-sy2*vbetam2(im,j) + shefz(i,6)=shefz(i,6)-sz*vbetam(im,j) + $ -sz1*vbetam1(im,j)-sz2*vbetam2(im,j) + +! shefx(i,6)=shefx(i,6) +! $ -sx1*vbetam1(im,j)-sx2*vbetam2(im,j) +! shefy(i,6)=shefy(i,6) +! $ -sy1*vbetam1(im,j)-sy2*vbetam2(im,j) +! shefz(i,6)=shefz(i,6) +! $ -sz1*vbetam1(im,j)-sz2*vbetam2(im,j) + +ci endif + + enddo + enddo + + return + end +c----------------------------------------------------------------------- + subroutine sheetforce11 + implicit none + integer maxca + parameter(maxca=800) +cc********************************************************************** + real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) + real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) + real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) + real*8 pin1(maxca,maxca),pin2(maxca,maxca) + real*8 pin3(maxca,maxca),pin4(maxca,maxca) + real*8 pina1(maxca,maxca),pina2(maxca,maxca) + real*8 pina3(maxca,maxca),pina4(maxca,maxca) + real*8 rx(maxca,maxca) + real*8 ry(maxca,maxca),rz(maxca,maxca) + real*8 bx(maxca),by(maxca),bz(maxca) + real*8 dis(maxca,maxca) + real*8 shefx(maxca,12),shefy(maxca,12) + real*8 shefz(maxca,12) + real*8 dp45,dm45,w_beta + real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, + $ c00,s00,ulnex,dnex + integer inb,nmax,iselect +cc********************************************************************** + common /phys1/ inb,nmax,iselect + common /kyori2/ dis + common /difvec/ rx,ry,rz + common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, + $ c00,s00,ulnex,dnex + common /sheconst/ dp45,dm45,w_beta + common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 + common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 + common /shef/ shefx,shefy,shefz +ci integer istrand(maxca,maxca) +ci integer istrand_p(maxca,maxca),istrand_m(maxca,maxca) +ci common /shetest/ istrand,istrand_p,istrand_m +C******************************************************************************** +C local variables + integer j,jm,jmm,ip,i,ipp + real*8 yy1,y1x,y1y,y1z,y11x,y11y,y11z,yy33,yyy3,yy3,y3x,y3y,y3z + real*8 yy44,yyy4a,yyy4b,yy4,y4x,y4y,y4z,yy55,yyy5,yy5,y5x,y5y + real*8 sx,sy,sz,sx1,sy1,sz1,sx2,sy2,sz2,y6x,y6y,y6z,y66x,y66y + real*8 yy88,yyy8a,yyy8b,yy8,y8x,y8y,y8z,yy99,yyy9,yy9,y9x,y9y + real*8 yy1010,yyy10,yy10,y10x,y10y,y10z,yyy4,yyy5a,yyy5b,yy6 + real*8 yyy9a,yyy9b,y5z,y66z,y9z,yyy8 +C******************************************************************************** + + do j=7,inb-1 + jm=j-1 + jmm=j-2 + do i=1,j-6 + ip=i+1 + ipp=i+2 + +ci if(istrand(i,jmm).eq.1 +ci & .and.(istrand_p(i,jmm)+istrand_m(i,jmm)).ge.1) then + + + yy1=-(dis(ipp,j)-ulhb)/dlhb + y1x=rx(ipp,j)/dis(ipp,j) + y1y=ry(ipp,j)/dis(ipp,j) + y1z=rz(ipp,j)/dis(ipp,j) + y11x=yy1*y1x + y11y=yy1*y1y + y11z=yy1*y1z + + yy33=1.0D0/(dis(ip,jm)*dis(jm,j)) + yyy3=pin2(i,jmm)/(dis(jm,j)**2) + yy3=-pin2(i,jmm)/dshe + y3x=(yy33*rx(ip,jm)-yyy3*rx(jm,j))*yy3 + y3y=(yy33*ry(ip,jm)-yyy3*ry(jm,j))*yy3 + y3z=(yy33*rz(ip,jm)-yyy3*rz(jm,j))*yy3 + + yy44=1.0D0/(dis(ipp,j)*dis(ip,ipp)) + yyy4=pin3(i,jmm)/(dis(ipp,j)**2) + yy4=-pin3(i,jmm)/dshe + y4x=(yy44*rx(ip,ipp)-yyy4*rx(ipp,j))*yy4 + y4y=(yy44*ry(ip,ipp)-yyy4*ry(ipp,j))*yy4 + y4z=(yy44*rz(ip,ipp)-yyy4*rz(ipp,j))*yy4 + + yy55=1.0D0/(dis(ipp,j)*dis(jm,j)) + yyy5a=pin4(i,jmm)/(dis(ipp,j)**2) + yyy5b=pin4(i,jmm)/(dis(jm,j)**2) + yy5=-pin4(i,jmm)/dshe + y5x=(yy55*(rx(jm,j)+rx(ipp,j))-yyy5a*rx(ipp,j) + $ -yyy5b*rx(jm,j))*yy5 + y5y=(yy55*(ry(jm,j)+ry(ipp,j))-yyy5a*ry(ipp,j) + $ -yyy5b*ry(jm,j))*yy5 + y5z=(yy55*(rz(jm,j)+rz(ipp,j))-yyy5a*rz(ipp,j) + $ -yyy5b*rz(jm,j))*yy5 + + sx=y11x+y3x+y4x+y5x + sy=y11y+y3y+y4y+y5y + sz=y11z+y3z+y4z+y5z + + sx1=y3x + sy1=y3y + sz1=y3z + sx2=y11x+y4x+y5x + sy2=y11y+y4y+y5y + sz2=y11z+y4z+y5z + + shefx(j,11)=shefx(j,11)-sx*vbetap(i,jmm) + $ -sx1*vbetap1(i,jmm)-sx2*vbetap2(i,jmm) + shefy(j,11)=shefy(j,11)-sy*vbetap(i,jmm) + $ -sy1*vbetap1(i,jmm)-sy2*vbetap2(i,jmm) + shefz(j,11)=shefz(j,11)-sz*vbetap(i,jmm) + $ -sz1*vbetap1(i,jmm)-sz2*vbetap2(i,jmm) + +! shefx(j,11)=shefx(j,11) +! $ -sx1*vbetap1(i,jmm)-sx2*vbetap2(i,jmm) +! shefy(j,11)=shefy(j,11) +! $ -sy1*vbetap1(i,jmm)-sy2*vbetap2(i,jmm) +! shefz(j,11)=shefz(j,11) +! $ -sz1*vbetap1(i,jmm)-sz2*vbetap2(i,jmm) + + yy6=-(dis(ip,j)-uldhb)/dldhb + y6x=rx(ip,j)/dis(ip,j) + y6y=ry(ip,j)/dis(ip,j) + y6z=rz(ip,j)/dis(ip,j) + y66x=yy6*y6x + y66y=yy6*y6y + y66z=yy6*y6z + + yy88=1.0D0/(dis(ip,j)*dis(ip,ipp)) + yyy8=pina1(i,jmm)/(dis(ip,j)**2) + yy8=-pina1(i,jmm)/dshe + y8x=(yy88*rx(ip,ipp)-yyy8*rx(ip,j))*yy8 + y8y=(yy88*ry(ip,ipp)-yyy8*ry(ip,j))*yy8 + y8z=(yy88*rz(ip,ipp)-yyy8*rz(ip,j))*yy8 + + yy99=1.0D0/(dis(ip,j)*dis(jm,j)) + yyy9a=pina2(i,jmm)/(dis(ip,j)**2) + yyy9b=pina2(i,jmm)/(dis(jm,j)**2) + yy9=-pina2(i,jmm)/dshe + y9x=(yy99*(rx(jm,j)+rx(ip,j))-yyy9a*rx(ip,j) + $ -yyy9b*rx(jm,j))*yy9 + y9y=(yy99*(ry(jm,j)+ry(ip,j))-yyy9a*ry(ip,j) + $ -yyy9b*ry(jm,j))*yy9 + y9z=(yy99*(rz(jm,j)+rz(ip,j))-yyy9a*rz(ip,j) + $ -yyy9b*rz(jm,j))*yy9 + + yy1010=1.0D0/(dis(jm,ipp)*dis(jm,j)) + yyy10=pina4(i,jmm)/(dis(jm,j)**2) + yy10=-pina4(i,jmm)/dshe + y10x=(yy1010*rx(jm,ipp)-yyy10*rx(jm,j))*yy10 + y10y=(yy1010*ry(jm,ipp)-yyy10*ry(jm,j))*yy10 + y10z=(yy1010*rz(jm,ipp)-yyy10*rz(jm,j))*yy10 + + sx=y66x+y8x+y9x+y10x + sy=y66y+y8y+y9y+y10y + sz=y66z+y8z+y9z+y10z + + sx1=y66x+y8x+y9x + sy1=y66y+y8y+y9y + sz1=y66z+y8z+y9z + sx2=y10x + sy2=y10y + sz2=y10z + + shefx(j,11)=shefx(j,11)-sx*vbetam(i,jmm) + $ -sx1*vbetam1(i,jmm)-sx2*vbetam2(i,jmm) + shefy(j,11)=shefy(j,11)-sy*vbetam(i,jmm) + $ -sy1*vbetam1(i,jmm)-sy2*vbetam2(i,jmm) + shefz(j,11)=shefz(j,11)-sz*vbetam(i,jmm) + $ -sz1*vbetam1(i,jmm)-sz2*vbetam2(i,jmm) + +! shefx(j,11)=shefx(j,11) +! $ -sx1*vbetam1(i,jmm)-sx2*vbetam2(i,jmm) +! shefy(j,11)=shefy(j,11) +! $ -sy1*vbetam1(i,jmm)-sy2*vbetam2(i,jmm) +! shefz(j,11)=shefz(j,11) +! $ -sz1*vbetam1(i,jmm)-sz2*vbetam2(i,jmm) + +ci endif + + enddo + enddo + + return + end +c----------------------------------------------------------------------- + subroutine sheetforce12 + implicit none + integer maxca + parameter(maxca=800) +cc********************************************************************** + real*8 vbetap(maxca,maxca),vbetam(maxca,maxca) + real*8 vbetap1(maxca,maxca),vbetam1(maxca,maxca) + real*8 vbetap2(maxca,maxca),vbetam2(maxca,maxca) + real*8 pin1(maxca,maxca),pin2(maxca,maxca) + real*8 pin3(maxca,maxca),pin4(maxca,maxca) + real*8 pina1(maxca,maxca),pina2(maxca,maxca) + real*8 pina3(maxca,maxca),pina4(maxca,maxca) + real*8 rx(maxca,maxca) + real*8 ry(maxca,maxca),rz(maxca,maxca) + real*8 bx(maxca),by(maxca),bz(maxca) + real*8 dis(maxca,maxca) + real*8 shefx(maxca,12),shefy(maxca,12) + real*8 shefz(maxca,12) + real*8 dp45,dm45,w_beta + real*8 dca,dlhb,ulhb,dshe,dldhb,uldhb, + $ c00,s00,ulnex,dnex + integer inb,nmax,iselect +cc********************************************************************** + common /phys1/ inb,nmax,iselect + common /kyori2/ dis + common /difvec/ rx,ry,rz + common /sheparm/ dca,dlhb,ulhb,dshe,dldhb,uldhb, + $ c00,s00,ulnex,dnex + common /sheconst/ dp45,dm45,w_beta + common /she/ vbetap,vbetam,vbetap1,vbetap2,vbetam1,vbetam2 + common /shepin/ pin1,pin2,pin3,pin4,pina1,pina2,pina3,pina4 + common /shef/ shefx,shefy,shefz +ci integer istrand(maxca,maxca) +ci integer istrand_p(maxca,maxca),istrand_m(maxca,maxca) +ci common /shetest/ istrand,istrand_p,istrand_m +cc********************************************************************** +C local variables + integer j,jm,jmm,ip,i,ipp,jp + real*8 yy1,y1x,y1y,y1z,y11x,y11y,y11z,yy33,yyy3,yy3,y3x,y3y,y3z + real*8 yy44,yyy4a,yyy4b,yy4,y4x,y4y,y4z,yy55,yyy5,yy5,y5x,y5y,y5z + real*8 sx,sy,sz,sx1,sy1,sz1,sx2,sy2,sz2,y6x,y6y,y6z,y66x,y66y,y66z + real*8 yy88,yyy8a,yyy8b,yy8,y8x,y8y,y8z,yy99,yyy9,yy9,y9x,y9y,y9z + real*8 yy1010,yyy10,yy10,y10x,y10y,y10z,yyy10a,yyy10b,yy6,yyy8 +!c*************************************************************************c + do j=6,inb-2 + jp=j+1 + jm=j-1 + do i=1,j-5 + ip=i+1 + ipp=i+2 + +ci if(istrand(i,jm).eq.1 +ci & .and.(istrand_p(i,jm)+istrand_m(i,jm)).ge.1) then + + + yy1=-(dis(ip,j)-ulhb)/dlhb + y1x=rx(ip,j)/dis(ip,j) + y1y=ry(ip,j)/dis(ip,j) + y1z=rz(ip,j)/dis(ip,j) + y11x=y1x*yy1 + y11y=y1y*yy1 + y11z=y1z*yy1 + + yy33=1.0D0/(dis(ip,j)*dis(ip,ipp)) + yyy3=pin1(i,jm)/(dis(ip,j)**2) + yy3=-pin1(i,jm)/dshe + y3x=(yy33*rx(ip,ipp)-yyy3*rx(ip,j))*yy3 + y3y=(yy33*ry(ip,ipp)-yyy3*ry(ip,j))*yy3 + y3z=(yy33*rz(ip,ipp)-yyy3*rz(ip,j))*yy3 + yy44=1.0D0/(dis(ip,j)*dis(j,jp)) + + yyy4a=pin2(i,jm)/(dis(ip,j)**2) + yyy4b=pin2(i,jm)/(dis(j,jp)**2) + yy4=-pin2(i,jm)/dshe + y4x=(yy44*(rx(j,jp)-rx(ip,j))-yyy4a*rx(ip,j) + $ +yyy4b*rx(j,jp))*yy4 + y4y=(yy44*(ry(j,jp)-ry(ip,j))-yyy4a*ry(ip,j) + $ +yyy4b*ry(j,jp))*yy4 + y4z=(yy44*(rz(j,jp)-rz(ip,j))-yyy4a*rz(ip,j) + $ +yyy4b*rz(j,jp))*yy4 + + yy55=1.0D0/(dis(ipp,jp)*dis(j,jp)) + yyy5=pin4(i,jm)/(dis(j,jp)**2) + yy5=-pin4(i,jm)/dshe + y5x=(-yy55*rx(ipp,jp)+yyy5*rx(j,jp))*yy5 + y5y=(-yy55*ry(ipp,jp)+yyy5*ry(j,jp))*yy5 + y5z=(-yy55*rz(ipp,jp)+yyy5*rz(j,jp))*yy5 + + sx=y11x+y3x+y4x+y5x + sy=y11y+y3y+y4y+y5y + sz=y11z+y3z+y4z+y5z + + sx1=y11x+y3x+y4x + sy1=y11y+y3y+y4y + sz1=y11z+y3z+y4z + sx2=y5x + sy2=y5y + sz2=y5z + + shefx(j,12)=shefx(j,12)-sx*vbetap(i,jm) + $ -sx1*vbetap1(i,jm)-sx2*vbetap2(i,jm) + shefy(j,12)=shefy(j,12)-sy*vbetap(i,jm) + $ -sy1*vbetap1(i,jm)-sy2*vbetap2(i,jm) + shefz(j,12)=shefz(j,12)-sz*vbetap(i,jm) + $ -sz1*vbetap1(i,jm)-sz2*vbetap2(i,jm) + +! shefx(j,12)=shefx(j,12) +! $ -sx1*vbetap1(i,jm)-sx2*vbetap2(i,jm) +! shefy(j,12)=shefy(j,12) +! $ -sy1*vbetap1(i,jm)-sy2*vbetap2(i,jm) +! shefz(j,12)=shefz(j,12) +! $ -sz1*vbetap1(i,jm)-sz2*vbetap2(i,jm) + + yy6=-(dis(ipp,j)-uldhb)/dldhb + y6x=rx(ipp,j)/dis(ipp,j) + y6y=ry(ipp,j)/dis(ipp,j) + y6z=rz(ipp,j)/dis(ipp,j) + y66x=yy6*y6x + y66y=yy6*y6y + y66z=yy6*y6z + + yy88=1.0D0/(dis(ip,jp)*dis(j,jp)) + yyy8=pina2(i,jm)/(dis(j,jp)**2) + yy8=-pina2(i,jm)/dshe + y8x=(-yy88*rx(ip,jp)+yyy8*rx(j,jp))*yy8 + y8y=(-yy88*ry(ip,jp)+yyy8*ry(j,jp))*yy8 + y8z=(-yy88*rz(ip,jp)+yyy8*rz(j,jp))*yy8 + + yy99=1.0D0/(dis(j,ipp)*dis(ip,ipp)) + yyy9=pina3(i,jm)/(dis(j,ipp)**2) + yy9=-pina3(i,jm)/dshe + y9x=(-yy99*rx(ip,ipp)+yyy9*rx(j,ipp))*yy9 + y9y=(-yy99*ry(ip,ipp)+yyy9*ry(j,ipp))*yy9 + y9z=(-yy99*rz(ip,ipp)+yyy9*rz(j,ipp))*yy9 + + yy1010=1.0D0/(dis(j,ipp)*dis(j,jp)) + yyy10a=pina4(i,jm)/(dis(j,ipp)**2) + yyy10b=pina4(i,jm)/(dis(j,jp)**2) + yy10=-pina4(i,jm)/dshe + y10x=(-yy1010*(rx(j,ipp)+rx(j,jp))+yyy10a*rx(j,ipp) + $ +yyy10b*rx(j,jp))*yy10 + y10y=(-yy1010*(ry(j,ipp)+ry(j,jp))+yyy10a*ry(j,ipp) + $ +yyy10b*ry(j,jp))*yy10 + y10z=(-yy1010*(rz(j,ipp)+rz(j,jp))+yyy10a*rz(j,ipp) + $ +yyy10b*rz(j,jp))*yy10 + + sx=y66x+y8x+y9x+y10x + sy=y66y+y8y+y9y+y10y + sz=y66z+y8z+y9z+y10z + + sx1=y8x + sy1=y8y + sz1=y8z + sx2=y66x+y9x+y10x + sy2=y66y+y9y+y10y + sz2=y66z+y9z+y10z + + shefx(j,12)=shefx(j,12)-sx*vbetam(i,jm) + $ -sx1*vbetam1(i,jm)-sx2*vbetam2(i,jm) + shefy(j,12)=shefy(j,12)-sy*vbetam(i,jm) + $ -sy1*vbetam1(i,jm)-sy2*vbetam2(i,jm) + shefz(j,12)=shefz(j,12)-sz*vbetam(i,jm) + $ -sz1*vbetam1(i,jm)-sz2*vbetam2(i,jm) + +ci endif + + ENDDO + ENDDO + + RETURN + END +C=============================================================================== diff --git a/source/unres/src_CSA_DiL/diff12.f b/source/unres/src_CSA_DiL/diff12.f new file mode 100644 index 0000000..13de22e --- /dev/null +++ b/source/unres/src_CSA_DiL/diff12.f @@ -0,0 +1,82 @@ +cccccccccccccccccccccccccccccccccc + subroutine get_diff12(aarray,barray,diff) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CSA' + include 'COMMON.BANK' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + dimension aarray(mxang,maxres,mxch), + & barray(mxang,maxres,mxch) + real x1(maxres),y1(maxres),z1(maxres) + integer n_1(maxres),L1 + real x2(maxres),y2(maxres),z2(maxres) + integer n_2(maxres),L2 + real TM,Rcomm + integer Lcomm + + + IF(tm_score) THEN + + do k=1,numch + do j=2,nres-1 + theta(j+1)=barray(1,j,k) + phi(j+2)=barray(2,j,k) + alph(j)=barray(3,j,k) + omeg(j)=barray(4,j,k) + enddo + enddo + call chainbuild + L1=0 + do i=nnt,nct + L1=L1+1 + n_1(L1)=L1 + x1(L1)=c(1,i) + y1(L1)=c(2,i) + z1(L1)=c(3,i) + enddo + + do k=1,numch + do j=2,nres-1 + theta(j+1)=aarray(1,j,k) + phi(j+2)=aarray(2,j,k) + alph(j)=aarray(3,j,k) + omeg(j)=aarray(4,j,k) + enddo + enddo + call chainbuild + L2=0 + do i=nnt,nct + L2=L2+1 + n_2(L2)=L2 + x2(L2)=c(1,i) + y2(L2)=c(2,i) + z2(L2)=c(3,i) + enddo + + call TMscore(L1,x1,y1,z1,n_1,L2,x2,y2,z2,n_2,TM,Rcomm,Lcomm) + diff=1.0d0-TM + +cd write(*,*)'TMscore=',TM,diff +cd write(*,*)'Number of residues in common=',Lcomm +cd write(*,*)'RMSD of the common residues=',Rcomm + + ELSE + diff=0.d0 + do k=1,numch + do j=2,nres-1 +c do i=1,4 +c do i=1,2 + do i=1,ndiff + dif=rad2deg*dabs(aarray(i,j,k)-barray(i,j,k)) + if(dif.gt.180.) dif=360.-dif + if (dif.gt.diffcut) diff=diff+dif + enddo + enddo + enddo + ENDIF + return + end +ccccccccccccccccccccccccccccccccccccccccccccccccc diff --git a/source/unres/src_CSA_DiL/distfit.f b/source/unres/src_CSA_DiL/distfit.f new file mode 100644 index 0000000..80e8fe4 --- /dev/null +++ b/source/unres/src_CSA_DiL/distfit.f @@ -0,0 +1,207 @@ + subroutine distfit(debug,maxit) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.DISTFIT' + DIMENSION X(MAXRES),DIAGH(MAXRES),phiold(maxres) + logical debug,sing + +cinput------------------------------------ +c NX=NRES-3 +c NY=((NRES-4)*(NRES-5))/2 +cinput------------------------------------ +ctest MAXIT=20 + TOL=0.5 + MAXMAR=10 + RL=100.0 + + CALL TRANSFER(NRES,phi,phiold) + + F0=RDIF() + +cd WRITE (IOUT,*) 'DISTFIT: F0=',F0 + + + DO IT=1,MAXIT + CALL RDERIV + CALL HEVAL + + DO I=1,NX + DIAGH(I)=H(I,I) + ENDDO + RL=RL*0.1 + + DO IMAR=1,MAXMAR + DO I=1,NX + H(I,I)=DIAGH(I)+RL + ENDDO + CALL TRANSFER(NX,XX,X) + CALL BANACH(NX,MAXRES,H,X,sing) + AIN=0.0 + DO I=1,NX + AIN=AIN+DABS(X(I)) + ENDDO + IF (AIN.LT.0.1*TOL .AND. RL.LT.1.0E-4) THEN + if (debug) then + WRITE (IOUT,*) 'DISTFIT: CONVERGENCE HAS BEEN ACHIEVED' + WRITE (IOUT,*) 'IT=',it,'F=',F0 + endif + RETURN + ENDIF + DO I=4,NRES + phi(I)=phiold(I)+mask(i)*X(I-3) +c print *,X(I-3) + ENDDO + + F1=RDIF() +cd WRITE (IOUT,*) 'IMAR=',IMAR,' RL=',RL,' F1=',F1 + IF (F1.LT.F0) THEN + CALL TRANSFER(NRES,phi,phiold) + F0=F1 + GOTO 1 + ELSE IF (DABS(F1-F0).LT.1.0E-5) THEN + if (debug) then + WRITE (IOUT,*) 'DISTFIT: CANNOT IMPROVE DISTANCE FIT' + WRITE (IOUT,*) 'IT=',it,'F=',F1 + endif + RETURN + ENDIF + RL=RL*10.0 + ENDDO + WRITE (IOUT,*) 'DISTFIT: MARQUARDT PROCEDURE HAS FAILED' + WRITE (IOUT,*) 'IT=',it,'F=',F0 + CALL TRANSFER(NRES,phiold,phi) + RETURN + 1 continue +cd write (iout,*) "it",it," imar",imar," f0",f0 + enddo + WRITE (IOUT,*) 'DISTFIT: FINAL F=',F0,'after MAXIT=',maxit + return + END + + double precision FUNCTION RDIF() + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DISTFIT' + +c print *,'in rdif' + + suma=0.0 + ind=0 + call chainbuild + do i=1,nres-3 + do j=i+3,nres + ind=ind+1 + if (w(ind).ne.0.0) then + DIJ=DIST(i,j) + suma=suma+w(ind)*(DIJ-d0(ind))*(DIJ-d0(ind)) + DD(ind)=DIJ +c print '(2i3,i4,4f12.2)',i,j,ind,dij,d0(ind),w(ind),suma + endif + enddo + enddo + + RDIF=suma + RETURN + END + + SUBROUTINE RDERIV + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DISTFIT' + include 'COMMON.GEO' + DIMENSION E12(3),R13(3),R24(3),PRODU(3) + + DO I=1,NY + DO J=1,NX + DRDG(I,J)=0.0 + ENDDO + ENDDO + DO I=1,NX + I1=I+1 + I2=I+2 + CALL VEC(I1,I2,E12) + DO J=1,I + DO K=1,3 + R13(K)=C(K,J)-C(K,I1) + ENDDO + DO K=I2+1,NRES + DO L=1,3 + R24(L)=C(L,K)-C(L,I2) + ENDDO + IND=((J-1)*(2*NRES-J-6))/2+K-3 + PRODU(1)=R13(2)*R24(3)-R13(3)*R24(2) + PRODU(2)=R13(3)*R24(1)-R13(1)*R24(3) + PRODU(3)=R13(1)*R24(2)-R13(2)*R24(1) + DRDG(IND,I)=SCALAR(E12,PRODU)/DIST(J,K) + ENDDO + ENDDO + ENDDO + RETURN + END + + SUBROUTINE HEVAL + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DISTFIT' + + DO I=1,NX + XI=0.0 + HII=0.0 + DO K=1,NY + BKI=DRDG(K,I) + BKIWK=w(K)*BKI + XI=XI+BKIWK*(D0(K)-DD(K)) + HII=HII+BKI*BKIWK + ENDDO + H(I,I)=HII + XX(I)=XI + DO J=I+1,NX + HIJ=0.0 + DO K=1,NY + HIJ=HIJ+DRDG(K,I)*DRDG(K,J)*w(K) + ENDDO + H(I,J)=HIJ + H(J,I)=HIJ + ENDDO + ENDDO + RETURN + END + + + SUBROUTINE VEC(I,J,U) +* +* Find the unit vector from atom (I) to atom (J). Store in U. +* + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + DIMENSION U(3) + + ANORM=0.0 + DO K=1,3 + UK=C(K,J)-C(K,I) + ANORM=ANORM+UK*UK + U(K)=UK + ENDDO + ANORM=SQRT(ANORM) + DO K=1,3 + U(K)=U(K)/ANORM + ENDDO + RETURN + END + + SUBROUTINE TRANSFER(N,X1,X2) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + DIMENSION X1(N),X2(N) + DO 1 I=1,N + 1 X2(I)=X1(I) + RETURN + END + diff --git a/source/unres/src_CSA_DiL/djacob.f b/source/unres/src_CSA_DiL/djacob.f new file mode 100644 index 0000000..e3f46bc --- /dev/null +++ b/source/unres/src_CSA_DiL/djacob.f @@ -0,0 +1,107 @@ + 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 diff --git a/source/unres/src_CSA_DiL/econstr_local.F b/source/unres/src_CSA_DiL/econstr_local.F new file mode 100644 index 0000000..e6e54f7 --- /dev/null +++ b/source/unres/src_CSA_DiL/econstr_local.F @@ -0,0 +1,91 @@ + 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_' +c#ifndef LANG0 +c include 'COMMON.LANGEVIN' +c#else +c include 'COMMON.LANGEVIN.lang0' +c#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 diff --git a/source/unres/src_CSA_DiL/elecont.f b/source/unres/src_CSA_DiL/elecont.f new file mode 100644 index 0000000..e9ed067 --- /dev/null +++ b/source/unres/src_CSA_DiL/elecont.f @@ -0,0 +1,509 @@ + 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 + diff --git a/source/unres/src_CSA_DiL/energy_p_new_barrier.F b/source/unres/src_CSA_DiL/energy_p_new_barrier.F new file mode 100644 index 0000000..821d8f7 --- /dev/null +++ b/source/unres/src_CSA_DiL/energy_p_new_barrier.F @@ -0,0 +1,9159 @@ + 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 + time00=MPI_Wtime() +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 + time00=MPI_Wtime() +#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 JUYONG for dfa test! + if (wdfa_dist.gt.0) call edfad(edfadis) +c print*, 'edfad is finished!', edfadis + if (wdfa_tor.gt.0) call edfat(edfator) +c print*, 'edfat is finished!', edfator + if (wdfa_nei.gt.0) call edfan(edfanei) +c print*, 'edfan is finished!', edfanei + if (wdfa_beta.gt.0) call edfab(edfabet) +c print*, 'edfab is finished!', edfabet +C stop +C JUYONG + +c print *,"Processor",myrank," computed USCSC" +#ifdef TIMING + time01=MPI_Wtime() +#endif + call vec_and_deriv +#ifdef TIMING + time_vec=time_vec+MPI_Wtime()-time01 +#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 +c call EconstrQ + call Econstr_back + else + Uconst=0.0d0 + Uconst_back=0.0d0 + endif +#ifdef TIMING + time_enecalc=time_enecalc+MPI_Wtime()-time00 +#endif +c print *,"Processor",myrank," computed Uconstr" +#ifdef TIMING + time00=MPI_Wtime() +#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 + energia(24)=edfadis + energia(25)=edfator + energia(26)=edfanei + energia(27)=edfabet +c print *," Processor",myrank," calls SUM_ENERGY" + call sum_energy(energia,.true.) +c print *," Processor",myrank," left SUM_ENERGY" +#ifdef TIMING + time_sumene=time_sumene+MPI_Wtime()-time00 +#endif + +c print*, 'etot:',energia(0) + + 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) + edfadis=energia(24) + edfator=energia(25) + edfanei=energia(26) + edfabet=energia(27) +#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 + & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei + & +wdfa_beta*edfabet +#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 + & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei + & +wdfa_beta*edfabet + +#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' + double precision gradbufc(3,maxres),gradbufx(3,maxres), + & glocbuf(4*maxres),gradbufc_sum(3,maxres) +#else + double precision gradbufc(3,maxres),gradbufx(3,maxres), + & glocbuf(4*maxres),gradbufc_sum(3,maxres) +#endif + 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' +#ifdef TIMING + time01=MPI_Wtime() +#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)+ + & wdfa_dist*gdfad(j,i)+ + & wdfa_tor*gdfat(j,i)+ + & wdfa_nei*gdfan(j,i)+ + & wdfa_beta*gdfab(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)+ + & wdfa_dist*gdfad(j,i)+ + & wdfa_tor*gdfat(j,i)+ + & wdfa_nei*gdfan(j,i)+ + & wdfa_beta*gdfab(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)+ + & wdfa_dist*gdfad(j,i)+ + & wdfa_tor*gdfat(j,i)+ + & wdfa_nei*gdfan(j,i)+ + & wdfa_beta*gdfab(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 + call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres, + & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR) + time_reduce=time_reduce+MPI_Wtime()-time00 +#ifdef DEBUG + write (iout,*) "gradbufc_sum after allreduce" + do i=1,nres + write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3) + enddo + call flush(iout) +#endif +#ifdef TIMING + time_allreduce=time_allreduce+MPI_Wtime()-time00 +#endif + do i=nnt,nres + do k=1,3 + gradbufc(k,i)=0.0d0 + enddo + enddo + do i=igrad_start,igrad_end + do j=jgrad_start(i),jgrad_end(i) + do k=1,3 + gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j) + enddo + enddo + enddo + 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=nnt,nres-1 + do k=1,3 + gradbufc(k,i)=0.0d0 + enddo + do j=i+1,nres + do k=1,3 + gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j) + enddo + enddo + enddo +#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) + & +wsccor*gsccor_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 + 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) + time_reduce=time_reduce+MPI_Wtime()-time00 +#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 + time_sumgradient=time_sumgradient+MPI_Wtime()-time01 +#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) +C Juyong + edfadis = energia(24) + edfator = energia(25) + edfanei = energia(26) + edfabet = energia(27) +C +#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,edfadis,edfator,edfanei,edfabet,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)'/ + & '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)'/ + & 'EDFAD= ',1pE16.6,' (DFA distance energy)'/ + & 'EDFAT= ',1pE16.6,' (DFA torsion energy)'/ + & 'EDFAN= ',1pE16.6,' (DFA NCa energy)'/ + & 'EDFAB= ',1pE16.6,' (DFA Beta 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,edfadis,edfator,edfanei,edfabet,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)'/ + & 'EDFAD= ',1pE16.6,' (DFA distance energy)'/ + & 'EDFAT= ',1pE16.6,' (DFA torsion energy)'/ + & 'EDFAN= ',1pE16.6,' (DFA NCa energy)'/ + & 'EDFAB= ',1pE16.6,' (DFA Beta 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' +#ifdef MOMENT + include 'COMMON.CONTACTS.MOMENT' +#endif + 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 (ri' +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,*) 'ji' +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 +cd write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj +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 +C Calculate the distance between the two points and its difference from the +C target distance. + dd=dist(ii,jj) + rdis=dd-dhpb(i) +C Get the force constant corresponding to this distance. + waga=forcon(i) +C Calculate the contribution to energy. + ehpb=ehpb+waga*rdis*rdis +C +C Evaluate gradient. +C + fac=waga*rdis/dd +cd print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd, +cd & ' waga=',waga,' fac=',fac + do j=1,3 + ggg(j)=fac*(c(j,jj)-c(j,ii)) + enddo +cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3) +C If this is a SC-SC 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 +c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) + enddo +! 6/20/98 - dihedral angle constraints + edihcnstr=0.0d0 + do i=1,ndih_constr + itori=idih_constr(i) + phii=phi(itori) + difi=phii-phi0(i) + if (difi.gt.drange(i)) then + difi=difi-drange(i) + edihcnstr=edihcnstr+0.25d0*ftors*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 + else if (difi.lt.-drange(i)) then + difi=difi+drange(i) + edihcnstr=edihcnstr+0.25d0*ftors*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 + endif +! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii, +! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) + enddo +! write (iout,*) 'edihcnstr',edihcnstr + return + end +c------------------------------------------------------------------------------ + 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 +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 +C Regular cosine and sine terms + do j=1,ntermd_1(itori,itori1,itori2) + v1cij=v1c(1,j,itori,itori1,itori2) + v1sij=v1s(1,j,itori,itori1,itori2) + v2cij=v1c(2,j,itori,itori1,itori2) + v2sij=v1s(2,j,itori,itori1,itori2) + cosphi1=dcos(j*phii) + sinphi1=dsin(j*phii) + cosphi2=dcos(j*phii1) + sinphi2=dsin(j*phii1) + etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ + & v2cij*cosphi2+v2sij*sinphi2 + gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1) + gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2) + enddo + do k=2,ntermd_2(itori,itori1,itori2) + do l=1,k-1 + v1cdij = v2c(k,l,itori,itori1,itori2) + v2cdij = v2c(l,k,itori,itori1,itori2) + v1sdij = v2s(k,l,itori,itori1,itori2) + v2sdij = v2s(l,k,itori,itori1,itori2) + cosphi1p2=dcos(l*phii+(k-l)*phii1) + cosphi1m2=dcos(l*phii-(k-l)*phii1) + sinphi1p2=dsin(l*phii+(k-l)*phii1) + sinphi1m2=dsin(l*phii-(k-l)*phii1) + etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ + & v1sdij*sinphi1p2+v2sdij*sinphi1m2 + gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 + & -v1cdij*sinphi1p2-v2cdij*sinphi1m2) + gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 + & -v1cdij*sinphi1p2+v2cdij*sinphi1m2) + enddo + enddo + gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1 + gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2 + 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=iphi_start,iphi_end + esccor_ii=0.0D0 + itori=itype(i-2) + itori1=itype(i-1) + phii=phi(i) + gloci=0.0D0 + do j=1,nterm_sccor + v1ij=v1sccor(j,itori,itori1) + v2ij=v2sccor(j,itori,itori1) + cosphi=dcos(j*phii) + sinphi=dsin(j*phii) + esccor=esccor+v1ij*cosphi+v2ij*sinphi + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo + 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,itori,itori1),j=1,6),(v2sccor(j,itori,itori1),j=1,6) + gsccor_loc(i-3)=gsccor_loc(i-3)+gloci + 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' +#ifdef MOMENT + include 'COMMON.CONTACTS.MOMENT' +#endif + 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' +#ifdef MOMENT + include 'COMMON.CONTACTS.MOMENT' +#endif + 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' +#ifdef MOMENT + include 'COMMON.CONTACTS.MOMENT' +#endif + 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" +#ifdef MOMENT + include 'COMMON.CONTACTS.MOMENT' +#endif + 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' +#ifdef MOMENT + include 'COMMON.CONTACTS.MOMENT' +#endif + 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" +#ifdef MOMENT + include 'COMMON.CONTACTS.MOMENT' +#endif + 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' +#ifdef MOMENT + include 'COMMON.CONTACTS.MOMENT' +#endif + 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' +#ifdef MOMENT + include 'COMMON.CONTACTS.MOMENT' +#endif + 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' +#ifdef MOMENT + include 'COMMON.CONTACTS.MOMENT' +#endif + 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' +#ifdef MOMENT + include 'COMMON.CONTACTS.MOMENT' +#endif + 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' +#ifdef MOMENT + include 'COMMON.CONTACTS.MOMENT' +#endif + 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' +#ifdef MOMENT + include 'COMMON.CONTACTS.MOMENT' +#endif + 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' +#ifdef MOMENT + include 'COMMON.CONTACTS.MOMENT' +#endif + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2) + logical swap + logical lprn + common /kutas/ lprn +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel Antiparallel C +C C +C o o C +C /l\ /j\ C +C / \ / \ C +C /| o | | o |\ C +C \ j|/k\| / \ |/k\|l / C +C \ / \ / \ / \ / C +C o o o o C +C i i C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + itk=itortyp(itype(k)) + s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i)) + s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k)) + s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k)) + call transpose2(EUgC(1,1,k),auxmat(1,1)) + call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) + vv1(1)=pizda1(1,1)-pizda1(2,2) + vv1(2)=pizda1(1,2)+pizda1(2,1) + s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) + vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk) + vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk) + s5=scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5 + eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5) + if (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' +#ifdef MOMENT + include 'COMMON.CONTACTS.MOMENT' +#endif + 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' +#ifdef MOMENT + include 'COMMON.CONTACTS.MOMENT' +#endif + 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' +#ifdef MOMENT + include 'COMMON.CONTACTS.MOMENT' +#endif + 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' +#ifdef MOMENT + include 'COMMON.CONTACTS.MOMENT' +#endif + 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 + diff --git a/source/unres/src_CSA_DiL/fitsq.f b/source/unres/src_CSA_DiL/fitsq.f new file mode 100644 index 0000000..36cbd30 --- /dev/null +++ b/source/unres/src_CSA_DiL/fitsq.f @@ -0,0 +1,364 @@ + 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 diff --git a/source/unres/src_CSA_DiL/gen_rand_conf.F b/source/unres/src_CSA_DiL/gen_rand_conf.F new file mode 100644 index 0000000..9be8b23 --- /dev/null +++ b/source/unres/src_CSA_DiL/gen_rand_conf.F @@ -0,0 +1,910 @@ + 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) + 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 diff --git a/source/unres/src_CSA_DiL/geomout_min.F b/source/unres/src_CSA_DiL/geomout_min.F new file mode 100644 index 0000000..5dab339 --- /dev/null +++ b/source/unres/src_CSA_DiL/geomout_min.F @@ -0,0 +1,348 @@ + 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)') '\@MOLECULE' + write (imol2,'(a)') tytul + write (imol2,'(5i5)') nct-nnt+1,nct-nnt+nss+1,nct-nnt+nss+1,0,0 + write (imol2,'(a)') 'SMALL' + write (imol2,'(a)') 'USER_CHARGES' + write (imol2,'(a)') '\@ATOM' + do i=nnt,nct + write (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)') '\@BOND' + do i=nnt,nct-1 + write (imol2,'(i5,2i6,i2)') i-nnt+1,i-nnt+1,i-nnt+2,1 + enddo + do i=1,nss + write (imol2,'(i5,2i6,i2)') nct-nnt+i,ihpb(i),jhpb(i),1 + enddo + write (imol2,'(a)') '\@SUBSTRUCTURE' + do i=nnt,nct + write (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----------------------------------------------------------------- + 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_' +c 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 +c call rms_nac_nnc(rms,frac,frac_nn,co,.false.) + 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" + else + write (line1,'(i10,f15.2,7f12.3,i5,$)') + & itime,totT,EK,potE,totE, + & amax,kinetic_T,t_bath,gyrate(),me + format1="a114" + 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 + diff --git a/source/unres/src_CSA_DiL/gradient_p.F b/source/unres/src_CSA_DiL/gradient_p.F new file mode 100644 index 0000000..25d1b12 --- /dev/null +++ b/source/unres/src_CSA_DiL/gradient_p.F @@ -0,0 +1,408 @@ + 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' + 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' +c +c This subrouting calculates total Cartesian coordinate gradient. +c The subroutine chainbuild_cart and energy MUST be called beforehand. +c +#ifdef TIMING + time00=MPI_Wtime() +#endif + icg=1 + call sum_gradient +#ifdef TIMING +#endif +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_' +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 + 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 diff --git a/source/unres/src_CSA_DiL/indexx.f b/source/unres/src_CSA_DiL/indexx.f new file mode 100644 index 0000000..b903862 --- /dev/null +++ b/source/unres/src_CSA_DiL/indexx.f @@ -0,0 +1,81 @@ + SUBROUTINE indexx(n,arr,indx) + implicit real*8 (a-h,o-z) + INTEGER n,indx(n),M,NSTACK + REAL*8 arr(n) +c PARAMETER (M=7,NSTACK=50) + PARAMETER (M=7,NSTACK=500) + INTEGER i,indxt,ir,itemp,j,jstack,k,l,istack(NSTACK) + REAL*8 a + do 11 j=1,n + indx(j)=j +11 continue + jstack=0 + l=1 + ir=n +1 if(ir-l.lt.M)then + do 13 j=l+1,ir + indxt=indx(j) + a=arr(indxt) + do 12 i=j-1,1,-1 + if(arr(indx(i)).le.a)goto 2 + indx(i+1)=indx(i) +12 continue + i=0 +2 indx(i+1)=indxt +13 continue + if(jstack.eq.0)return + ir=istack(jstack) + l=istack(jstack-1) + jstack=jstack-2 + else + k=(l+ir)/2 + itemp=indx(k) + indx(k)=indx(l+1) + indx(l+1)=itemp + if(arr(indx(l+1)).gt.arr(indx(ir)))then + itemp=indx(l+1) + indx(l+1)=indx(ir) + indx(ir)=itemp + endif + if(arr(indx(l)).gt.arr(indx(ir)))then + itemp=indx(l) + indx(l)=indx(ir) + indx(ir)=itemp + endif + if(arr(indx(l+1)).gt.arr(indx(l)))then + itemp=indx(l+1) + indx(l+1)=indx(l) + indx(l)=itemp + endif + i=l+1 + j=ir + indxt=indx(l) + a=arr(indxt) +3 continue + i=i+1 + if(arr(indx(i)).lt.a)goto 3 +4 continue + j=j-1 + if(arr(indx(j)).gt.a)goto 4 + if(j.lt.i)goto 5 + itemp=indx(i) + indx(i)=indx(j) + indx(j)=itemp + goto 3 +5 indx(l)=indx(j) + indx(j)=indxt + jstack=jstack+2 + if(jstack.gt.NSTACK)pause 'NSTACK too small in indexx' + if(ir-i+1.ge.j-l)then + istack(jstack)=ir + istack(jstack-1)=i + ir=j-1 + else + istack(jstack)=j-1 + istack(jstack-1)=l + l=i + endif + endif + goto 1 + END +C (C) Copr. 1986-92 Numerical Recipes Software *11915aZ%. diff --git a/source/unres/src_CSA_DiL/initialize_p.F b/source/unres/src_CSA_DiL/initialize_p.F new file mode 100644 index 0000000..19cf3d6 --- /dev/null +++ b/source/unres/src_CSA_DiL/initialize_p.F @@ -0,0 +1,1386 @@ + block data + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.MCM' +c 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 +c 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"," "," ", + & "DFA DIS","DFA TOR","DFA NEI","DFA BET"/ + data wname / + & "WSC","WSCP","WELEC","WCORR","WCORR5","WCORR6","WEL_LOC", + & "WTURN3","WTURN4","WTURN6","WANG","WSCLOC","WTOR","WTORD", + & "WSTRAIN","WVDWPP","WBOND","SCAL14"," "," ","WSCCOR", + & " "," ","WDFAD","WDFAT","WDFAN","WDFAB"/ + data nprint_ene /24/ + data print_order/1,2,3,11,12,13,14,4,5,6,7,8,9,10,19,18,15,17,16, + & 21,24,25,26,27,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,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 + 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 diff --git a/source/unres/src_CSA_DiL/int_to_cart.f b/source/unres/src_CSA_DiL/int_to_cart.f new file mode 100644 index 0000000..97324ec --- /dev/null +++ b/source/unres/src_CSA_DiL/int_to_cart.f @@ -0,0 +1,119 @@ + 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' + +c calculating dE/ddc1 + if (nres.lt.3) return + 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 + return + end + + diff --git a/source/unres/src_CSA_DiL/intcartderiv.F b/source/unres/src_CSA_DiL/intcartderiv.F new file mode 100644 index 0000000..5fea875 --- /dev/null +++ b/source/unres/src_CSA_DiL/intcartderiv.F @@ -0,0 +1,466 @@ + 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' + 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 + +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 +#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 +cd write (iout,*) "Gather dtheta" +cd call flush(iout) + write (iout,*) "dtheta before gather" + do i=1,nres + write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2) + 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 diff --git a/source/unres/src_CSA_DiL/intcor.f b/source/unres/src_CSA_DiL/intcor.f new file mode 100644 index 0000000..a3cd5d0 --- /dev/null +++ b/source/unres/src_CSA_DiL/intcor.f @@ -0,0 +1,91 @@ +C +C------------------------------------------------------------------------------ +C + double precision function alpha(i1,i2,i3) +c +c Calculates the planar angle between atoms (i1), (i2), and (i3). +c + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.CHAIN' + x12=c(1,i1)-c(1,i2) + x23=c(1,i3)-c(1,i2) + y12=c(2,i1)-c(2,i2) + y23=c(2,i3)-c(2,i2) + z12=c(3,i1)-c(3,i2) + z23=c(3,i3)-c(3,i2) + vnorm=dsqrt(x12*x12+y12*y12+z12*z12) + wnorm=dsqrt(x23*x23+y23*y23+z23*z23) + scalar=(x12*x23+y12*y23+z12*z23)/(vnorm*wnorm) + alpha=arcos(scalar) + return + end +C +C------------------------------------------------------------------------------ +C + double precision function beta(i1,i2,i3,i4) +c +c Calculates the dihedral angle between atoms (i1), (i2), (i3) and (i4) +c + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.CHAIN' + x12=c(1,i1)-c(1,i2) + x23=c(1,i3)-c(1,i2) + x34=c(1,i4)-c(1,i3) + y12=c(2,i1)-c(2,i2) + y23=c(2,i3)-c(2,i2) + y34=c(2,i4)-c(2,i3) + z12=c(3,i1)-c(3,i2) + z23=c(3,i3)-c(3,i2) + z34=c(3,i4)-c(3,i3) +cd print '(2i3,3f10.5)',i1,i2,x12,y12,z12 +cd print '(2i3,3f10.5)',i2,i3,x23,y23,z23 +cd print '(2i3,3f10.5)',i3,i4,x34,y34,z34 + wx=-y23*z34+y34*z23 + wy=x23*z34-z23*x34 + wz=-x23*y34+y23*x34 + wnorm=dsqrt(wx*wx+wy*wy+wz*wz) + vx=y12*z23-z12*y23 + vy=-x12*z23+z12*x23 + vz=x12*y23-y12*x23 + vnorm=dsqrt(vx*vx+vy*vy+vz*vz) + if (vnorm.gt.1.0D-13 .and. wnorm.gt.1.0D-13) then + scalar=(vx*wx+vy*wy+vz*wz)/(vnorm*wnorm) + if (dabs(scalar).gt.1.0D0) + &scalar=0.99999999999999D0*scalar/dabs(scalar) + angle=dacos(scalar) +cd print '(2i4,10f7.3)',i2,i3,vx,vy,vz,wx,wy,wz,vnorm,wnorm, +cd &scalar,angle + else + angle=pi + endif +c if (angle.le.0.0D0) angle=pi+angle + tx=vy*wz-vz*wy + ty=-vx*wz+vz*wx + tz=vx*wy-vy*wx + scalar=tx*x23+ty*y23+tz*z23 + if (scalar.lt.0.0D0) angle=-angle + beta=angle + return + end +C +C------------------------------------------------------------------------------ +C + function dist(i1,i2) +c +c Calculates the distance between atoms (i1) and (i2). +c + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.CHAIN' + x12=c(1,i1)-c(1,i2) + y12=c(2,i1)-c(2,i2) + z12=c(3,i1)-c(3,i2) + dist=dsqrt(x12*x12+y12*y12+z12*z12) + return + end +C diff --git a/source/unres/src_CSA_DiL/intlocal.f b/source/unres/src_CSA_DiL/intlocal.f new file mode 100644 index 0000000..2dbcc88 --- /dev/null +++ b/source/unres/src_CSA_DiL/intlocal.f @@ -0,0 +1,517 @@ + 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 diff --git a/source/unres/src_CSA_DiL/local_move.f b/source/unres/src_CSA_DiL/local_move.f new file mode 100644 index 0000000..d02a9d1 --- /dev/null +++ b/source/unres/src_CSA_DiL/local_move.f @@ -0,0 +1,970 @@ +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------------------------------------------------------------- diff --git a/source/unres/src_CSA_DiL/matmult.f b/source/unres/src_CSA_DiL/matmult.f new file mode 100644 index 0000000..e9257cf --- /dev/null +++ b/source/unres/src_CSA_DiL/matmult.f @@ -0,0 +1,18 @@ + SUBROUTINE MATMULT(A1,A2,A3) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + DIMENSION A1(3,3),A2(3,3),A3(3,3) + DIMENSION AI3(3,3) + DO 1 I=1,3 + DO 2 J=1,3 + A3IJ=0.0 + DO 3 K=1,3 + 3 A3IJ=A3IJ+A1(I,K)*A2(K,J) + AI3(I,J)=A3IJ + 2 CONTINUE + 1 CONTINUE + DO 4 I=1,3 + DO 4 J=1,3 + 4 A3(I,J)=AI3(I,J) + RETURN + END diff --git a/source/unres/src_CSA_DiL/minim_jlee.F b/source/unres/src_CSA_DiL/minim_jlee.F new file mode 100644 index 0000000..2b53f11 --- /dev/null +++ b/source/unres/src_CSA_DiL/minim_jlee.F @@ -0,0 +1,452 @@ +#ifdef MPI + subroutine minim_jlee +c controls minimization and sorting routines + 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 'COMMON.CONTROL' + include 'mpif.h' + external func,gradient,fdum + real ran1,ran2,ran3 + include 'COMMON.SETUP' + include 'COMMON.GEO' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + include 'COMMON.DISTFIT' + include 'COMMON.CHAIN' + dimension muster(mpi_status_size) + dimension var(maxvar),erg(mxch*(mxch+1)/2+1) + dimension var2(maxvar) + integer iffr(maxres),ihpbt(maxdim),jhpbt(maxdim) + double precision d(maxvar),v(1:lv+1),garbage(maxvar) + double precision energia(0:n_ene),time0s,time1s + dimension indx(9),info(12) + dimension iv(liv) + dimension idum(1),rdum(1) + dimension icont(2,maxcont) + logical check_var,fail + integer iloop(2) + common /przechowalnia/ v + data rad /1.745329252d-2/ +c receive # of start +! print *,'Processor',me,' calling MINIM_JLEE maxfun',maxfun, +! & ' maxmin',maxmin,' tolf',tolf,' rtolf',rtolf + nhpb0=nhpb + 10 continue + time0s=MPI_WTIME() +c print *, 'MINIM_JLEE: ',me,' is waiting' + call mpi_recv(info,12,mpi_integer,king,idint,CG_COMM, + * muster,ierr) + time1s=MPI_WTIME() + write (iout,'(a12,f10.4,a4)')'Waiting for ',time1s-time0s,' sec' + call flush(iout) + if (info(1).eq.0.and.info(2).eq.-2) then +cd write (iout,*) 'Parallel tmscore for refresh bank' +cd call flush(iout) + call refresh_bank_worker_tmscore(var) + goto 10 + endif + n=info(1) +c print *, 'MINIM_JLEE: ',me,' received: ',n + +crc if (ierr.ne.0) go to 100 +c if # = 0, return + if (n.eq.0) then + write (iout,*) 'Finishing minim_jlee - signal',n,' from master' + call flush(iout) + return + endif + + nfun=0 + IF (n.lt.0) THEN + call mpi_recv(var,nvar,mpi_double_precision, + * king,idreal,CG_COMM,muster,ierr) + call mpi_recv(iffr,nres,mpi_integer, + * king,idint,CG_COMM,muster,ierr) + call mpi_recv(var2,nvar,mpi_double_precision, + * king,idreal,CG_COMM,muster,ierr) + ELSE +c receive initial values of variables + call mpi_recv(var,nvar,mpi_double_precision, + * king,idreal,CG_COMM,muster,ierr) +crc if (ierr.ne.0) go to 100 + ENDIF + + if(vdisulf.and.info(2).ne.-1) then + if(info(4).ne.0)then + call mpi_recv(ihpbt,info(4),mpi_integer, + * king,idint,CG_COMM,muster,ierr) + call mpi_recv(jhpbt,info(4),mpi_integer, + * king,idint,CG_COMM,muster,ierr) + endif + endif + + IF (n.lt.0) THEN + n=-n + nhpb=nhpb0 + link_start=1 + link_end=nhpb + call init_int_table + call contact_cp(var,var2,iffr,nfun,n) + ENDIF + + if(vdisulf.and.info(2).ne.-1) then + nss=0 + if(info(4).ne.0)then +cd write(iout,*) 'SS=',info(4),'N=',info(1),'IT=',info(2) + call var_to_geom(nvar,var) + call chainbuild + do i=1,info(4) + if (dist(ihpbt(i),jhpbt(i)).lt.7.0) then + nss=nss+1 + ihpb(nss)=ihpbt(i) + jhpb(nss)=jhpbt(i) +cd write(iout,*) 'SS mv=',info(3), +cd & ihpb(nss)-nres,jhpb(nss)-nres, +cd & dist(ihpb(nss),jhpb(nss)) + dhpb(nss)=dbr + forcon(nss)=fbr + else +cd write(iout,*) 'rm SS mv=',info(3), +cd & ihpbt(i)-nres,jhpbt(i)-nres,dist(ihpbt(i),jhpbt(i)) + endif + enddo + endif + nhpb=nss + link_start=1 + link_end=nhpb + call init_int_table + endif + + if (info(3).eq.14) then + write(iout,*) 'calling local_move',info(7),info(8) + call local_move_init(.false.) + call var_to_geom(nvar,var) + call local_move(info(7),info(8),20d0,50d0) + call geom_to_var(nvar,var) + endif + + + if (info(3).eq.16) then + write(iout,*) 'calling beta_slide',info(7),info(8), + & info(10), info(11), info(12) + call var_to_geom(nvar,var) + call beta_slide(info(7),info(8),info(10),info(11),info(12) + & ,nfun,n) + call geom_to_var(nvar,var) + endif + + + if (info(3).eq.17) then + write(iout,*) 'calling beta_zip',info(7),info(8) + call var_to_geom(nvar,var) + call beta_zip(info(7),info(8),nfun,n) + call geom_to_var(nvar,var) + endif + + +crc overlap test + + if (overlapsc) then + + call var_to_geom(nvar,var) + call chainbuild + call etotal(energia(0)) + nfun=nfun+1 + if (energia(1).eq.1.0d20) then + info(3)=-info(3) + write (iout,'(a,1pe14.5)')'#OVERLAP evdw=1d20',energia(1) + call overlap_sc(fail) + if(.not.fail) then + call geom_to_var(nvar,var) + call etotal(energia(0)) + nfun=nfun+1 + write (iout,'(a,1pe14.5)')'#OVERLAP evdw after',energia(1) + else + v(10)=1.0d20 + iv(1)=-1 + goto 201 + endif + endif + endif + + if (searchsc) then + call var_to_geom(nvar,var) + call sc_move(2,nres-1,1,10d0,nft_sc,etot) + call geom_to_var(nvar,var) +cd write(iout,*) 'sc_move',nft_sc,etot + endif + + if (check_var(var,info)) then + v(10)=1.0d21 + iv(1)=6 + goto 201 + endif + + +crc + +! write (iout,*) 'MINIM_JLEE: Processor',me,' nvar',nvar +! write (iout,'(8f10.4)') (var(i),i=1,nvar) +! write (*,*) 'MINIM_JLEE: Processor',me,' received nvar',nvar +! write (*,'(8f10.4)') (var(i),i=1,nvar) + + do i=1,nvar + garbage(i)=var(i) + enddo + + 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 +cd iv(21)=iout + iv(21)=0 +* 1 means to print out result + iv(22)=0 +cd iv(22)=1 +* 1 means to print out summary stats + iv(23)=0 +* 1 means to print initial x and d + iv(24)=0 + +c if(me.eq.3.and.n.eq.255) then +c print *,' CHUJ: stoi' +c iv(21)=6 +c iv(22)=1 +c iv(23)=1 +c iv(24)=1 +c endif + +* 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 +c minimize energy +! write (iout,*) 'Processor',me,' nvar',nvar +! write (iout,*) 'Variables BEFORE minimization:' +! write (iout,'(8f10.4)') (rad2deg*var(i),i=1,nvar) + +c print *, 'MINIM_JLEE: ',me,' before SUMSL ' + + call func(nvar,var,nf,eee,idum,rdum,fdum) + nfun=nfun+1 + if(eee.ge.1.0d20) 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 + go to 201 + endif + +ct time0s=MPI_WTIME() + call sumsl(nvar,d,var,func,gradient,iv,liv,lv,v,idum,rdum,fdum) +ct write(iout,*) 'sumsl time=',MPI_WTIME()-time0s,iv(7),v(10) +c print *, 'MINIM_JLEE: ',me,' after SUMSL ' + +c find which conformation was returned from sumsl + nfun=nfun+iv(7) +! print *,'Processor',me,' iv(17)',iv(17),' iv(18)',iv(18),' nf',nf, +! & ' retcode',iv(1),' energy',v(10),' tolf',v(31),' rtolf',v(32) +c if (iv(1).ne.4 .or. nf.le.1) then +c write (*,*) 'Processor',me,' something bad in SUMSL',iv(1),nf +c write (*,*) 'Initial Variables' +c write (*,'(8f10.4)') (rad2deg*garbage(i),i=1,nvar) +c write (*,*) 'Variables' +c write (*,'(8f10.4)') (rad2deg*var(i),i=1,nvar) +c write (*,*) 'Vector d' +c write (*,'(8f10.4)') (d(i),i=1,nvar) +c write (iout,*) 'Processor',me,' something bad in SUMSL', +c & iv(1),nf +c write (iout,*) 'Initial Variables' +c write (iout,'(8f10.4)') (rad2deg*garbage(i),i=1,nvar) +c write (iout,*) 'Variables' +c write (iout,'(8f10.4)') (rad2deg*var(i),i=1,nvar) +c write (iout,*) 'Vector d' +c write (iout,'(8f10.4)') (d(i),i=1,nvar) +c endif +c if (nf.lt.iv(6)-1) then +c recalculate intra- and interchain energies +c call func(nvar,var,nf,v(10),iv,v,fdum) +c else if (nf.eq.iv(6)-1) then +c regenerate conformation +c call var_to_geom(nvar,var) +c call chainbuild +c endif +c change origin and axes to standard ECEPP format +c call var_to_geom(nvar,var) +! write (iout,*) 'MINIM_JLEE after minim: Processor',me,' nvar',nvar +! write (iout,'(8f10.4)') (var(i),i=1,nvar) +! write (iout,*) 'Energy:',v(10) +c send back output +c print *, 'MINIM_JLEE: ',me,' minimized: ',n + 201 continue + indx(1)=n +c return code: 6-gradient 9-number of ftn evaluation, etc + indx(2)=iv(1) +c total # of ftn evaluations (for iwf=0, it includes all minimizations). + indx(3)=nfun + indx(4)=info(2) + indx(5)=info(3) + indx(6)=nss + indx(7)=info(5) + indx(8)=info(6) + indx(9)=info(9) + call mpi_send(indx,9,mpi_integer,king,idint,CG_COMM, + * ierr) +c send back energies +c al & cc +c calculate contact order +#ifdef CO_BIAS + call contact(.false.,ncont,icont,co) + erg(1)=v(10)-1.0d2*co +#else + erg(1)=v(10) +#endif + j=1 + call mpi_send(erg,j,mpi_double_precision,king,idreal, + * CG_COMM,ierr) +#ifdef CO_BIAS + call mpi_send(co,j,mpi_double_precision,king,idreal, + * CG_COMM,ierr) +#endif +c send back values of variables + call mpi_send(var,nvar,mpi_double_precision, + * king,idreal,CG_COMM,ierr) +! print * , 'MINIM_JLEE: Processor',me,' send erg and var ' + + if(vdisulf.and.info(2).ne.-1.and.nss.ne.0) then +cd call intout +cd call chainbuild +cd call etotal(energia(0)) +cd etot=energia(0) +cd call enerprint(energia(0)) + call mpi_send(ihpb,nss,mpi_integer, + * king,idint,CG_COMM,ierr) + call mpi_send(jhpb,nss,mpi_integer, + * king,idint,CG_COMM,ierr) + endif + + go to 10 + 100 print *, ' error in receiving message from emperor', me + call mpi_abort(mpi_comm_world,ierror,ierrcode) + return + 200 print *, ' error in sending message to emperor' + call mpi_abort(mpi_comm_world,ierror,ierrcode) + return + 300 print *, ' error in communicating with emperor' + call mpi_abort(mpi_comm_world,ierror,ierrcode) + return + 956 format (' initial energy could not be calculated',41x) + 957 format (80x) + 965 format (' convergence code ',i2,' # of function calls ', + * i4,' # of gradient calls ',i4,10x) + 975 format (' energy ',1p,e12.4,' scaled gradient ',e11.3,32x) + end +#else + subroutine minim_jlee +c controls minimization and sorting routines + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + write (iout,*) "Unsupported option for serial version" + return + end +#endif + + logical function check_var(var,info) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.SETUP' + dimension var(maxvar) + dimension info(3) +C AL ------- + check_var=.false. + do i=nphi+ntheta+1,nphi+ntheta+nside +! Check the side chain "valence" angles alpha + if (var(i).lt.1.0d-7) then + write (iout,*) 'CHUJ NASTAPIL ABSOLUTNY!!!!!!!!!!!!' + write (iout,*) 'Processor',me,'received bad variables!!!!' + write (iout,*) 'Variables' + write (iout,'(8f10.4)') (rad2deg*var(j),j=1,nvar) + write (iout,*) 'Continuing calculations at this point', + & ' could destroy the results obtained so far... ABORTING!!!!!!' + write (iout,'(a19,i5,f10.4,a4,2i4,a3,i3)') + & 'valence angle alpha',i-nphi-ntheta,var(i), + & 'n it',info(1),info(2),'mv ',info(3) + write (*,*) 'CHUJ NASTAPIL ABSOLUTNY!!!!!!!!!!!!' + write (*,*) 'Processor',me,'received bad variables!!!!' + write (*,*) 'Variables' + write (*,'(8f10.4)') (rad2deg*var(j),j=1,nvar) + write (*,*) 'Continuing calculations at this point', + & ' could destroy the results obtained so far... ABORTING!!!!!!' + write (*,'(a19,i5,f10.4,a4,2i4,a3,i3)') + & 'valence angle alpha',i-nphi-ntheta,var(i), + & 'n it',info(1),info(2),'mv ',info(3) + check_var=.true. + return + endif + enddo +! Check the backbone "valence" angles theta + do i=nphi+1,nphi+ntheta + if (var(i).lt.1.0d-7) then + write (iout,*) 'CHUJ NASTAPIL ABSOLUTNY!!!!!!!!!!!!' + write (iout,*) 'Processor',me,'received bad variables!!!!' + write (iout,*) 'Variables' + write (iout,'(8f10.4)') (rad2deg*var(j),j=1,nvar) + write (iout,*) 'Continuing calculations at this point', + & ' could destroy the results obtained so far... ABORTING!!!!!!' + write (iout,'(a19,i5,f10.4,a4,2i4,a3,i3)') + & 'valence angle theta',i-nphi,var(i), + & 'n it',info(1),info(2),'mv ',info(3) + write (*,*) 'CHUJ NASTAPIL ABSOLUTNY!!!!!!!!!!!!' + write (*,*) 'Processor',me,'received bad variables!!!!' + write (*,*) 'Variables' + write (*,'(8f10.4)') (rad2deg*var(j),j=1,nvar) + write (*,*) 'Continuing calculations at this point', + & ' could destroy the results obtained so far... ABORTING!!!!!!' + write (*,'(a19,i5,f10.4,a4,2i4,a3,i3)') + & 'valence angle theta',i-nphi,var(i), + & 'n it',info(1),info(2),'mv ',info(3) + check_var=.true. + return + endif + enddo + return + end diff --git a/source/unres/src_CSA_DiL/minim_mult.F b/source/unres/src_CSA_DiL/minim_mult.F new file mode 100644 index 0000000..0af0b3b --- /dev/null +++ b/source/unres/src_CSA_DiL/minim_mult.F @@ -0,0 +1,131 @@ +#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 ',indx(2) + 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) +c print *,indx(2),indx(5) + 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 +#else + subroutine minim_mcmf + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + write (iout,*) "Unsupported option for serial version" + return + end +#endif + diff --git a/source/unres/src_CSA_DiL/minimize_p.F b/source/unres/src_CSA_DiL/minimize_p.F new file mode 100644 index 0000000..876db34 --- /dev/null +++ b/source/unres/src_CSA_DiL/minimize_p.F @@ -0,0 +1,641 @@ + 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 +cmd 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 +cmd 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 +cmd 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 +cmd call fricmat_mult(z,d_a_tmp) + else if (iorder.eq.10) then +cmd 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 diff --git a/source/unres/src_CSA_DiL/misc.f b/source/unres/src_CSA_DiL/misc.f new file mode 100644 index 0000000..e189839 --- /dev/null +++ b/source/unres/src_CSA_DiL/misc.f @@ -0,0 +1,203 @@ +C $Date: 1994/10/12 17:24:21 $ +C $Revision: 2.5 $ +C +C +C + logical function find_arg(ipos,line,errflag) + parameter (maxlen=80) + character*80 line + character*1 empty /' '/,equal /'='/ + logical errflag +* This function returns .TRUE., if an argument follows keyword keywd; if so +* IPOS will point to the first non-blank character of the argument. Returns +* .FALSE., if no argument follows the keyword; in this case IPOS points +* to the first non-blank character of the next keyword. + do while (line(ipos:ipos) .eq. empty .and. ipos.le.maxlen) + ipos=ipos+1 + enddo + errflag=.false. + if (line(ipos:ipos).eq.equal) then + find_arg=.true. + ipos=ipos+1 + do while (line(ipos:ipos) .eq. empty .and. ipos.le.maxlen) + ipos=ipos+1 + enddo + if (ipos.gt.maxlen) errflag=.true. + else + find_arg=.false. + endif + return + end + logical function find_group(iunit,jout,key1) + character*(*) key1 + character*80 karta,ucase + integer ilen + external ilen + logical lcom + rewind (iunit) + karta=' ' + ll=ilen(key1) + do while (index(ucase(karta),key1(1:ll)).eq.0.or.lcom(1,karta)) + read (iunit,'(a)',end=10) karta + enddo + write (jout,'(2a)') '> ',karta(1:78) + find_group=.true. + return + 10 find_group=.false. + return + end + logical function iblnk(charc) + character*1 charc + integer n + n = ichar(charc) + iblnk = (n.eq.9) .or. (n.eq.10) .or. (charc.eq. ' ') + return + end + integer function ilen(string) + character*(*) string + logical iblnk + + ilen = len(string) +1 if ( ilen .gt. 0 ) then + if ( iblnk( string(ilen:ilen) ) ) then + ilen = ilen - 1 + goto 1 + endif + endif + return + end + integer function in_keywd_set(nkey,ikey,narg,keywd,keywdset) + character*16 keywd,keywdset(1:nkey,0:nkey) + character*16 ucase + do i=1,narg + if (ucase(keywd).eq.keywdset(i,ikey)) then +* Match found + in_keywd_set=i + return + endif + enddo +* No match to the allowed set of keywords if this point is reached. + in_keywd_set=0 + return + end + character*(*) function lcase(string) + integer i, k, idiff + character*(*) string + character*1 c + character*40 chtmp +c + i = len(lcase) + k = len(string) + if (i .lt. k) then + k = i + if (string(k+1:) .ne. ' ') then + chtmp = string + endif + endif + idiff = ichar('a') - ichar('A') + lcase = string + do 99 i = 1, k + c = string(i:i) + if (lge(c,'A') .and. lle(c,'Z')) then + lcase(i:i) = char(ichar(c) + idiff) + endif + 99 continue + return + end + logical function lcom(ipos,karta) + character*80 karta + character koment(2) /'!','#'/ + lcom=.false. + do i=1,2 + if (karta(ipos:ipos).eq.koment(i)) lcom=.true. + enddo + return + end + logical function lower_case(ch) + character*(*) ch + lower_case=(ch.ge.'a' .and. ch.le.'z') + return + end + subroutine mykey(line,keywd,ipos,blankline,errflag) +* This subroutine seeks a non-empty substring keywd in the string LINE. +* The substring begins with the first character different from blank and +* "=" encountered right to the pointer IPOS (inclusively) and terminates +* at the character left to the first blank or "=". When the subroutine is +* exited, the pointer IPOS is moved to the position of the terminator in LINE. +* The logical variable BLANKLINE is set at .TRUE., if LINE(IPOS:) contains +* only separators or the maximum length of the data line (80) has been reached. +* The logical variable ERRFLAG is set at .TRUE. if the string +* consists only from a "=". + parameter (maxlen=80) + character*1 empty /' '/,equal /'='/,comma /','/ + character*(*) keywd + character*80 line + logical blankline,errflag,lcom + errflag=.false. + do while (line(ipos:ipos).eq.empty .and. (ipos.le.maxlen)) + ipos=ipos+1 + enddo + if (ipos.gt.maxlen .or. lcom(ipos,line) ) then +* At this point the rest of the input line turned out to contain only blanks +* or to be commented out. + blankline=.true. + return + endif + blankline=.false. + istart=ipos +* Checks whether the current char is a separator. + do while (line(ipos:ipos).ne.empty .and. line(ipos:ipos).ne.equal + & .and. line(ipos:ipos).ne.comma .and. ipos.le.maxlen) + ipos=ipos+1 + enddo + iend=ipos-1 +* Error flag set to .true., if the length of the keyword was found less than 1. + if (iend.lt.istart) then + errflag=.true. + return + endif + keywd=line(istart:iend) + return + end + subroutine numstr(inum,numm) + character*10 huj /'0123456789'/ + character*(*) numm + inumm=inum + inum1=inumm/10 + inum2=inumm-10*inum1 + inumm=inum1 + numm(3:3)=huj(inum2+1:inum2+1) + inum1=inumm/10 + inum2=inumm-10*inum1 + inumm=inum1 + numm(2:2)=huj(inum2+1:inum2+1) + inum1=inumm/10 + inum2=inumm-10*inum1 + inumm=inum1 + numm(1:1)=huj(inum2+1:inum2+1) + return + end + character*(*) function ucase(string) + integer i, k, idiff + character*(*) string + character*1 c + character*40 chtmp +c + i = len(ucase) + k = len(string) + if (i .lt. k) then + k = i + if (string(k+1:) .ne. ' ') then + chtmp = string + endif + endif + idiff = ichar('a') - ichar('A') + ucase = string + do 99 i = 1, k + c = string(i:i) + if (lge(c,'a') .and. lle(c,'z')) then + ucase(i:i) = char(ichar(c) - idiff) + endif + 99 continue + return + end diff --git a/source/unres/src_CSA_DiL/newconf.F b/source/unres/src_CSA_DiL/newconf.F new file mode 100644 index 0000000..df93149 --- /dev/null +++ b/source/unres/src_CSA_DiL/newconf.F @@ -0,0 +1,2456 @@ +#ifdef MPI +ccccccccccccccccccccccccccccccccccccccccccccccccc +ccccccccccccccccccccccccccccccccccccccccccccccccc + subroutine make_var(n,idum,iter_csa) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CSA' + include 'COMMON.BANK' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.HAIRPIN' + include 'COMMON.VAR' + include 'COMMON.DISTFIT' + include 'COMMON.GEO' + include 'COMMON.CONTROL' + logical nicht_getan,nicht_getan1,fail,lfound + integer nharp,iharp(4,maxres/3),nconf_harp + integer iisucc(mxio) + logical ifused(mxio) + integer nhx_seed(max_seed),ihx_seed(4,maxres/3,max_seed) + integer nhx_use(max_seed),ihx_use(0:4,maxres/3,max_seed) + integer nlx_seed(max_seed),ilx_seed(2,maxres/3,max_seed), + & nlx_use(max_seed),ilx_use(maxres/3,max_seed) + real ran1,ran2 + + write (iout,*) 'make_var : nseed=',nseed,'ntry=',n + index=0 + +c----------------------------------------- + if (n7.gt.0.or.n8.gt.0.or.n9.gt.0.or.n14.gt.0.or.n15.gt.0 + & .or.n16.gt.0.or.n17.gt.0.or.n18.gt.0) + & call select_frag(n7frag,n8frag,n14frag, + & n15frag,nbefrag,iter_csa) + +c--------------------------------------------------- +c N18 - random perturbation of one phi(=gamma) angle in a loop +c + IF (n18.gt.0) THEN + nlx_tot=0 + do iters=1,nseed + i1=is(iters) + nlx_seed(iters)=0 + do i2=1,n14frag + if (lvar_frag(i2,1).eq.i1) then + nlx_seed(iters)=nlx_seed(iters)+5 + ilx_seed(1,nlx_seed(iters),iters)=lvar_frag(i2,2) + ilx_seed(2,nlx_seed(iters),iters)=lvar_frag(i2,3) + ilx_use(nlx_seed(iters),iters)=5 + endif + enddo + nlx_use(iters)=nlx_seed(iters) + nlx_tot=nlx_tot+nlx_seed(iters) + enddo + + if (nlx_tot .ge. n18*nseed) then + ntot_gen=n18*nseed + else + ntot_gen=(nlx_tot/nseed)*nseed + endif + + ngen=0 + do while (ngen.lt.ntot_gen) + do iters=1,nseed + iseed=is(iters) + if (nlx_use(iters).gt.0) then + nicht_getan=.true. + do while (nicht_getan) + iih=iran_num(1,nlx_seed(iters)) + if (ilx_use(iih,iters).gt.0) then + nicht_getan=.false. + ilx_use(iih,iters)=ilx_use(iih,iters)-1 + nlx_use(iters)=nlx_use(iters)-1 + endif + enddo + ngen=ngen+1 + index=index+1 + movenx(index)=18 + parent(1,index)=iseed + parent(2,index)=0 + + + if (vdisulf) then + nss_in(index)=bvar_nss(iseed) + do ij=1,nss_in(index) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + endif + + + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang_in(i,j,k,index)=bvar(i,j,k,iseed) + enddo + enddo + enddo + + jr=iran_num(ilx_seed(1,iih,iters),ilx_seed(2,iih,iters)) + d=ran_number(-pi,pi) + dihang_in(2,jr-2,1,index)=pinorm(dihang_in(2,jr-2,1,index)+d) + + + if (ngen.eq.ntot_gen) goto 145 + endif + enddo + enddo + 145 continue + + ENDIF + + +c----------------------------------------- +c N17 : zip a beta in a seed by forcing one additional p-p contact +c + IF (n17.gt.0) THEN + nhx_tot=0 + do iters=1,nseed + i1=is(iters) + nhx_seed(iters)=0 + nhx_use(iters)=0 + do i2=1,nbefrag + if (avar_frag(i2,1).eq.i1) then + nhx_seed(iters)=nhx_seed(iters)+1 + ihx_use(2,nhx_seed(iters),iters)=1 + if (avar_frag(i2,5)-avar_frag(i2,3).le.3.and. + & avar_frag(i2,2).gt.1.and.avar_frag(i2,4).lt.nres) then + ihx_seed(1,nhx_seed(iters),iters)=avar_frag(i2,2)-1 + ihx_seed(2,nhx_seed(iters),iters)=avar_frag(i2,4)+1 + ihx_use(0,nhx_seed(iters),iters)=1 + ihx_use(1,nhx_seed(iters),iters)=0 + nhx_use(iters)=nhx_use(iters)+1 + else + if (avar_frag(i2,4).gt.avar_frag(i2,5)) then + if (avar_frag(i2,2).gt.1.and. + & avar_frag(i2,4).lt.nres) then + ihx_seed(1,nhx_seed(iters),iters)=avar_frag(i2,2)-1 + ihx_seed(2,nhx_seed(iters),iters)=avar_frag(i2,4)+1 + ihx_use(0,nhx_seed(iters),iters)=1 + ihx_use(1,nhx_seed(iters),iters)=0 + nhx_use(iters)=nhx_use(iters)+1 + endif + if (avar_frag(i2,3).lt.nres.and. + & avar_frag(i2,5).gt.1) then + ihx_seed(1,nhx_seed(iters),iters)=avar_frag(i2,3)+1 + ihx_seed(2,nhx_seed(iters),iters)=avar_frag(i2,5)-1 + ihx_use(0,nhx_seed(iters),iters)= + & ihx_use(0,nhx_seed(iters),iters)+1 + ihx_use(2,nhx_seed(iters),iters)=0 + nhx_use(iters)=nhx_use(iters)+1 + endif + else + if (avar_frag(i2,2).gt.1.and. + & avar_frag(i2,4).gt.1) then + ihx_seed(1,nhx_seed(iters),iters)=avar_frag(i2,2)-1 + ihx_seed(2,nhx_seed(iters),iters)=avar_frag(i2,4)-1 + ihx_use(0,nhx_seed(iters),iters)=1 + ihx_use(1,nhx_seed(iters),iters)=0 + nhx_use(iters)=nhx_use(iters)+1 + endif + if (avar_frag(i2,3).lt.nres.and. + & avar_frag(i2,5).lt.nres) then + ihx_seed(1,nhx_seed(iters),iters)=avar_frag(i2,3)+1 + ihx_seed(2,nhx_seed(iters),iters)=avar_frag(i2,5)+1 + ihx_use(0,nhx_seed(iters),iters)= + & ihx_use(0,nhx_seed(iters),iters)+1 + ihx_use(2,nhx_seed(iters),iters)=0 + nhx_use(iters)=nhx_use(iters)+1 + endif + endif + endif + endif + enddo + + nhx_tot=nhx_tot+nhx_use(iters) +cd write (iout,*) "debug N17",iters,nhx_seed(iters), +cd & nhx_use(iters),nhx_tot + enddo + + if (nhx_tot .ge. n17*nseed) then + ntot_gen=n17*nseed + else if (nhx_tot .ge. nseed) then + ntot_gen=(nhx_tot/nseed)*nseed + else + ntot_gen=nhx_tot + endif +cd write (iout,*) "debug N17==",ntot_gen,nhx_tot,nseed + + ngen=0 + do while (ngen.lt.ntot_gen) + do iters=1,nseed + iseed=is(iters) + if (nhx_use(iters).gt.0) then +cd write (iout,*) "debug N17",nhx_use(iters),ngen,ntot_gen +cd write (iout,*) "debugN17^", +cd & (ihx_use(0,k,iters),k=1,nhx_use(iters)) + nicht_getan=.true. + do while (nicht_getan) + iih=iran_num(1,nhx_seed(iters)) +cd write (iout,*) "debugN17^",iih + if (ihx_use(0,iih,iters).gt.0) then + iim=iran_num(1,2) +cd write (iout,*) "debugN17=",iih,nhx_seed(iters) +cd write (iout,*) "debugN17-",iim,'##', +cd & (ihx_use(k,iih,iters),k=0,2) +cd call flush(iout) + do while (ihx_use(iim,iih,iters).eq.1) + iim=iran_num(1,2) +cd write (iout,*) "debugN17-",iim,'##', +cd & (ihx_use(k,iih,iters),k=0,2) +cd call flush(iout) + enddo + nicht_getan=.false. + ihx_use(iim,iih,iters)=1 + ihx_use(0,iih,iters)=ihx_use(0,iih,iters)-1 + nhx_use(iters)=nhx_use(iters)-1 + endif + enddo + ngen=ngen+1 + index=index+1 + movenx(index)=17 + parent(1,index)=iseed + parent(2,index)=0 + + if (vdisulf) then + nss_in(index)=bvar_nss(iseed) + do ij=1,nss_in(index) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + endif + + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang_in(i,j,k,index)=bvar(i,j,k,iseed) + enddo + enddo + enddo + + if (iim.eq.1) then + idata(1,index)=ihx_seed(1,iih,iters) + idata(2,index)=ihx_seed(2,iih,iters) + else + idata(1,index)=ihx_seed(3,iih,iters) + idata(2,index)=ihx_seed(4,iih,iters) + endif + + if (ngen.eq.ntot_gen) goto 115 + endif + enddo + enddo + 115 continue + write (iout,*) "N17",n17," ngen/nseed",ngen/nseed, + & ngen,nseed + + + ENDIF +c----------------------------------------- +c N16 : slide non local beta in a seed by +/- 1 or +/- 2 +c + IF (n16.gt.0) THEN + nhx_tot=0 + do iters=1,nseed + i1=is(iters) + nhx_seed(iters)=0 + do i2=1,n7frag + if (bvar_frag(i2,1).eq.i1) then + nhx_seed(iters)=nhx_seed(iters)+1 + ihx_seed(1,nhx_seed(iters),iters)=bvar_frag(i2,3) + ihx_seed(2,nhx_seed(iters),iters)=bvar_frag(i2,4) + ihx_seed(3,nhx_seed(iters),iters)=bvar_frag(i2,5) + ihx_seed(4,nhx_seed(iters),iters)=bvar_frag(i2,6) + ihx_use(0,nhx_seed(iters),iters)=4 + do i3=1,4 + ihx_use(i3,nhx_seed(iters),iters)=0 + enddo + endif + enddo + nhx_use(iters)=4*nhx_seed(iters) + nhx_tot=nhx_tot+nhx_seed(iters) +cd write (iout,*) "debug N16",iters,nhx_seed(iters) + enddo + + if (4*nhx_tot .ge. n16*nseed) then + ntot_gen=n16*nseed + else if (4*nhx_tot .ge. nseed) then + ntot_gen=(4*nhx_tot/nseed)*nseed + else + ntot_gen=4*nhx_tot + endif + write (iout,*) "debug N16",ntot_gen,4*nhx_tot,nseed + + ngen=0 + do while (ngen.lt.ntot_gen) + do iters=1,nseed + iseed=is(iters) + if (nhx_use(iters).gt.0) then + nicht_getan=.true. + do while (nicht_getan) + iih=iran_num(1,nhx_seed(iters)) + if (ihx_use(0,iih,iters).gt.0) then + iim=iran_num(1,4) + do while (ihx_use(iim,iih,iters).eq.1) +cd write (iout,*) iim, +cd & ihx_use(0,iih,iters),ihx_use(iim,iih,iters) + iim=iran_num(1,4) + enddo + nicht_getan=.false. + ihx_use(iim,iih,iters)=1 + ihx_use(0,iih,iters)=ihx_use(0,iih,iters)-1 + nhx_use(iters)=nhx_use(iters)-1 + endif + enddo + ngen=ngen+1 + index=index+1 + movenx(index)=16 + parent(1,index)=iseed + parent(2,index)=0 + + if (vdisulf) then + nss_in(index)=bvar_nss(iseed) + do ij=1,nss_in(index) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + endif + + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang_in(i,j,k,index)=bvar(i,j,k,iseed) + enddo + enddo + enddo + + do i=1,4 + idata(i,index)=ihx_seed(i,iih,iters) + enddo + idata(5,index)=iim + + if (ngen.eq.ntot_gen) goto 116 + endif + enddo + enddo + 116 continue + write (iout,*) "N16",n16," ngen/nseed",ngen/nseed, + & ngen,nseed + ENDIF +c----------------------------------------- +c N15 : copy two 2nd structure elements from 1 or 2 conf. in bank to a seed +c + IF (n15.gt.0) THEN + + do iters=1,nseed + iseed=is(iters) + do i=1,mxio + ifused(i)=.false. + enddo + + do idummy=1,n15 + iter=0 + 84 continue + + iran=0 + iif=iran_num(1,n15frag) + do while( (ifused(iif) .or. svar_frag(iif,1).eq.iseed) .and. + & iran.le.mxio ) + iif=iran_num(1,n15frag) + iran=iran+1 + enddo + if(iran.ge.mxio) goto 811 + + iran=0 + iig=iran_num(1,n15frag) + do while( (ifused(iig) .or. svar_frag(iig,1).eq.iseed .or. + & .not.(svar_frag(iif,3).lt.svar_frag(iig,2).or. + & svar_frag(iig,3).lt.svar_frag(iif,2)) ) .and. + & iran.le.mxio ) + iig=iran_num(1,n15frag) + iran=iran+1 + enddo + if(iran.ge.mxio) goto 811 + + index=index+1 + movenx(index)=15 + parent(1,index)=iseed + parent(2,index)=svar_frag(iif,1) + parent(3,index)=svar_frag(iig,1) + + + if (vdisulf) then + nss_in(index)=bvar_nss(iseed) + do ij=1,nss_in(index) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + endif + + ifused(iif)=.true. + ifused(iig)=.true. + call newconf_copy(idum,dihang_in(1,1,1,index), + & svar_frag(iif,1),svar_frag(iif,2),svar_frag(iif,3)) + + do j=svar_frag(iig,2),svar_frag(iig,3) + do i=1,4 + dihang_in(i,j,1,index)=bvar(i,j,1,svar_frag(iig,1)) + enddo + enddo + + + if(iter.lt.10) then + call check_old(icheck,index) + if(icheck.eq.1) then + index=index-1 + ifused(iif)=.false. + goto 84 + endif + endif + + 811 continue + enddo + enddo + ENDIF + +c----------------------------------------- +c N14 local_move (Maurizio) for loops in a seed +c + IF (n14.gt.0) THEN + nlx_tot=0 + do iters=1,nseed + i1=is(iters) + nlx_seed(iters)=0 + do i2=1,n14frag + if (lvar_frag(i2,1).eq.i1) then + nlx_seed(iters)=nlx_seed(iters)+3 + ilx_seed(1,nlx_seed(iters),iters)=lvar_frag(i2,2) + ilx_seed(2,nlx_seed(iters),iters)=lvar_frag(i2,3) + ilx_use(nlx_seed(iters),iters)=3 + endif + enddo + nlx_use(iters)=nlx_seed(iters) + nlx_tot=nlx_tot+nlx_seed(iters) +cd write (iout,*) "debug N14",iters,nlx_seed(iters) + enddo + + if (nlx_tot .ge. n14*nseed) then + ntot_gen=n14*nseed + else + ntot_gen=(nlx_tot/nseed)*nseed + endif +cd write (iout,*) "debug N14",ntot_gen,n14frag,nseed + + ngen=0 + do while (ngen.lt.ntot_gen) + do iters=1,nseed + iseed=is(iters) + if (nlx_use(iters).gt.0) then + nicht_getan=.true. + do while (nicht_getan) + iih=iran_num(1,nlx_seed(iters)) + if (ilx_use(iih,iters).gt.0) then + nicht_getan=.false. + ilx_use(iih,iters)=ilx_use(iih,iters)-1 + nlx_use(iters)=nlx_use(iters)-1 + endif + enddo + ngen=ngen+1 + index=index+1 + movenx(index)=14 + parent(1,index)=iseed + parent(2,index)=0 + + idata(1,index)=ilx_seed(1,iih,iters) + idata(2,index)=ilx_seed(2,iih,iters) + + + if (vdisulf) then + nss_in(index)=bvar_nss(iseed) + do ij=1,nss_in(index) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + endif + + + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang_in(i,j,k,index)=bvar(i,j,k,iseed) + enddo + enddo + enddo + + if (ngen.eq.ntot_gen) goto 131 + endif + enddo + enddo + 131 continue +cd write (iout,*) "N14",n14," ngen/nseed",ngen/nseed, +cd & ngen,nseed + + ENDIF +c----------------------------------------- +c N9 : shift a helix in a seed +c + IF (n9.gt.0) THEN + nhx_tot=0 + do iters=1,nseed + i1=is(iters) + nhx_seed(iters)=0 + do i2=1,n8frag + if (hvar_frag(i2,1).eq.i1) then + nhx_seed(iters)=nhx_seed(iters)+1 + ihx_seed(1,nhx_seed(iters),iters)=hvar_frag(i2,2) + ihx_seed(2,nhx_seed(iters),iters)=hvar_frag(i2,3) + ihx_use(0,nhx_seed(iters),iters)=4 + do i3=1,4 + ihx_use(i3,nhx_seed(iters),iters)=0 + enddo + endif + enddo + nhx_use(iters)=4*nhx_seed(iters) + nhx_tot=nhx_tot+nhx_seed(iters) +cd write (iout,*) "debug N9",iters,nhx_seed(iters) + enddo + + if (4*nhx_tot .ge. n9*nseed) then + ntot_gen=n9*nseed + else + ntot_gen=(4*nhx_tot/nseed)*nseed + endif +cd write (iout,*) "debug N9",ntot_gen,n8frag,nseed + + ngen=0 + do while (ngen.lt.ntot_gen) + do iters=1,nseed + iseed=is(iters) + if (nhx_use(iters).gt.0) then + nicht_getan=.true. + do while (nicht_getan) + iih=iran_num(1,nhx_seed(iters)) + if (ihx_use(0,iih,iters).gt.0) then + iim=iran_num(1,4) + do while (ihx_use(iim,iih,iters).eq.1) +cd write (iout,*) iim, +cd & ihx_use(0,iih,iters),ihx_use(iim,iih,iters) + iim=iran_num(1,4) + enddo + nicht_getan=.false. + ihx_use(iim,iih,iters)=1 + ihx_use(0,iih,iters)=ihx_use(0,iih,iters)-1 + nhx_use(iters)=nhx_use(iters)-1 + endif + enddo + ngen=ngen+1 + index=index+1 + movenx(index)=9 + parent(1,index)=iseed + parent(2,index)=0 + + if (vdisulf) then + nss_in(index)=bvar_nss(iseed) + do ij=1,nss_in(index) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + endif + + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang_in(i,j,k,index)=bvar(i,j,k,iseed) + enddo + enddo + enddo + + jstart=max(nnt,ihx_seed(1,iih,iters)+1) + jend=min(nct,ihx_seed(2,iih,iters)) +cd write (iout,*) "debug N9",iters,iih,jstart,jend + if (iim.eq.1) then + ishift=-2 + else if (iim.eq.2) then + ishift=-1 + else if (iim.eq.3) then + ishift=1 + else if (iim.eq.4) then + ishift=2 + else + write (iout,*) 'CHUJ NASTAPIL: iim=',iim + call mpi_abort(mpi_comm_world,ierror,ierrcode) + endif + do j=jstart,jend + if (itype(j).eq.10) then + iang=2 + else + iang=4 + endif + do i=1,iang + if (j+ishift.ge.nnt.and.j+ishift.le.nct) + & dihang_in(i,j+ishift,1,index)=bvar(i,j,1,iseed) + enddo + enddo + if (ishift.gt.0) then + do j=0,ishift-1 + if (itype(jend+j).eq.10) then + iang=2 + else + iang=4 + endif + do i=1,iang + if (jend+j.ge.nnt.and.jend+j.le.nct) + & dihang_in(i,jstart+j,1,index)=bvar(i,jend+j,1,iseed) + enddo + enddo + else + do j=0,-ishift-1 + if (itype(jstart+j).eq.10) then + iang=2 + else + iang=4 + endif + do i=1,iang + if (jend+j.ge.nnt.and.jend+j.le.nct) + & dihang_in(i,jend+j,1,index)=bvar(i,jstart+j,1,iseed) + enddo + enddo + endif + if (ngen.eq.ntot_gen) goto 133 + endif + enddo + enddo + 133 continue +cd write (iout,*) "N9",n9," ngen/nseed",ngen/nseed, +cd & ngen,nseed + + ENDIF +c----------------------------------------- +c N8 : copy a helix from bank to seed +c + if (n8.gt.0) then + if (n8frag.lt.n8) then + write (iout,*) "N8: only ",n8frag,'helices' + n8c=n8frag + else + n8c=n8 + endif + + do iters=1,nseed + iseed=is(iters) + do i=1,mxio + ifused(i)=.false. + enddo + + + do idummy=1,n8c + iter=0 + 94 continue + iran=0 + iif=iran_num(1,n8frag) + do while( (ifused(iif) .or. hvar_frag(iif,1).eq.iseed) .and. + & iran.le.mxio ) + iif=iran_num(1,n8frag) + iran=iran+1 + enddo + + if(iran.ge.mxio) goto 911 + + index=index+1 + movenx(index)=8 + parent(1,index)=iseed + parent(2,index)=hvar_frag(iif,1) + + + if (vdisulf) then + nss_in(index)=bvar_nss(iseed) + do ij=1,nss_in(index) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + endif + + ifused(iif)=.true. + if (hvar_frag(iif,3)-hvar_frag(iif,2).le.6) then + call newconf_copy(idum,dihang_in(1,1,1,index), + & hvar_frag(iif,1),hvar_frag(iif,2),hvar_frag(iif,3)) + else + ih_start=iran_num(hvar_frag(iif,2),hvar_frag(iif,3)-6) + ih_end=iran_num(ih_start,hvar_frag(iif,3)) + call newconf_copy(idum,dihang_in(1,1,1,index), + & hvar_frag(iif,1),ih_start,ih_end) + endif + iter=iter+1 + if(iter.lt.10) then + call check_old(icheck,index) + if(icheck.eq.1) then + index=index-1 + ifused(iif)=.false. + goto 94 + endif + endif + + + 911 continue + + enddo + enddo + + endif + +c----------------------------------------- +c N7 : copy nonlocal beta fragment from bank to seed +c + if (n7.gt.0) then + if (n7frag.lt.n7) then + write (iout,*) "N7: only ",n7frag,'nonlocal fragments' + n7c=n7frag + else + n7c=n7 + endif + + do i=1,maxres + do j=1,mxio2 + iff_in(i,j)=0 + enddo + enddo + index2=0 + do i=1,mxio + isend2(i)=0 + enddo + + do iters=1,nseed + iseed=is(iters) + do i=1,mxio + ifused(i)=.false. + enddo + + do idummy=1,n7c + iran=0 + iif=iran_num(1,n7frag) + do while( (ifused(iif) .or. bvar_frag(iif,1).eq.iseed) .and. + & iran.le.mxio ) + iif=iran_num(1,n7frag) + iran=iran+1 + enddo + +cd write (*,'(3i5,l,4i5)'),iters,idummy,iif,ifused(iif), +cd & bvar_frag(iif,1),iseed,iran,index2 + + if(iran.ge.mxio) goto 999 + if(index2.ge.mxio2) goto 999 + + index=index+1 + movenx(index)=7 + parent(1,index)=iseed + parent(2,index)=bvar_frag(iif,1) + index2=index2+1 + isend2(index)=index2 + ifused(iif)=.true. + + if (vdisulf) then + nss_in(index)=bvar_nss(iseed) + do ij=1,nss_in(index) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + endif + + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang_in2(i,j,k,index2)=bvar(i,j,k,bvar_frag(iif,1)) + enddo + enddo + enddo + + if (bvar_frag(iif,2).eq.4) then + do i=bvar_frag(iif,3),bvar_frag(iif,4) + iff_in(i,index2)=1 + enddo + if (bvar_frag(iif,5).lt.bvar_frag(iif,6)) then +cd print *,'###',bvar_frag(iif,3),bvar_frag(iif,4), +cd & bvar_frag(iif,5),bvar_frag(iif,6) + do i=bvar_frag(iif,5),bvar_frag(iif,6) + iff_in(i,index2)=1 + enddo + else +cd print *,'###',bvar_frag(iif,3),bvar_frag(iif,4), +cd & bvar_frag(iif,6),bvar_frag(iif,5) + do i=bvar_frag(iif,6),bvar_frag(iif,5) + iff_in(i,index2)=1 + enddo + endif + endif + + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang_in(i,j,k,index)=bvar(i,j,k,iseed) + enddo + enddo + enddo + + + 999 continue + + enddo + enddo + + endif +c----------------------------------------------- +c N6 : copy random continues fragment from bank to seed +c + do iters=1,nseed + iseed=is(iters) + do idummy=1,n6 + isize=(is2-is1+1)*ran1(idum)+is1 + index=index+1 + movenx(index)=6 + + + if (vdisulf) then + nss_in(index)=bvar_nss(iseed) + do ij=1,nss_in(index) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + endif + + iter=0 + 104 continue + if(icycle.le.0) then + i1=nconf* ran1(idum)+1 + i1=nbank-nconf+i1 + else + i1=nbank* ran1(idum)+1 + endif + if(i1.eq.iseed) goto 104 + iter=iter+1 + call newconf_residue(idum,dihang_in(1,1,1,index),i1,isize) + parent(1,index)=iseed + parent(2,index)=i1 + if(iter.lt.10) then + call check_old(icheck,index) + if(icheck.eq.1) goto 104 + endif + enddo + enddo +c----------------------------------------- + if (n3.gt.0.or.n4.gt.0) call gen_hairpin + nconf_harp=0 + do iters=1,nseed + if (nharp_seed(iters).gt.0) nconf_harp=nconf_harp+1 + enddo +c----------------------------------------- +c N3 : copy hairpin from bank to seed +c + do iters=1,nseed + iseed=is(iters) + nsucc=0 + nacc=0 + do idummy=1,n3 + index=index+1 + iter=0 + 124 continue + if(icycle.le.0) then + i1=nconf* ran1(idum)+1 + i1=nbank-nconf+i1 + else + i1=nbank* ran1(idum)+1 + endif + if(i1.eq.iseed) goto 124 + do k=1,nsucc + if (i1.eq.iisucc(k).and.nsucc.lt.nconf_harp-1) goto 124 + enddo + nsucc=nsucc+1 + iisucc(nsucc)=i1 + iter=iter+1 + call newconf_residue_hairpin(idum,dihang_in(1,1,1,index), + & i1,fail) + if (fail) then + if (icycle.le.0 .and. nsucc.eq.nconf .or. + & icycle.gt.0 .and. nsucc.eq.nbank) then + index=index-1 + goto 125 + else + goto 124 + endif + endif + if(iter.lt.10) then + call check_old(icheck,index) + if(icheck.eq.1) goto 124 + endif + movenx(index)=3 + parent(1,index)=iseed + parent(2,index)=i1 + + + if (vdisulf) then + nss_in(index)=bvar_nss(iseed) + do ij=1,nss_in(index) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + endif + + nacc=nacc+1 + enddo +c if not enough hairpins, supplement with windows + 125 continue +cdd if (n3.ne.0) write (iout,*) "N3",n3," nsucc",nsucc," nacc",nacc + do idummy=nacc+1,n3 + isize=(is2-is1+1)*ran1(idum)+is1 + index=index+1 + movenx(index)=6 + parent(1,index)=iseed + parent(2,index)=i1 + + + if (vdisulf) then + nss_in(index)=bvar_nss(iseed) + do ij=1,nss_in(index) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + endif + + iter=0 + 114 continue + if(icycle.le.0) then + i1=nconf* ran1(idum)+1 + i1=nbank-nconf+i1 + else + i1=nbank* ran1(idum)+1 + endif + if(i1.eq.iseed) goto 114 + iter=iter+1 + call newconf_residue(idum,dihang_in(1,1,1,index),i1,isize) + if(iter.lt.10) then + call check_old(icheck,index) + if(icheck.eq.1) goto 114 + endif + enddo + enddo +c----------------------------------------- +c N4 : shift a turn in hairpin in seed +c + IF (N4.GT.0) THEN + if (4*nharp_tot .ge. n4*nseed) then + ntot_gen=n4*nseed + else + ntot_gen=(4*nharp_tot/nseed)*nseed + endif + ngen=0 + do while (ngen.lt.ntot_gen) + do iters=1,nseed + iseed=is(iters) +c write (iout,*) 'iters',iters,' iseed',iseed,' nharp_seed', +c & nharp_seed(iters),' nharp_use',nharp_use(iters), +c & ' ntot_gen',ntot_gen +c write (iout,*) 'iharp_use(0)', +c & (iharp_use(0,k,iters),k=1,nharp_seed(iters)) + if (nharp_use(iters).gt.0) then + nicht_getan=.true. + do while (nicht_getan) + iih=iran_num(1,nharp_seed(iters)) +c write (iout,*) 'iih',iih,' iharp_use', +c & (iharp_use(k,iih,iters),k=1,4) + if (iharp_use(0,iih,iters).gt.0) then + nicht_getan1=.true. + do while (nicht_getan1) + iim=iran_num(1,4) + nicht_getan1=iharp_use(iim,iih,iters).eq.1 + enddo + nicht_getan=.false. + iharp_use(iim,iih,iters)=1 + iharp_use(0,iih,iters)=iharp_use(0,iih,iters)-1 + nharp_use(iters)=nharp_use(iters)-1 +cdd write (iout,'(a16,i3,a5,i2,a10,2i4)') +cdd & 'N4 selected hairpin',iih,' move',iim,' iharp_seed', +cdd & iharp_seed(1,iih,iters),iharp_seed(2,iih,iters) + endif + enddo + ngen=ngen+1 + index=index+1 + movenx(index)=4 + parent(1,index)=iseed + parent(2,index)=0 + + + if (vdisulf) then + nss_in(index)=bvar_nss(iseed) + do ij=1,nss_in(index) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + endif + + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang_in(i,j,k,index)=bvar(i,j,k,iseed) + enddo + enddo + enddo + jstart=iharp_seed(1,iih,iters)+1 + jend=iharp_seed(2,iih,iters) + if (iim.eq.1) then + ishift=-2 + else if (iim.eq.2) then + ishift=-1 + else if (iim.eq.3) then + ishift=1 + else if (iim.eq.4) then + ishift=2 + else + write (iout,*) 'CHUJ NASTAPIL: iim=',iim + call mpi_abort(mpi_comm_world,ierror,ierrcode) + endif +c write (iout,*) 'jstart',jstart,' jend',jend,' ishift',ishift +c write (iout,*) 'Before turn shift' +c do j=2,nres-1 +c theta(j+1)=dihang_in(1,j,1,index) +c phi(j+2)=dihang_in(2,j,1,index) +c alph(j)=dihang_in(3,j,1,index) +c omeg(j)=dihang_in(4,j,1,index) +c enddo +c call intout + do j=jstart,jend + if (itype(j).eq.10) then + iang=2 + else + iang=4 + endif + do i=1,iang + if (j+ishift.ge.nnt.and.j+ishift.le.nct) + & dihang_in(i,j+ishift,1,index)=bvar(i,j,1,iseed) + enddo + enddo +c write (iout,*) 'After turn shift' +c do j=2,nres-1 +c theta(j+1)=dihang_in(1,j,1,index) +c phi(j+2)=dihang_in(2,j,1,index) +c alph(j)=dihang_in(3,j,1,index) +c omeg(j)=dihang_in(4,j,1,index) +c enddo +c call intout + if (ngen.eq.ntot_gen) goto 135 + endif + enddo + enddo +c if not enough hairpins, supplement with windows +c write (iout,*) 'end of enddo' + 135 continue +cdd write (iout,*) "N4",n4," ngen/nseed",ngen/nseed, +cdd & ngen,nseed + do iters=1,nseed + iseed=is(iters) + do idummy=ngen/nseed+1,n4 + isize=(is2-is1+1)*ran1(idum)+is1 + index=index+1 + movenx(index)=6 + + if (vdisulf) then + nss_in(index)=bvar_nss(iseed) + do ij=1,nss_in(index) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + endif + + + iter=0 + 134 continue + if(icycle.le.0) then + i1=nconf* ran1(idum)+1 + i1=nbank-nconf+i1 + else + i1=nbank* ran1(idum)+1 + endif + if(i1.eq.iseed) goto 134 + iter=iter+1 + call newconf_residue(idum,dihang_in(1,1,1,index),i1,isize) + parent(1,index)=iseed + parent(2,index)=i1 + if(iter.lt.10) then + call check_old(icheck,index) + if(icheck.eq.1) goto 134 + endif + enddo + enddo + ENDIF +c----------------------------------------- +c N5 : copy one residue from bank to seed (normally switched off - use N1) +c + do iters=1,nseed + iseed=is(iters) + isize=1 + do i=1,n5 + index=index+1 + movenx(index)=5 + + if (vdisulf) then + nss_in(index)=bvar_nss(iseed) + do ij=1,nss_in(index) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + endif + + + iter=0 + 105 continue + if(icycle.le.0) then + i1=nconf* ran1(idum)+1 + i1=nbank-nconf+i1 + else + i1=nbank* ran1(idum)+1 + endif + if(i1.eq.iseed) goto 105 + iter=iter+1 + call newconf_residue(idum,dihang_in(1,1,1,index),i1,isize) + parent(1,index)=iseed + parent(2,index)=i1 + if(iter.lt.10) then + call check_old(icheck,index) + if(icheck.eq.1) goto 105 + endif + enddo + enddo +c----------------------------------------- +c N2 : copy backbone of one residue from bank or first bank to seed +c (normally switched off - use N1) +c + do iters=1,nseed + iseed=is(iters) + do i=n2,1,-1 + if(icycle.le.0.and.iuse.gt.nconf-irr) then + iseed=ran1(idum)*nconf+1 + iseed=nbank-nconf+iseed + endif + index=index+1 + movenx(index)=2 + + if (vdisulf) then + nss_in(index)=bvar_nss(iseed) + do ij=1,nss_in(index) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + endif + + iter=0 + 102 i1= ran1(idum)*nbank+1 + if(i1.eq.iseed) goto 102 + iter=iter+1 + if(icycle.le.0.and.iuse.gt.nconf-irr) then + nran=mod(i-1,nran0)+3 + call newconf1arr(idum,dihang_in(1,1,1,index),nran,i1) + parent(1,index)=-iseed + parent(2,index)=-i1 + else if(icycle.le.0.and.iters.le.iuse) then + nran=mod(i-1,nran0)+1 + call newconf1abr(idum,dihang_in(1,1,1,index),nran,i1) + parent(1,index)=iseed + parent(2,index)=-i1 + else + nran=mod(i-1,nran1)+1 + if(ran1(idum).lt.0.5) then + call newconf1abr(idum,dihang_in(1,1,1,index),nran,i1) + parent(1,index)=iseed + parent(2,index)=-i1 + else + call newconf1abb(idum,dihang_in(1,1,1,index),nran,i1) + parent(1,index)=iseed + parent(2,index)=i1 + endif + endif + if(iter.lt.10) then + call check_old(icheck,index) + if(icheck.eq.1) goto 102 + endif + enddo + enddo +c----------------------------------------- +c N1 : copy backbone or sidechain of one residue from bank or +c first bank to seed +c + do iters=1,nseed + iseed=is(iters) + do i=n1,1,-1 + if(icycle.le.0.and.iuse.gt.nconf-irr) then + iseed=ran1(idum)*nconf+1 + iseed=nbank-nconf+iseed + endif + index=index+1 + movenx(index)=1 + + if (vdisulf) then + nss_in(index)=bvar_nss(iseed) + do ij=1,nss_in(index) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + endif + + iter=0 + 101 i1= ran1(idum)*nbank+1 + + if(i1.eq.iseed) goto 101 + iter=iter+1 + if(icycle.le.0.and.iuse.gt.nconf-irr) then + nran=mod(i-1,nran0)+3 + call newconf1rr(idum,dihang_in(1,1,1,index),nran,i1) + parent(1,index)=-iseed + parent(2,index)=-i1 + else if(icycle.le.0.and.iters.le.iuse) then + nran=mod(i-1,nran0)+1 + call newconf1br(idum,dihang_in(1,1,1,index),nran,i1) + parent(1,index)=iseed + parent(2,index)=-i1 + else + nran=mod(i-1,nran1)+1 + if(ran1(idum).lt.0.5) then + call newconf1br(idum,dihang_in(1,1,1,index),nran,i1) + parent(1,index)=iseed + parent(2,index)=-i1 + else + call newconf1bb(idum,dihang_in(1,1,1,index),nran,i1) + parent(1,index)=iseed + parent(2,index)=i1 + endif + endif + if(iter.lt.10) then + call check_old(icheck,index) + if(icheck.eq.1) goto 101 + endif + enddo + enddo +c----------------------------------------- +c N0 just all seeds +c + IF (n0.gt.0) THEN + do iters=1,nseed + iseed=is(iters) + index=index+1 + movenx(index)=0 + parent(1,index)=iseed + parent(2,index)=0 + + if (vdisulf) then + nss_in(index)=bvar_nss(iseed) + do ij=1,nss_in(index) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + endif + + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang_in(i,j,k,index)=bvar(i,j,k,iseed) + enddo + enddo + enddo + enddo + ENDIF +c----------------------------------------- + if (vdisulf) then + do iters=1,nseed + iseed=is(iters) + + do k=1,numch + do j=2,nres-1 + theta(j+1)=bvar(1,j,k,iseed) + phi(j+2)=bvar(2,j,k,iseed) + alph(j)=bvar(3,j,k,iseed) + omeg(j)=bvar(4,j,k,iseed) + enddo + enddo + call chainbuild + +cd write(iout,*) 'makevar DYNSS',iseed,'#',bvar_ns(iseed), +cd & (bvar_s(k,iseed),k=1,bvar_ns(iseed)), +cd & bvar_nss(iseed), +cd & (bvar_ss(1,k,iseed)-nres,'-', +cd & bvar_ss(2,k,iseed)-nres,k=1,bvar_nss(iseed)) + + do i1=1,bvar_ns(iseed) +c +c N10 fussion of free halfcysteines in seed +c first select CYS with distance < 7A +c + do j1=i1+1,bvar_ns(iseed) + if (dist(bvar_s(i1,iseed)+nres,bvar_s(j1,iseed)+nres) + & .lt.7.0.and. + & iabs(bvar_s(i1,iseed)-bvar_s(j1,iseed)).gt.3) then + + index=index+1 + movenx(index)=10 + parent(1,index)=iseed + parent(2,index)=0 + do ij=1,bvar_nss(iseed) + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + enddo + ij=bvar_nss(iseed)+1 + nss_in(index)=ij + iss_in(ij,index)=bvar_s(i1,iseed)+nres + jss_in(ij,index)=bvar_s(j1,iseed)+nres + +cd write(iout,*) 'makevar NSS0',index, +cd & dist(bvar_s(i1,iseed)+nres,bvar_s(j1,iseed)+nres), +cd & nss_in(index),iss_in(ij,index)-nres,'-',jss_in(ij,index)-nres + + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang_in(i,j,k,index)=bvar(i,j,k,iseed) + enddo + enddo + enddo + + endif + enddo +c +c N11 type I transdisulfidation +c + do j1=1,bvar_nss(iseed) + if (dist(bvar_s(i1,iseed)+nres,bvar_ss(1,j1,iseed)) + & .lt.7.0.and. + & iabs(bvar_s(i1,iseed)-(bvar_ss(1,j1,iseed)-nres)) + & .gt.3) then + + index=index+1 + movenx(index)=11 + parent(1,index)=iseed + parent(2,index)=0 + do ij=1,bvar_nss(iseed) + if (ij.ne.j1) then + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + endif + enddo + nss_in(index)=bvar_nss(iseed) + iss_in(j1,index)=bvar_s(i1,iseed)+nres + jss_in(j1,index)=bvar_ss(1,j1,iseed) + if (iss_in(j1,index).gt.jss_in(j1,index)) then + iss_in(j1,index)=bvar_ss(1,j1,iseed) + jss_in(j1,index)=bvar_s(i1,iseed)+nres + endif + +cd write(iout,*) 'makevar NSS1 #1',index, +cd & bvar_s(i1,iseed),bvar_ss(1,j1,iseed)-nres, +cd & dist(bvar_s(i1,iseed)+nres,bvar_ss(1,j1,iseed)), +cd & (iss_in(ij,index)-nres,'-',jss_in(ij,index)-nres, +cd & ij=1,nss_in(index)) + + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang_in(i,j,k,index)=bvar(i,j,k,iseed) + enddo + enddo + enddo + endif + if (dist(bvar_s(i1,iseed)+nres,bvar_ss(2,j1,iseed)) + & .lt.7.0.and. + & iabs(bvar_s(i1,iseed)-(bvar_ss(2,j1,iseed)-nres)) + & .gt.3) then + + index=index+1 + movenx(index)=11 + parent(1,index)=iseed + parent(2,index)=0 + do ij=1,bvar_nss(iseed) + if (ij.ne.j1) then + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + endif + enddo + nss_in(index)=bvar_nss(iseed) + iss_in(j1,index)=bvar_s(i1,iseed)+nres + jss_in(j1,index)=bvar_ss(2,j1,iseed) + if (iss_in(j1,index).gt.jss_in(j1,index)) then + iss_in(j1,index)=bvar_ss(2,j1,iseed) + jss_in(j1,index)=bvar_s(i1,iseed)+nres + endif + + +cd write(iout,*) 'makevar NSS1 #2',index, +cd & bvar_s(i1,iseed),bvar_ss(2,j1,iseed)-nres, +cd & dist(bvar_s(i1,iseed)+nres,bvar_ss(2,j1,iseed)), +cd & (iss_in(ij,index)-nres,'-',jss_in(ij,index)-nres, +cd & ij=1,nss_in(index)) + + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang_in(i,j,k,index)=bvar(i,j,k,iseed) + enddo + enddo + enddo + + endif + enddo + enddo + +c +c N12 type II transdisulfidation +c + do i1=1,bvar_nss(iseed) + do j1=i1+1,bvar_nss(iseed) + if (dist(bvar_ss(1,i1,iseed),bvar_ss(1,j1,iseed)) + & .lt.7.0.and. + & dist(bvar_ss(2,i1,iseed),bvar_ss(2,j1,iseed)) + & .lt.7.0.and. + & iabs(bvar_ss(1,i1,iseed)-bvar_ss(1,j1,iseed)) + & .gt.3.and. + & iabs(bvar_ss(2,i1,iseed)-bvar_ss(2,j1,iseed)) + & .gt.3) then + index=index+1 + movenx(index)=12 + parent(1,index)=iseed + parent(2,index)=0 + do ij=1,bvar_nss(iseed) + if (ij.ne.i1 .and. ij.ne.j1) then + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + endif + enddo + nss_in(index)=bvar_nss(iseed) + iss_in(i1,index)=bvar_ss(1,i1,iseed) + jss_in(i1,index)=bvar_ss(1,j1,iseed) + if (iss_in(i1,index).gt.jss_in(i1,index)) then + iss_in(i1,index)=bvar_ss(1,j1,iseed) + jss_in(i1,index)=bvar_ss(1,i1,iseed) + endif + iss_in(j1,index)=bvar_ss(2,i1,iseed) + jss_in(j1,index)=bvar_ss(2,j1,iseed) + if (iss_in(j1,index).gt.jss_in(j1,index)) then + iss_in(j1,index)=bvar_ss(2,j1,iseed) + jss_in(j1,index)=bvar_ss(2,i1,iseed) + endif + + +cd write(iout,*) 'makevar NSS2 #1',index, +cd & bvar_ss(1,i1,iseed)-nres,bvar_ss(1,j1,iseed)-nres, +cd & dist(bvar_ss(1,i1,iseed),bvar_ss(1,j1,iseed)), +cd & bvar_ss(2,i1,iseed)-nres,bvar_ss(2,j1,iseed)-nres, +cd & dist(bvar_ss(2,i1,iseed),bvar_ss(2,j1,iseed)), +cd & (iss_in(ij,index)-nres,'-',jss_in(ij,index)-nres, +cd & ij=1,nss_in(index)) + + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang_in(i,j,k,index)=bvar(i,j,k,iseed) + enddo + enddo + enddo + + endif + + if (dist(bvar_ss(1,i1,iseed),bvar_ss(2,j1,iseed)) + & .lt.7.0.and. + & dist(bvar_ss(2,i1,iseed),bvar_ss(1,j1,iseed)) + & .lt.7.0.and. + & iabs(bvar_ss(1,i1,iseed)-bvar_ss(2,j1,iseed)) + & .gt.3.and. + & iabs(bvar_ss(2,i1,iseed)-bvar_ss(1,j1,iseed)) + & .gt.3) then + index=index+1 + movenx(index)=12 + parent(1,index)=iseed + parent(2,index)=0 + do ij=1,bvar_nss(iseed) + if (ij.ne.i1 .and. ij.ne.j1) then + iss_in(ij,index)=bvar_ss(1,ij,iseed) + jss_in(ij,index)=bvar_ss(2,ij,iseed) + endif + enddo + nss_in(index)=bvar_nss(iseed) + iss_in(i1,index)=bvar_ss(1,i1,iseed) + jss_in(i1,index)=bvar_ss(2,j1,iseed) + if (iss_in(i1,index).gt.jss_in(i1,index)) then + iss_in(i1,index)=bvar_ss(2,j1,iseed) + jss_in(i1,index)=bvar_ss(1,i1,iseed) + endif + iss_in(j1,index)=bvar_ss(2,i1,iseed) + jss_in(j1,index)=bvar_ss(1,j1,iseed) + if (iss_in(j1,index).gt.jss_in(j1,index)) then + iss_in(j1,index)=bvar_ss(1,j1,iseed) + jss_in(j1,index)=bvar_ss(2,i1,iseed) + endif + + +cd write(iout,*) 'makevar NSS2 #2',index, +cd & bvar_ss(1,i1,iseed)-nres,bvar_ss(2,j1,iseed)-nres, +cd & dist(bvar_ss(1,i1,iseed),bvar_ss(2,j1,iseed)), +cd & bvar_ss(2,i1,iseed)-nres,bvar_ss(1,j1,iseed)-nres, +cd & dist(bvar_ss(2,i1,iseed),bvar_ss(1,j1,iseed)), +cd & (iss_in(ij,index)-nres,'-',jss_in(ij,index)-nres, +cd & ij=1,nss_in(index)) + + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang_in(i,j,k,index)=bvar(i,j,k,iseed) + enddo + enddo + enddo + + endif + + + enddo + enddo +c +c N13 removal of disulfide bond +c + if (bvar_nss(iseed).gt.0) then + i1=bvar_nss(iseed)*ran1(idum)+1 + + index=index+1 + movenx(index)=13 + parent(1,index)=iseed + parent(2,index)=0 + ij=0 + do j1=1,bvar_nss(iseed) + if (j1.ne.i1) then + ij=ij+1 + iss_in(ij,index)=bvar_ss(1,j1,iseed) + jss_in(ij,index)=bvar_ss(2,j1,iseed) + endif + enddo + nss_in(index)=bvar_nss(iseed)-1 + +cd write(iout,*) 'NSS3',index,i1, +cd & bvar_ss(1,i1,iseed)-nres,'=',bvar_ss(2,i1,iseed)-nres,'#', +cd & (iss_in(ij,index)-nres,'-',jss_in(ij,index)-nres, +cd & ij=1,nss_in(index)) + + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang_in(i,j,k,index)=bvar(i,j,k,iseed) + enddo + enddo + enddo + + endif + + enddo + endif +c----------------------------------------- + + + + if(index.ne.n) write(iout,*)'make_var : ntry=',index + + n=index +cd do ii=1,n +cd write (istat,*) "======== ii=",ii," the dihang array" +cd do i=1,nres +cd write (istat,'(i5,4f15.5)') i,(dihang_in(k,i,1,ii)*rad2deg,k=1,4) +cd enddo +cd enddo + return + end +ccccccccccccccccccccccccccccccccccccccccccccccccc +ccccccccccccccccccccccccccccccccccccccccccccccccc + subroutine check_old(icheck,n) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CSA' + include 'COMMON.BANK' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + data ctdif /10./ + data ctdiff /60./ + + i1=n + do i2=1,n-1 + diff=0.d0 + do m=1,numch + do j=2,nres-1 + do i=1,4 + dif=rad2deg*dabs(dihang_in(i,j,m,i1)-dihang_in(i,j,m,i2)) + if(dif.gt.180.0) dif=360.0-dif + if(dif.gt.ctdif) goto 100 + diff=diff+dif + if(diff.gt.ctdiff) goto 100 + enddo + enddo + enddo + icheck=1 + return + 100 continue + enddo + + icheck=0 + + return + end +ccccccccccccccccccccccccccccccccccccccccccccccccc +ccccccccccccccccccccccccccccccccccccccccccccccccc + subroutine newconf1rr(idum,vvar,nran,i1) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CSA' + include 'COMMON.BANK' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + real ran1,ran2 + dimension vvar(mxang,maxres,mxch),iold(ntotal) + ctdif=10. + + do k=1,numch + do j=2,nres-1 + do i=1,4 + vvar(i,j,k)=rvar(i,j,k,iseed) + enddo + enddo + enddo + + do index=1,nran + iold(index) = 0 + enddo + + number=ntotgr + + iter=0 + do index=1,nran + 10 iran= ran1(idum)*number+1 + if(iter.gt.number) return + iter=iter+1 + if(iter.eq.1) goto 11 + do ind=1,index-1 + if(iran.eq.iold(ind)) goto 10 + enddo + 11 continue + + do ind=1,ngroup(iran) + i=igroup(1,ind,iran) + j=igroup(2,ind,iran) + k=igroup(3,ind,iran) + dif=rad2deg*dabs(vvar(i,j,k)-rvar(i,j,k,i1)) + if(dif.gt.180.) dif=360.-dif + if(dif.gt.ctdif) goto 20 + enddo + if(iter.gt.number) goto 20 + goto 10 + 20 continue + do ind=1,ngroup(iran) + i=igroup(1,ind,iran) + j=igroup(2,ind,iran) + k=igroup(3,ind,iran) + vvar(i,j,k)=rvar(i,j,k,i1) + enddo + iold(index)=iran + enddo + + return + end +ccccccccccccccccccccccccccccccccccccccccccccccccc +ccccccccccccccccccccccccccccccccccccccccccccccccc + subroutine newconf1br(idum,vvar,nran,i1) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CSA' + include 'COMMON.BANK' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + include 'COMMON.TORCNSTR' + include 'COMMON.CONTROL' + real ran1,ran2 + dimension vvar(mxang,maxres,mxch),iold(ntotal) + ctdif=10. + + do k=1,numch + do j=2,nres-1 + do i=1,4 + vvar(i,j,k)=bvar(i,j,k,iseed) + enddo + enddo + enddo + + do index=1,nran + iold(index) = 0 + enddo + + number=ntotgr + + iter=0 + do index=1,nran + 10 iran= ran1(idum)*number+1 + if(i2ndstr.gt.0) then + rtmp=ran1(idum) + if(rtmp.le.rdih_bias) then + i=0 + do j=1,ndih_nconstr + if(igroup(2,1,iran).eq.idih_nconstr(j))i=j + enddo + if(i.eq.0) then + juhc=0 +4321 juhc=juhc+1 + iran= ran1(idum)*number+1 + i=0 + do j=1,ndih_nconstr + if(igroup(2,1,iran).eq.idih_nconstr(j))i=j + enddo + if(i.eq.0.or.juhc.lt.1000)goto 4321 + if(juhc.eq.1000) then + print *, 'move 6 : failed to find unconstrained group' + write(iout,*) 'move 6 : failed to find unconstrained group' + endif + endif + endif + endif + if(iter.gt.number) return + iter=iter+1 + if(iter.eq.1) goto 11 + do ind=1,index-1 + if(iran.eq.iold(ind)) goto 10 + enddo + 11 continue + + do ind=1,ngroup(iran) + i=igroup(1,ind,iran) + j=igroup(2,ind,iran) + k=igroup(3,ind,iran) + dif=rad2deg*dabs(vvar(i,j,k)-rvar(i,j,k,i1)) + if(dif.gt.180.) dif=360.-dif + if(dif.gt.ctdif) goto 20 + enddo + if(iter.gt.number) goto 20 + goto 10 + 20 continue + do ind=1,ngroup(iran) + i=igroup(1,ind,iran) + j=igroup(2,ind,iran) + k=igroup(3,ind,iran) + vvar(i,j,k)=rvar(i,j,k,i1) + enddo + iold(index)=iran + enddo + + return + end +ccccccccccccccccccccccccccccccccccccccccccccccccc +ccccccccccccccccccccccccccccccccccccccccccccccccc + subroutine newconf1bb(idum,vvar,nran,i1) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CSA' + include 'COMMON.BANK' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + real ran1,ran2 + dimension vvar(mxang,maxres,mxch),iold(ntotal) + ctdif=10. + + do k=1,numch + do j=2,nres-1 + do i=1,4 + vvar(i,j,k)=bvar(i,j,k,iseed) + enddo + enddo + enddo + + do index=1,nran + iold(index) = 0 + enddo + + number=ntotgr + + iter=0 + do index=1,nran + 10 iran= ran1(idum)*number+1 + if(iter.gt.number) return + iter=iter+1 + if(iter.eq.1) goto 11 + do ind=1,index-1 + if(iran.eq.iold(ind)) goto 10 + enddo + 11 continue + + do ind=1,ngroup(iran) + i=igroup(1,ind,iran) + j=igroup(2,ind,iran) + k=igroup(3,ind,iran) + dif=rad2deg*dabs(vvar(i,j,k)-bvar(i,j,k,i1)) + if(dif.gt.180.) dif=360.-dif + if(dif.gt.ctdif) goto 20 + enddo + if(iter.gt.number) goto 20 + goto 10 + 20 continue + do ind=1,ngroup(iran) + i=igroup(1,ind,iran) + j=igroup(2,ind,iran) + k=igroup(3,ind,iran) + vvar(i,j,k)=bvar(i,j,k,i1) + enddo + iold(index)=iran + enddo + + return + end +ccccccccccccccccccccccccccccccccccccccccccccccccc +ccccccccccccccccccccccccccccccccccccccccccccccccc + subroutine newconf1arr(idum,vvar,nran,i1) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CSA' + include 'COMMON.BANK' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + real ran1,ran2 + dimension vvar(mxang,maxres,mxch),iold(ntotal) + ctdif=10. + + do k=1,numch + do j=2,nres-1 + do i=1,4 + vvar(i,j,k)=rvar(i,j,k,iseed) + enddo + enddo + enddo + + do index=1,nran + iold(index) = 0 + enddo + + number=nres-2 + + iter=0 + do index=1,nran + 10 iran= ran1(idum)*number+1 + if(iter.gt.number) return + iter=iter+1 + if(iter.eq.1) goto 11 + do ind=1,index-1 + if(iran.eq.iold(ind)) goto 10 + enddo + 11 continue + + do ind=1,ngroup(iran) + i=igroup(1,ind,iran) + j=igroup(2,ind,iran) + k=igroup(3,ind,iran) + dif=rad2deg*dabs(vvar(i,j,k)-rvar(i,j,k,i1)) + if(dif.gt.180.) dif=360.-dif + if(dif.gt.ctdif) goto 20 + enddo + if(iter.gt.number) goto 20 + goto 10 + 20 continue + do ind=1,ngroup(iran) + i=igroup(1,ind,iran) + j=igroup(2,ind,iran) + k=igroup(3,ind,iran) + vvar(i,j,k)=rvar(i,j,k,i1) + enddo + iold(index)=iran + enddo + + return + end +ccccccccccccccccccccccccccccccccccccccccccccccccc +ccccccccccccccccccccccccccccccccccccccccccccccccc + subroutine newconf1abr(idum,vvar,nran,i1) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CSA' + include 'COMMON.BANK' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + include 'COMMON.TORCNSTR' + include 'COMMON.CONTROL' + real ran1,ran2 + dimension vvar(mxang,maxres,mxch),iold(ntotal) + ctdif=10. + + do k=1,numch + do j=2,nres-1 + do i=1,4 + vvar(i,j,k)=bvar(i,j,k,iseed) + enddo + enddo + enddo + + do index=1,nran + iold(index) = 0 + enddo + + number=nres-2 + + iter=0 + do index=1,nran + 10 iran= ran1(idum)*number+1 + if(i2ndstr.gt.0) then + rtmp=ran1(idum) + if(rtmp.le.rdih_bias) then + iran=ran1(idum)*ndih_nconstr+1 + iran=idih_nconstr(iran) + endif + endif + if(iter.gt.number) return + iter=iter+1 + if(iter.eq.1) goto 11 + do ind=1,index-1 + if(iran.eq.iold(ind)) goto 10 + enddo + 11 continue + + do ind=1,ngroup(iran) + i=igroup(1,ind,iran) + j=igroup(2,ind,iran) + k=igroup(3,ind,iran) + dif=rad2deg*dabs(vvar(i,j,k)-rvar(i,j,k,i1)) + if(dif.gt.180.) dif=360.-dif + if(dif.gt.ctdif) goto 20 + enddo + if(iter.gt.number) goto 20 + goto 10 + 20 continue + do ind=1,ngroup(iran) + i=igroup(1,ind,iran) + j=igroup(2,ind,iran) + k=igroup(3,ind,iran) + vvar(i,j,k)=rvar(i,j,k,i1) + enddo + iold(index)=iran + enddo + + return + end +ccccccccccccccccccccccccccccccccccccccccccccccccc +ccccccccccccccccccccccccccccccccccccccccccccccccc + subroutine newconf1abb(idum,vvar,nran,i1) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CSA' + include 'COMMON.BANK' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + include 'COMMON.TORCNSTR' + include 'COMMON.CONTROL' + real ran1,ran2 + dimension vvar(mxang,maxres,mxch),iold(ntotal) + ctdif=10. + + do k=1,numch + do j=2,nres-1 + do i=1,4 + vvar(i,j,k)=bvar(i,j,k,iseed) + enddo + enddo + enddo + + do index=1,nran + iold(index) = 0 + enddo + + number=nres-2 + + iter=0 + do index=1,nran + 10 iran= ran1(idum)*number+1 + if(i2ndstr.gt.0) then + rtmp=ran1(idum) + if(rtmp.le.rdih_bias) then + iran=ran1(idum)*ndih_nconstr+1 + iran=idih_nconstr(iran) + endif + endif + if(iter.gt.number) return + iter=iter+1 + if(iter.eq.1) goto 11 + do ind=1,index-1 + if(iran.eq.iold(ind)) goto 10 + enddo + 11 continue + + do ind=1,ngroup(iran) + i=igroup(1,ind,iran) + j=igroup(2,ind,iran) + k=igroup(3,ind,iran) + dif=rad2deg*dabs(vvar(i,j,k)-bvar(i,j,k,i1)) + if(dif.gt.180.) dif=360.-dif + if(dif.gt.ctdif) goto 20 + enddo + if(iter.gt.number) goto 20 + goto 10 + 20 continue + do ind=1,ngroup(iran) + i=igroup(1,ind,iran) + j=igroup(2,ind,iran) + k=igroup(3,ind,iran) + vvar(i,j,k)=bvar(i,j,k,i1) + enddo + iold(index)=iran + enddo + + return + end +ccccccccccccccccccccccccccccccccccccccccccccccccc +ccccccccccccccccccccccccccccccccccccccccccccccccc + subroutine newconf_residue(idum,vvar,i1,isize) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CSA' + include 'COMMON.BANK' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + include 'COMMON.TORCNSTR' + include 'COMMON.CONTROL' + real ran1,ran2 + dimension vvar(mxang,maxres,mxch),iold(ntotal) + ctdif=10. + + if (iseed.gt.mxio .or. iseed.lt.1) then + write (iout,*) 'Dimension ERROR in NEWCONF: ISEED',iseed + call mpi_abort(mpi_comm_world,ierror,ierrcode) + endif + do k=1,numch + do j=2,nres-1 + do i=1,4 + vvar(i,j,k)=bvar(i,j,k,iseed) + enddo + enddo + enddo + + + k=1 + number=nres+isize-2 + iter=1 + 10 iran= ran1(idum)*number+1 + if(i2ndstr.gt.0) then + rtmp=ran1(idum) + if(rtmp.le.rdih_bias) then + iran=ran1(idum)*ndih_nconstr+1 + iran=idih_nconstr(iran) + endif + endif + istart=iran-isize+1 + iend=iran + if(istart.lt.2) istart=2 + if(iend.gt.nres-1) iend=nres-1 + + if(iter.eq.1) goto 11 + do ind=1,iter-1 + if(iran.eq.iold(ind)) goto 10 + enddo + 11 continue + + do j=istart,iend + do i=1,4 + dif=rad2deg*dabs(vvar(i,j,k)-bvar(i,j,k,i1)) + if(dif.gt.180.) dif=360.-dif + if(dif.gt.ctdif) goto 20 + enddo + enddo + iold(iter)=iran + iter=iter+1 + if(iter.gt.number) goto 20 + goto 10 + + 20 continue + do j=istart,iend + do i=1,4 + vvar(i,j,k)=bvar(i,j,k,i1) + enddo + enddo + + return + end + +ccccccccccccccccccccccccccccccccccccccccccccccccc +ccccccccccccccccccccccccccccccccccccccccccccccccc + subroutine newconf_copy(idum,vvar,i1,istart,iend) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CSA' + include 'COMMON.BANK' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + include 'COMMON.TORCNSTR' + include 'COMMON.CONTROL' + real ran1,ran2 + dimension vvar(mxang,maxres,mxch),iold(ntotal) + ctdif=10. + + if (iseed.gt.mxio .or. iseed.lt.1) then + write (iout,*) 'Dimension ERROR in NEWCONF: ISEED',iseed + call mpi_abort(mpi_comm_world,ierror,ierrcode) + endif + do k=1,numch + do j=2,nres-1 + do i=1,4 + vvar(i,j,k)=bvar(i,j,k,iseed) + enddo + enddo + enddo + + + do j=istart,iend + do i=1,4 + vvar(i,j,1)=bvar(i,j,1,i1) + enddo + enddo + + return + end +ccccccccccccccccccccccccccccccccccccccccccccccccc +ccccccccccccccccccccccccccccccccccccccccccccccccc + subroutine newconf_residue_hairpin(idum,vvar,i1,fail) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CSA' + include 'COMMON.BANK' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + include 'COMMON.VAR' + real ran1,ran2 + dimension vvar(mxang,maxres,mxch),iold(ntotal) + integer nharp,iharp(4,maxres/3),icipa(maxres/3) + logical fail,not_done + ctdif=10. + + fail=.false. + if (iseed.gt.mxio .or. iseed.lt.1) then + write (iout,*) 'Dimension ERROR in NEWCONF: ISEED',iseed + call mpi_abort(mpi_comm_world,ierror,ierrcode) + endif + do k=1,numch + do j=2,nres-1 + do i=1,4 + vvar(i,j,k)=bvar(i,j,k,iseed) + enddo + enddo + enddo + do k=1,numch + do j=2,nres-1 + theta(j+1)=bvar(1,j,k,i1) + phi(j+2)=bvar(2,j,k,i1) + alph(j)=bvar(3,j,k,i1) + omeg(j)=bvar(4,j,k,i1) + enddo + enddo +c call intout + call chainbuild + call hairpin(.false.,nharp,iharp) + + if (nharp.eq.0) then + fail=.true. + return + endif + + n_used=0 + + DO III=1,NHARP + + not_done = .true. + icount=0 + do while (not_done) + icount=icount+1 + iih=iran_num(1,nharp) + do k=1,n_used + if (iih.eq.icipa(k)) then + iih=0 + goto 22 + endif + enddo + not_done=.false. + n_used=n_used+1 + icipa(n_used)=iih + 22 continue + not_done = not_done .and. icount.le.nharp + enddo + + if (iih.eq.0) then + write (iout,*) "CHUJ NASTAPIL W NEWCONF_RESIDUE_HAIRPIN!!!!" + fail=.true. + return + endif + + istart=iharp(1,iih)+1 + iend=iharp(2,iih) + +cdd write (iout,*) "newconf_residue_hairpin: iih",iih, +cdd & " istart",istart," iend",iend + + do k=1,numch + do j=istart,iend + do i=1,4 + dif=rad2deg*dabs(vvar(i,j,k)-bvar(i,j,k,i1)) + if(dif.gt.180.) dif=360.-dif + if(dif.gt.ctdif) goto 20 + enddo + enddo + enddo + goto 10 + 20 continue + do k=1,numch + do j=istart,iend + do i=1,4 + vvar(i,j,k)=bvar(i,j,k,i1) + enddo + enddo + enddo +c do j=1,numch +c do l=2,nres-1 +c write (iout,'(4f8.3)') (rad2deg*vvar(i,l,j),i=1,4) +c enddo +c enddo + return + 10 continue + ENDDO + + fail=.true. + + return + end +ccccccccccccccccccccccccccccccccccccccccccccccccc +ccccccccccccccccccccccccccccccccccccccccccccccccc + subroutine gen_hairpin + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CSA' + include 'COMMON.BANK' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.HAIRPIN' + +c write (iout,*) 'Entering GEN_HAIRPIN' + do iters=1,nseed + i1=is(iters) + do k=1,numch + do j=2,nres-1 + theta(j+1)=bvar(1,j,k,i1) + phi(j+2)=bvar(2,j,k,i1) + alph(j)=bvar(3,j,k,i1) + omeg(j)=bvar(4,j,k,i1) + enddo + enddo + call chainbuild + call hairpin(.false.,nharp_seed(iters),iharp_seed(1,1,iters)) + enddo + + nharp_tot=0 + do iters=1,nseed + nharp_tot=nharp_tot+nharp_seed(iters) + nharp_use(iters)=4*nharp_seed(iters) + do j=1,nharp_seed(iters) + iharp_use(0,j,iters)=4 + do k=1,4 + iharp_use(k,j,iters)=0 + enddo + enddo + enddo + + write (iout,*) 'GEN_HAIRPIN: nharp_tot',nharp_tot +cdd do i=1,nseed +cdd write (iout,*) 'seed',i +cdd write (iout,*) 'nharp_seed',nharp_seed(i), +cdd & ' nharp_use',nharp_use(i) +cd write (iout,*) 'iharp_seed, iharp_use' +cd do j=1,nharp_seed(i) +cd write (iout,'(7i3)') iharp_seed(1,j,i),iharp_seed(2,j,i), +cd & (iharp_use(k,j,i),k=0,4) +cd enddo +cdd enddo + return + end + +ccccccccccccccccccccccccccccccccccccccccccccccccc +ccccccccccccccccccccccccccccccccccccccccccccccccc + subroutine select_frag(nn,nh,nl,ns,nb,i_csa) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CSA' + include 'COMMON.BANK' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.HAIRPIN' + include 'COMMON.DISTFIT' + character*50 linia + integer isec(maxres) + + + nn=0 + nh=0 + nl=0 + ns=0 + nb=0 +cd write (iout,*) 'Entering select_frag' + do i1=1,nbank + do i=1,nres + isec(i)=0 + enddo + do k=1,numch + do j=2,nres-1 + theta(j+1)=bvar(1,j,k,i1) + phi(j+2)=bvar(2,j,k,i1) + alph(j)=bvar(3,j,k,i1) + omeg(j)=bvar(4,j,k,i1) + enddo + enddo + call chainbuild +cd write (iout,*) ' -- ',i1,' -- ' + call secondary2(.false.) +c +c bvar_frag nn==pair of nonlocal strands in beta sheet (loop>4) +c strands > 4 residues; used by N7 and N16 +c + do j=1,nbfrag +c +Ctest 09/12/02 bfrag(2,j)-bfrag(1,j).gt.3 +c + do i=bfrag(1,j),bfrag(2,j) + isec(i)=1 + enddo + do i=bfrag(4,j),bfrag(3,j),sign(1,bfrag(3,j)-bfrag(4,j)) + isec(i)=1 + enddo + + if ( (bfrag(3,j).lt.bfrag(4,j) .or. + & bfrag(4,j)-bfrag(2,j).gt.4) .and. + & bfrag(2,j)-bfrag(1,j).gt.4 ) then + nn=nn+1 + + + if (bfrag(3,j).lt.bfrag(4,j)) then + write(linia,'(a6,i3,a1,i3,a1,i3,a1,i3)') + & "select",bfrag(1,j)-1,"-",bfrag(2,j)-1 + & ,",",bfrag(3,j)-1,"-",bfrag(4,j)-1 + else + write(linia,'(a6,i3,a1,i3,a1,i3,a1,i3)') + & "select",bfrag(1,j)-1,"-",bfrag(2,j)-1 + & ,",",bfrag(4,j)-1,"-",bfrag(3,j)-1 + + endif +cd call write_pdb(i_csa*1000+nn+nh,linia,0d0) + + bvar_frag(nn,1)=i1 + bvar_frag(nn,2)=4 + do i=1,4 + bvar_frag(nn,i+2)=bfrag(i,j) + enddo + endif + enddo + +c +c hvar_frag nh==helices; used by N8 and N9 +c + do j=1,nhfrag + + do i=hfrag(1,j),hfrag(2,j) + isec(i)=2 + enddo + + if ( hfrag(2,j)-hfrag(1,j).gt.4 ) then + nh=nh+1 + +cd write(linia,'(a6,i3,a1,i3)') +cd & "select",hfrag(1,j)-1,"-",hfrag(2,j)-1 +cd call write_pdb(i_csa*1000+nn+nh,linia,0d0) + + hvar_frag(nh,1)=i1 + hvar_frag(nh,2)=hfrag(1,j) + hvar_frag(nh,3)=hfrag(2,j) + endif + enddo + + +cv write(iout,'(i4,1pe12.4,1x,1000i1)') +cv & i1,bene(i1),(isec(i),i=1,nres) +cv write(linia,'(i4,1x,1000i1)') +cv & i1,(isec(i),i=1,nres) +cv call write_pdb(i_csa*1000+i1,linia,bene(i1)) +c +c lvar_frag nl==loops; used by N14 +c + i=1 + nl1=nl + do while (i.lt.nres) + if (isec(i).eq.0) then + nl=nl+1 + lvar_frag(nl,1)=i1 + lvar_frag(nl,2)=i + i=i+1 + do while (isec(i).eq.0.and.i.le.nres) + i=i+1 + enddo + lvar_frag(nl,3)=i-1 + if (lvar_frag(nl,3)-lvar_frag(nl,2).lt.1) nl=nl-1 + endif + i=i+1 + enddo +cd write(iout,'(4i5)') (i,(lvar_frag(i,ii),ii=1,3),i=nl1+1,nl) + +c +c svar_frag ns==an secondary structure element; used by N15 +c + i=1 + ns1=ns + do while (i.lt.nres) + if (isec(i).gt.0) then + ns=ns+1 + svar_frag(ns,1)=i1 + svar_frag(ns,2)=i + i=i+1 + do while (isec(i).gt.0.and.isec(i-1).eq.isec(i) + & .and.i.le.nres) + i=i+1 + enddo + svar_frag(ns,3)=i-1 + if (svar_frag(ns,3)-svar_frag(ns,2).lt.1) ns=ns-1 + endif + if (isec(i).eq.0) i=i+1 + enddo +cd write(iout,'(4i5)') (i,(svar_frag(i,ii),ii=1,3),i=ns1+1,ns) + +c +c avar_frag nb==any pair of beta strands; used by N17 +c + do j=1,nbfrag + nb=nb+1 + avar_frag(nb,1)=i1 + do i=1,4 + avar_frag(nb,i+1)=bfrag(i,j) + enddo + enddo + + enddo + + return + end +#endif diff --git a/source/unres/src_CSA_DiL/parmread.F b/source/unres/src_CSA_DiL/parmread.F new file mode 100644 index 0000000..5a7b99f --- /dev/null +++ b/source/unres/src_CSA_DiL/parmread.F @@ -0,0 +1,1006 @@ + 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 + write (2,*) "End reading THETA_PDB" + enddo + 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 +C 5/21/07 (AL) Read coefficients of the backbone-local sidechain-local +C correlation energies. +C + read (isccor,*,end=119,err=119) nterm_sccor + do i=1,20 + do j=1,20 + read (isccor,'(a)') + do k=1,nterm_sccor + read (isccor,*,end=119,err=119) kk,v1sccor(k,i,j), + & v2sccor(k,i,j) + enddo + enddo + enddo + close (isccor) + if (lprint) then + write (iout,'(/a/)') 'Torsional constants of SCCORR:' + do i=1,20 + do j=1,20 + write (iout,*) 'ityp',i,' jtyp',j + do k=1,nterm_sccor + write (iout,'(2(1pe15.5))') v1sccor(k,i,j),v2sccor(k,i,j) + enddo + enddo + enddo + endif +C +C 9/18/99 (AL) Read coefficients of the Fourier expansion of the local +C interaction energy of the Gly, Ala, and Pro prototypes. +C + 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 diff --git a/source/unres/src_CSA_DiL/pinorm.f b/source/unres/src_CSA_DiL/pinorm.f new file mode 100644 index 0000000..91392bf --- /dev/null +++ b/source/unres/src_CSA_DiL/pinorm.f @@ -0,0 +1,17 @@ + double precision function pinorm(x) + implicit real*8 (a-h,o-z) +c +c this function takes an angle (in radians) and puts it in the range of +c -pi to +pi. +c + integer n + include 'COMMON.GEO' + n = x / dwapi + pinorm = x - n * dwapi + if ( pinorm .gt. pi ) then + pinorm = pinorm - dwapi + else if ( pinorm .lt. - pi ) then + pinorm = pinorm + dwapi + end if + return + end diff --git a/source/unres/src_CSA_DiL/printmat.f b/source/unres/src_CSA_DiL/printmat.f new file mode 100644 index 0000000..be2b38f --- /dev/null +++ b/source/unres/src_CSA_DiL/printmat.f @@ -0,0 +1,16 @@ + subroutine printmat(ldim,m,n,iout,key,a) + character*3 key(n) + double precision a(ldim,n) + do 1 i=1,n,8 + nlim=min0(i+7,n) + write (iout,1000) (key(k),k=i,nlim) + write (iout,1020) + 1000 format (/5x,8(6x,a3)) + 1020 format (/80(1h-)/) + do 2 j=1,n + write (iout,1010) key(j),(a(j,k),k=i,nlim) + 2 continue + 1 continue + 1010 format (a3,2x,8(f9.4)) + return + end diff --git a/source/unres/src_CSA_DiL/prng_32.F b/source/unres/src_CSA_DiL/prng_32.F new file mode 100644 index 0000000..9448f31 --- /dev/null +++ b/source/unres/src_CSA_DiL/prng_32.F @@ -0,0 +1,1077 @@ +#if defined(AIX) || defined(AMD64) + real*8 function prng_next(mel) + implicit none + integer me,mel +c +c Calling sequence: +c = prng_next ( ) +c = vprng ( , , ) +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 = prng_next ( ) +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 diff --git a/source/unres/src_CSA_DiL/ran.f b/source/unres/src_CSA_DiL/ran.f new file mode 100644 index 0000000..dd23252 --- /dev/null +++ b/source/unres/src_CSA_DiL/ran.f @@ -0,0 +1,128 @@ +ccccccccccccccccccccccccccccccccccccccccccccccccc + FUNCTION ran0(idum) + INTEGER idum,IA,IM,IQ,IR,MASK + REAL ran0,AM + PARAMETER (IA=16807,IM=2147483647,AM=1./IM,IQ=127773,IR=2836, + *MASK=123459876) + INTEGER k + idum=ieor(idum,MASK) + k=idum/IQ + idum=IA*(idum-k*IQ)-IR*k + if (idum.lt.0) idum=idum+IM + ran0=AM*idum + idum=ieor(idum,MASK) + return + END +C (C) Copr. 1986-92 Numerical Recipes Software *11915 +ccccccccccccccccccccccccccccccccccccccccccccccccc + FUNCTION ran1(idum) + INTEGER idum,IA,IM,IQ,IR,NTAB,NDIV + REAL ran1,AM,EPS,RNMX + PARAMETER (IA=16807,IM=2147483647,AM=1./IM,IQ=127773,IR=2836, + *NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=1.2e-7,RNMX=1.-EPS) + INTEGER j,k,iv(NTAB),iy + SAVE iv,iy + DATA iv /NTAB*0/, iy /0/ + if (idum.le.0.or.iy.eq.0) then + idum=max(-idum,1) + do 11 j=NTAB+8,1,-1 + k=idum/IQ + idum=IA*(idum-k*IQ)-IR*k + if (idum.lt.0) idum=idum+IM + if (j.le.NTAB) iv(j)=idum +11 continue + iy=iv(1) + endif + k=idum/IQ + idum=IA*(idum-k*IQ)-IR*k + if (idum.lt.0) idum=idum+IM + j=1+iy/NDIV + iy=iv(j) + iv(j)=idum + ran1=min(AM*iy,RNMX) + return + END +C (C) Copr. 1986-92 Numerical Recipes Software *11915 +ccccccccccccccccccccccccccccccccccccccccccccccccc + FUNCTION ran2(idum) + INTEGER idum,IM1,IM2,IMM1,IA1,IA2,IQ1,IQ2,IR1,IR2,NTAB,NDIV + REAL ran2,AM,EPS,RNMX + PARAMETER (IM1=2147483563,IM2=2147483399,AM=1./IM1,IMM1=IM1-1, + *IA1=40014,IA2=40692,IQ1=53668,IQ2=52774,IR1=12211,IR2=3791, + *NTAB=32,NDIV=1+IMM1/NTAB,EPS=1.2e-7,RNMX=1.-EPS) + INTEGER idum2,j,k,iv(NTAB),iy + SAVE iv,iy,idum2 + DATA idum2/123456789/, iv/NTAB*0/, iy/0/ + if (idum.le.0) then + idum=max(-idum,1) + idum2=idum + do 11 j=NTAB+8,1,-1 + k=idum/IQ1 + idum=IA1*(idum-k*IQ1)-k*IR1 + if (idum.lt.0) idum=idum+IM1 + if (j.le.NTAB) iv(j)=idum +11 continue + iy=iv(1) + endif + k=idum/IQ1 + idum=IA1*(idum-k*IQ1)-k*IR1 + if (idum.lt.0) idum=idum+IM1 + k=idum2/IQ2 + idum2=IA2*(idum2-k*IQ2)-k*IR2 + if (idum2.lt.0) idum2=idum2+IM2 + j=1+iy/NDIV + iy=iv(j)-idum2 + iv(j)=idum + if(iy.lt.1)iy=iy+IMM1 + ran2=min(AM*iy,RNMX) + return + END +C (C) Copr. 1986-92 Numerical Recipes Software *11915 +ccccccccccccccccccccccccccccccccccccccccccccccccc + FUNCTION ran3(idum) + INTEGER idum + INTEGER MBIG,MSEED,MZ +C REAL MBIG,MSEED,MZ + REAL ran3,FAC + PARAMETER (MBIG=1000000000,MSEED=161803398,MZ=0,FAC=1./MBIG) +C PARAMETER (MBIG=4000000.,MSEED=1618033.,MZ=0.,FAC=1./MBIG) + INTEGER i,iff,ii,inext,inextp,k + INTEGER mj,mk,ma(55) +C REAL mj,mk,ma(55) + SAVE iff,inext,inextp,ma + DATA iff /0/ + if(idum.lt.0.or.iff.eq.0)then + iff=1 + mj=MSEED-iabs(idum) + mj=mod(mj,MBIG) + ma(55)=mj + mk=1 + do 11 i=1,54 + ii=mod(21*i,55) + ma(ii)=mk + mk=mj-mk + if(mk.lt.MZ)mk=mk+MBIG + mj=ma(ii) +11 continue + do 13 k=1,4 + do 12 i=1,55 + ma(i)=ma(i)-ma(1+mod(i+30,55)) + if(ma(i).lt.MZ)ma(i)=ma(i)+MBIG +12 continue +13 continue + inext=0 + inextp=31 + idum=1 + endif + inext=inext+1 + if(inext.eq.56)inext=1 + inextp=inextp+1 + if(inextp.eq.56)inextp=1 + mj=ma(inext)-ma(inextp) + if(mj.lt.MZ)mj=mj+MBIG + ma(inext)=mj + ran3=mj*FAC + return + END +C (C) Copr. 1986-92 Numerical Recipes Software *11915 +ccccccccccccccccccccccccccccccccccccccccccccccccc diff --git a/source/unres/src_CSA_DiL/randgens.f b/source/unres/src_CSA_DiL/randgens.f new file mode 100644 index 0000000..0daeb35 --- /dev/null +++ b/source/unres/src_CSA_DiL/randgens.f @@ -0,0 +1,99 @@ +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 diff --git a/source/unres/src_CSA_DiL/readpdb.F b/source/unres/src_CSA_DiL/readpdb.F new file mode 100644 index 0000000..dacd12d --- /dev/null +++ b/source/unres/src_CSA_DiL/readpdb.F @@ -0,0 +1,410 @@ + 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' +c include "mpif.h" + 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' +c include "mpif.h" + 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 + diff --git a/source/unres/src_CSA_DiL/readrtns_csa.F b/source/unres/src_CSA_DiL/readrtns_csa.F new file mode 100644 index 0000000..17b2165 --- /dev/null +++ b/source/unres/src_CSA_DiL/readrtns_csa.F @@ -0,0 +1,1911 @@ + 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 +c if (modecalc.eq.3 .or. modecalc.eq.6) call mcmread +C Read MD control parameters if reqjuired +c if (modecalc.eq.12) call read_MDpar +C Read MREMD control parameters if required +c if (modecalc.eq.14) then +c call read_MDpar +c call read_REMDpar +c endif +C Read MUCA control parameters if required +c if (lmuca) call read_muca +C Read CSA control parameters if required (from fort.40 if exists +C otherwise from general input file) + if (modecalc.eq.8) then + inquire (file="fort.40",exist=file_exist) + if (.not.file_exist) call csaread + 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,f10.5)') i-nss,ihpb(i),jhpb(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' +c include 'COMMON.THREAD' + include 'COMMON.SBRIDGE' + include 'COMMON.CONTROL' + include 'COMMON.MCM' +c include 'COMMON.MAP' + include 'COMMON.HEADER' +c include 'COMMON.CSA' + include 'COMMON.CHAIN' +c include 'COMMON.MUCA' +c 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,0) + 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 + 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 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' +c include 'COMMON.DBASE' +c include 'COMMON.THREAD' + include 'COMMON.CONTACTS' + include 'COMMON.TORCNSTR' + include 'COMMON.TIME1' + include 'COMMON.BOUNDS' +c include 'COMMON.MD' +c 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. + + 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) +C Juyong + call reada(weightcard,'WDFAD',wdfa_dist,0.0d0) + call reada(weightcard,'WDFAT',wdfa_tor,0.0d0) + call reada(weightcard,'WDFAN',wdfa_nei,0.0d0) + call reada(weightcard,'WDFAB',wdfa_beta,0.0d0) +C + 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 +C JUYONG + weights(24)=wdfa_dist + weights(25)=wdfa_tor + weights(26)=wdfa_nei + weights(27)=wdfa_beta +C + + 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, + & wdfa_dist,wdfa_tor,wdfa_nei,wdfa_beta + + 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)'/ + & 'WDFA_D= ',f10.6,' (DFA, distance)' / + & 'WDFA_T= ',f10.6,' (DFA, torsional)' / + & 'WDFA_N= ',f10.6,' (DFA, number of neighbor)' / + & 'WDFA_B= ',f10.6,' (DFA, beta formation)') + + 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 +c 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, + & wdfa_dist,wdfa_tor,wdfa_nei,wdfa_beta + + 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)'/ + & 'WDFA_D= ',f10.6,' (DFA, distance)' / + & 'WDFA_T= ',f10.6,' (DFA, torsional)' / + & 'WDFA_N= ',f10.6,' (DFA, number of neighbor)' / + & 'WDFA_B= ',f10.6,' (DFA, beta formation)') + + 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) +c 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 + +C Juyong:READ init_vars +C Initialize variables! +C Juyong:READ read_info +C READ fragment information!! +C both routines should be in dfa.F file!! + + if (.not. (wdfa_dist.eq.0.0 .and. wdfa_tor.eq.0.0 .and. + & wdfa_nei.eq.0.0 .and. wdfa_beta.eq.0.0)) then + call init_dfa_vars + print*, 'init_dfa_vars finished!' + call read_dfa_info + print*, 'read_dfa_info finished!' + endif +C +C + + + 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 +c write (iout,*) "constr_dist",constr_dist,nstart_sup,nsup + call flush(iout) + if (constr_dist.gt.0) call read_dist_constr +c write (iout,*) "After read_dist_constr nhpb",nhpb + call hpb_partition + 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 + 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 +c 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 + do itrial=1,100 + itmp=1 +c call gen_rand_conf(itmp,*31) + goto 40 + 31 write (iout,*) 'Failed to generate random conformation', + & ', itrial=',itrial + write (*,*) 'Failed to generate random conformation', + & ', itrial=',itrial + enddo + write (iout,'(a,i3,a)') 'Processor:',me, + & ' error in generating random conformation.' + write (*,'(a,i3,a)') 'Processor:',me, + & ' error in generating random conformation.' + stop + 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 +c 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' +c include 'COMMON.DBASE' +c 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 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' +c include 'COMMON.DBASE' +c 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' +c include 'COMMON.DBASE' +c 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 csaread + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.CSA' + include 'COMMON.BANK' + include 'COMMON.CONTROL' + character*80 ucase + character*620 mcmcard + call card_concat(mcmcard) + + call readi(mcmcard,'NCONF',nconf,50) + call readi(mcmcard,'NADD',nadd,0) + call readi(mcmcard,'JSTART',jstart,1) + call readi(mcmcard,'JEND',jend,1) + call readi(mcmcard,'NSTMAX',nstmax,500000) + call readi(mcmcard,'N0',n0,1) + call readi(mcmcard,'N1',n1,6) + call readi(mcmcard,'N2',n2,4) + call readi(mcmcard,'N3',n3,0) + call readi(mcmcard,'N4',n4,0) + call readi(mcmcard,'N5',n5,0) + call readi(mcmcard,'N6',n6,10) + call readi(mcmcard,'N7',n7,0) + call readi(mcmcard,'N8',n8,0) + call readi(mcmcard,'N9',n9,0) + call readi(mcmcard,'N14',n14,0) + call readi(mcmcard,'N15',n15,0) + call readi(mcmcard,'N16',n16,0) + call readi(mcmcard,'N17',n17,0) + call readi(mcmcard,'N18',n18,0) + + vdisulf=(index(mcmcard,'DYNSS').gt.0) + + call readi(mcmcard,'NDIFF',ndiff,2) + call reada(mcmcard,'DIFFCUT',diffcut,0.0d0) + call readi(mcmcard,'IS1',is1,1) + call readi(mcmcard,'IS2',is2,8) + call readi(mcmcard,'NRAN0',nran0,4) + call readi(mcmcard,'NRAN1',nran1,2) + call readi(mcmcard,'IRR',irr,1) + call readi(mcmcard,'NSEED',nseed,20) + call readi(mcmcard,'NTOTAL',ntotal,10000) + call reada(mcmcard,'CUT1',cut1,2.0d0) + call reada(mcmcard,'CUT2',cut2,5.0d0) + call reada(mcmcard,'ESTOP',estop,-300000.0d0) + call readi(mcmcard,'ICMAX',icmax,1) + call readi(mcmcard,'NBANKM',nbankm,400) + call readi(mcmcard,'IUCUT',iucut,2) + call readi(mcmcard,'IRESTART',irestart,0) +c!bankt call readi(mcmcard,'NBANKTM',ntbankm,0) + ntbankm=0 +c!bankt + call reada(mcmcard,'DELE',dele,20.0d0) + call reada(mcmcard,'DIFCUT',difcut,720.0d0) + call readi(mcmcard,'IREF',iref,0) + call reada(mcmcard,'RMSCUT',rmscut,4.0d0) + call reada(mcmcard,'PNCCUT',pnccut,0.5d0) + call readi(mcmcard,'NCONF_IN',nconf_in,0) + call reada(mcmcard,'RDIH_BIAS',rdih_bias,0.5d0) + write (iout,*) "NCONF_IN",nconf_in + tm_score=(index(mcmcard,'TMSCORE').gt.0) + if (tm_score) write (iout,*) "Using TM_Score instead of DIFF", + & " for torsional angles" + return + end + + 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' +c 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', + & readonly) + 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) + call getenv_loc('THETPAR',thetname) + open (ithep,file=thetname,status='old',readonly) +#ifndef CRYST_THETA + call getenv_loc('THETPARPDB',thetname_pdb) + print *,"thetname_pdb ",thetname_pdb + open (ithep_pdb,file=thetname_pdb,status='old',readonly) + print *,ithep_pdb," opened" +#endif + call getenv_loc('ROTPAR',rotname) + open (irotam,file=rotname,status='old',readonly) +#ifndef CRYST_SC + call getenv_loc('ROTPARPDB',rotname_pdb) + open (irotam_pdb,file=rotname_pdb,status='old',readonly) +#endif + call getenv_loc('TORPAR',torname) + open (itorp,file=torname,status='old',readonly) + call getenv_loc('TORDPAR',tordname) + open (itordp,file=tordname,status='old',readonly) + call getenv_loc('SCCORPAR',sccorname) + open (isccor,file=sccorname,status='old',readonly) + call getenv_loc('FOURIER',fouriername) + open (ifourier,file=fouriername,status='old',readonly) + call getenv_loc('ELEPAR',elename) + open (ielep,file=elename,status='old',readonly) + call getenv_loc('SIDEPAR',sidename) + open (isidep,file=sidename,status='old',readonly) +#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',readonly) +#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',readonly) +#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' +c if(usampl) then +c qname=prefix(:lenpre)//'_'//pot(:lenpot)// +c & liczba(:ilen(liczba))//'.const' +c 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' +c if(usampl) then +c qname=prefix(:lenpre)//'_'//pot(:lenpot)//'.const' +c endif +#endif +#if defined(AIX) || defined(PGI) + if (me.eq.king .or. .not. out1file) + & open(iout,file=outname,status='unknown') +#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 + 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') +#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 + 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_rbank=prefix(:lenpre)//'.CSA.rbank' + csa_seed=prefix(:lenpre)//'.CSA.seed' + csa_history=prefix(:lenpre)//'.CSA.history' + csa_bank=prefix(:lenpre)//'.CSA.bank' + csa_bank1=prefix(:lenpre)//'.CSA.bank1' + csa_alpha=prefix(:lenpre)//'.CSA.alpha' + csa_alpha1=prefix(:lenpre)//'.CSA.alpha1' +c!bankt csa_bankt=prefix(:lenpre)//'.CSA.bankt' + csa_int=prefix(:lenpre)//'.int' + csa_bank_reminimized=prefix(:lenpre)//'.CSA.bank_reminimized' + csa_native_int=prefix(:lenpre)//'.CSA.native.int' + 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 + + 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 + write (iout,*) "Calling read_dist_constr" + write (iout,*) "nres",nres," nstart_sup",nstart_sup," nsup",nsup + 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 + 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),forcon(nhpb+1) + if (forcon(nhpb+1).gt.0.0d0) then + nhpb=nhpb+1 + dhpb(nhpb)=dist(ihpb(nhpb),jhpb(nhpb)) +#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 + endif + enddo + call flush(iout) + 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' +c include 'COMMON.THREAD' + include 'COMMON.SBRIDGE' + include 'COMMON.CONTROL' + include 'COMMON.MCM' +c include 'COMMON.MAP' + include 'COMMON.HEADER' +c include 'COMMON.CSA' + include 'COMMON.CHAIN' +c include 'COMMON.MUCA' +c 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 diff --git a/source/unres/src_CSA_DiL/rescode.f b/source/unres/src_CSA_DiL/rescode.f new file mode 100644 index 0000000..2973ef9 --- /dev/null +++ b/source/unres/src_CSA_DiL/rescode.f @@ -0,0 +1,32 @@ + 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 + diff --git a/source/unres/src_CSA_DiL/rmdd.f b/source/unres/src_CSA_DiL/rmdd.f new file mode 100644 index 0000000..799ab47 --- /dev/null +++ b/source/unres/src_CSA_DiL/rmdd.f @@ -0,0 +1,159 @@ +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 diff --git a/source/unres/src_CSA_DiL/rmsd.F b/source/unres/src_CSA_DiL/rmsd.F new file mode 100644 index 0000000..8e07b0c --- /dev/null +++ b/source/unres/src_CSA_DiL/rmsd.F @@ -0,0 +1,184 @@ + 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 + +c--------------------------------------------------------------------------- + subroutine calc_tmscore(tmscore_dp,lprn) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.INTERACT' + real x1(maxres),y1(maxres),z1(maxres) + integer n_1(maxres),L1 + real x2(maxres),y2(maxres),z2(maxres) + integer n_2(maxres),L2 + real TM,Rcomm + integer Lcomm + logical lprn + + L1=0 +c print *,"nz_start",nz_start," nz_end",nz_end + do i=nz_start,nz_end + L1=L1+1 + n_1(L1)=L1 + x1(L1)=c(1,i+nstart_seq-nstart_sup) + y1(L1)=c(2,i+nstart_seq-nstart_sup) + z1(L1)=c(3,i+nstart_seq-nstart_sup) + + n_2(L1)=L1 + x2(L1)=cref(1,i) + y2(L1)=cref(2,i) + z2(L1)=cref(3,i) + enddo + L2=L1 + + call TMscore(L1,x1,y1,z1,n_1,L2,x2,y2,z2,n_2,TM,Rcomm,Lcomm) + + tmscore_dp=TM + if (lprn) then + write (iout,'(a40,f8.2)') + & 'TM-score with the reference structure: ',TM + endif + return + end + diff --git a/source/unres/src_CSA_DiL/sc_move.F b/source/unres/src_CSA_DiL/sc_move.F new file mode 100644 index 0000000..b6837fd --- /dev/null +++ b/source/unres/src_CSA_DiL/sc_move.F @@ -0,0 +1,823 @@ + 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----------------------------------------------------------------------------- diff --git a/source/unres/src_CSA_DiL/shift.F b/source/unres/src_CSA_DiL/shift.F new file mode 100644 index 0000000..6eb9b3f --- /dev/null +++ b/source/unres/src_CSA_DiL/shift.F @@ -0,0 +1,105 @@ +c--------------------------------- + subroutine csa_read + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CSA' + include 'COMMON.BANK' + include 'COMMON.IOUNITS' + + open(icsa_in,file=csa_in,status="old",err=100) + read(icsa_in,*) nconf + read(icsa_in,*) jstart,jend + read(icsa_in,*) nstmax + read(icsa_in,*) n1,n2,n3,n4,n5,n6,n7,n8,is1,is2 + read(icsa_in,*) nran0,nran1,irr + read(icsa_in,*) nseed + read(icsa_in,*) ntotal,cut1,cut2 + read(icsa_in,*) estop + read(icsa_in,*) icmax,irestart + read(icsa_in,*) ntbankm,dele,difcut + read(icsa_in,*) iref,rmscut,pnccut + read(icsa_in,*) ndiff + close(icsa_in) + + return + + 100 continue + return + end +c--------------------------------- + subroutine initial_write + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CSA' + include 'COMMON.BANK' + include 'COMMON.IOUNITS' + + open(icsa_seed,file=csa_seed,status="unknown") + write(icsa_seed,*) "seed" + close(31) +#if defined(AIX) || defined(PGI) + open(icsa_history,file=csa_history,status="unknown", + & position="append") +#else + open(icsa_history,file=csa_history,status="unknown", + & access="append") +#endif + write(icsa_history,*) nconf + write(icsa_history,*) jstart,jend + write(icsa_history,*) nstmax + write(icsa_history,*) n1,n2,n3,n4,n5,n6,n7,n8,is1,is2 + write(icsa_history,*) nran0,nran1,irr + write(icsa_history,*) nseed + write(icsa_history,*) ntotal,cut1,cut2 + write(icsa_history,*) estop + write(icsa_history,*) icmax,irestart + write(icsa_history,*) ntbankm,dele,difcut + write(icsa_history,*) iref,rmscut,pnccut + write(icsa_history,*) ndiff + + write(icsa_history,*) + close(icsa_history) + + open(icsa_bank1,file=csa_bank1,status="unknown") + write(icsa_bank1,*) 0 + close(icsa_bank1) + + return + end +c--------------------------------- + subroutine restart_write + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CSA' + include 'COMMON.BANK' + +#if defined(AIX) || defined(PGI) + open(icsa_history,file=csa_history,position="append") +#else + open(icsa_history,file=csa_history,access="append") +#endif + write(icsa_history,*) + write(icsa_history,*) "This is restart" + write(icsa_history,*) + write(icsa_history,*) nconf + write(icsa_history,*) jstart,jend + write(icsa_history,*) nstmax + write(icsa_history,*) n1,n2,n3,n4,n5,n6,n7,n8,is1,is2 + write(icsa_history,*) nran0,nran1,irr + write(icsa_history,*) nseed + write(icsa_history,*) ntotal,cut1,cut2 + write(icsa_history,*) estop + write(icsa_history,*) icmax,irestart + write(icsa_history,*) ntbankm,dele,difcut + write(icsa_history,*) iref,rmscut,pnccut + write(icsa_history,*) ndiff + write(icsa_history,*) + write(icsa_history,*) "irestart is: ", irestart + + write(icsa_history,*) + close(icsa_history) + + return + end +c--------------------------------- diff --git a/source/unres/src_CSA_DiL/sumsld.f b/source/unres/src_CSA_DiL/sumsld.f new file mode 100644 index 0000000..1ce7b78 --- /dev/null +++ b/source/unres/src_CSA_DiL/sumsld.f @@ -0,0 +1,1446 @@ + 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 diff --git a/source/unres/src_CSA_DiL/test.F b/source/unres/src_CSA_DiL/test.F new file mode 100644 index 0000000..a065af9 --- /dev/null +++ b/source/unres/src_CSA_DiL/test.F @@ -0,0 +1,2800 @@ + 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_n16 + 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 jdata(5) + logical debug + debug=.true. + +c + call geom_to_var(nvar,var1) + call chainbuild + call etotal(energy(0)) + etot=energy(0) + write(iout,*) nnt,nct,etot + call write_pdb(1,'first structure',etot) + call secondary2(.true.) + + do i=1,4 + jdata(i)=bfrag(i,2) + enddo + + DO ij=1,4 + ieval=0 + jdata(5)=ij + call var_to_geom(nvar,var1) + write(iout,*) 'N16 test',(jdata(i),i=1,5) + call beta_slide(jdata(1),jdata(2),jdata(3),jdata(4),jdata(5) + & ,ieval,ij) + call geom_to_var(nvar,var) + + 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(ij*100+99,'full min',etot) + endif + + + ENDDO + + 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 test11 + 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' +c + include 'COMMON.DISTFIT' + integer if(20,maxres),nif,ifa(20) + integer ibc(0:maxres,0:maxres),istrand(20) + integer ibd(maxres),ifb(10,2),nifb,lifb(10),lifb0 + integer itmp(20,maxres) + double precision time0,time1 + double precision energy(0:n_ene),ee + double precision varia(maxvar),vorg(maxvar) +c + logical debug,ltest,usedbfrag(maxres/3) + character*50 linia +c + integer betasheet(maxres),ibetasheet(maxres),nbetasheet + integer bstrand(maxres/3,6),nbstrand + +c------------------------ + + debug=.true. +c------------------------ + nbstrand=0 + nbetasheet=0 + do i=1,nres + betasheet(i)=0 + ibetasheet(i)=0 + enddo + call geom_to_var(nvar,vorg) + call secondary2(debug) + + if (nbfrag.le.1) return + + do i=1,nbfrag + usedbfrag(i)=.false. + enddo + + + nbetasheet=nbetasheet+1 + nbstrand=2 + bstrand(1,1)=bfrag(1,1) + bstrand(1,2)=bfrag(2,1) + bstrand(1,3)=nbetasheet + bstrand(1,4)=1 + bstrand(1,5)=bfrag(1,1) + bstrand(1,6)=bfrag(2,1) + do i=bfrag(1,1),bfrag(2,1) + betasheet(i)=nbetasheet + ibetasheet(i)=1 + enddo +c + bstrand(2,1)=bfrag(3,1) + bstrand(2,2)=bfrag(4,1) + bstrand(2,3)=nbetasheet + bstrand(2,5)=bfrag(3,1) + bstrand(2,6)=bfrag(4,1) + + if (bfrag(3,1).le.bfrag(4,1)) then + bstrand(2,4)=2 + do i=bfrag(3,1),bfrag(4,1) + betasheet(i)=nbetasheet + ibetasheet(i)=2 + enddo + else + bstrand(2,4)=-2 + do i=bfrag(4,1),bfrag(3,1) + betasheet(i)=nbetasheet + ibetasheet(i)=2 + enddo + endif + + iused_nbfrag=1 + + do while (iused_nbfrag.ne.nbfrag) + + do j=2,nbfrag + + IF (.not.usedbfrag(j)) THEN + + write (*,*) j,(bfrag(i,j),i=1,4) + do jk=6,1,-1 + write (*,'(i4,a3,10i4)') jk,'B',(bstrand(i,jk),i=1,nbstrand) + enddo + write (*,*) '------------------' + + + if (bfrag(3,j).le.bfrag(4,j)) then + do i=bfrag(3,j),bfrag(4,j) + if(betasheet(i).eq.nbetasheet) then + in=ibetasheet(i) + do k=bfrag(3,j),bfrag(4,j) + betasheet(k)=nbetasheet + ibetasheet(k)=in + enddo + nbstrand=nbstrand+1 + usedbfrag(j)=.true. + iused_nbfrag=iused_nbfrag+1 + do k=bfrag(1,j),bfrag(2,j) + betasheet(k)=nbetasheet + ibetasheet(k)=nbstrand + enddo + if (bstrand(in,4).lt.0) then + bstrand(nbstrand,1)=bfrag(2,j) + bstrand(nbstrand,2)=bfrag(1,j) + bstrand(nbstrand,3)=nbetasheet + bstrand(nbstrand,4)=-nbstrand + bstrand(nbstrand,5)=bstrand(nbstrand,1) + bstrand(nbstrand,6)=bstrand(nbstrand,2) + if(bstrand(in,1).lt.bfrag(4,j)) then + call bgrow(bstrand,nbstrand,in,1,bfrag(4,j)) + else + bstrand(nbstrand,5)=bstrand(nbstrand,5)+ + & (bstrand(in,5)-bfrag(4,j)) + endif + if(bstrand(in,2).gt.bfrag(3,j)) then + call bgrow(bstrand,nbstrand,in,2,bfrag(3,j)) + else + bstrand(nbstrand,6)=bstrand(nbstrand,6)- + & (-bstrand(in,6)+bfrag(3,j)) + endif + else + bstrand(nbstrand,1)=bfrag(1,j) + bstrand(nbstrand,2)=bfrag(2,j) + bstrand(nbstrand,3)=nbetasheet + bstrand(nbstrand,4)=nbstrand + bstrand(nbstrand,5)=bstrand(nbstrand,1) + bstrand(nbstrand,6)=bstrand(nbstrand,2) + if(bstrand(in,1).gt.bfrag(3,j)) then + call bgrow(bstrand,nbstrand,in,1,bfrag(3,j)) + else + bstrand(nbstrand,5)=bstrand(nbstrand,5)- + & (-bstrand(in,5)+bfrag(3,j)) + endif + if(bstrand(in,2).lt.bfrag(4,j)) then + call bgrow(bstrand,nbstrand,in,2,bfrag(4,j)) + else + bstrand(nbstrand,6)=bstrand(nbstrand,6)+ + & (bstrand(in,6)-bfrag(4,j)) + endif + endif + goto 11 + endif + if(betasheet(bfrag(1,j)+i-bfrag(3,j)).eq.nbetasheet) then + in=ibetasheet(bfrag(1,j)+i-bfrag(3,j)) + do k=bfrag(1,j),bfrag(2,j) + betasheet(k)=nbetasheet + ibetasheet(k)=in + enddo + nbstrand=nbstrand+1 + usedbfrag(j)=.true. + iused_nbfrag=iused_nbfrag+1 + do k=bfrag(3,1),bfrag(4,1) + betasheet(k)=nbetasheet + ibetasheet(k)=nbstrand + enddo + if (bstrand(in,4).lt.0) then + bstrand(nbstrand,1)=bfrag(4,j) + bstrand(nbstrand,2)=bfrag(3,j) + bstrand(nbstrand,3)=nbetasheet + bstrand(nbstrand,4)=-nbstrand + bstrand(nbstrand,5)=bstrand(nbstrand,1) + bstrand(nbstrand,6)=bstrand(nbstrand,2) + if(bstrand(in,1).lt.bfrag(2,j)) then + call bgrow(bstrand,nbstrand,in,1,bfrag(2,j)) + else + bstrand(nbstrand,5)=bstrand(nbstrand,5)+ + & (bstrand(in,5)-bfrag(2,j)) + endif + if(bstrand(in,2).gt.bfrag(1,j)) then + call bgrow(bstrand,nbstrand,in,2,bfrag(1,j)) + else + bstrand(nbstrand,6)=bstrand(nbstrand,6)- + & (-bstrand(in,6)+bfrag(1,j)) + endif + else + bstrand(nbstrand,1)=bfrag(3,j) + bstrand(nbstrand,2)=bfrag(4,j) + bstrand(nbstrand,3)=nbetasheet + bstrand(nbstrand,4)=nbstrand + bstrand(nbstrand,5)=bstrand(nbstrand,1) + bstrand(nbstrand,6)=bstrand(nbstrand,2) + if(bstrand(in,1).gt.bfrag(1,j)) then + call bgrow(bstrand,nbstrand,in,1,bfrag(1,j)) + else + bstrand(nbstrand,5)=bstrand(nbstrand,5)- + & (-bstrand(in,5)+bfrag(1,j)) + endif + if(bstrand(in,2).lt.bfrag(2,j)) then + call bgrow(bstrand,nbstrand,in,2,bfrag(2,j)) + else + bstrand(nbstrand,6)=bstrand(nbstrand,6)+ + & (bstrand(in,6)-bfrag(2,j)) + endif + endif + goto 11 + endif + enddo + else + do i=bfrag(4,j),bfrag(3,j) + if(betasheet(i).eq.nbetasheet) then + in=ibetasheet(i) + do k=bfrag(4,j),bfrag(3,j) + betasheet(k)=nbetasheet + ibetasheet(k)=in + enddo + nbstrand=nbstrand+1 + usedbfrag(j)=.true. + iused_nbfrag=iused_nbfrag+1 + do k=bfrag(1,j),bfrag(2,j) + betasheet(k)=nbetasheet + ibetasheet(k)=nbstrand + enddo + if (bstrand(in,4).lt.0) then + bstrand(nbstrand,1)=bfrag(1,j) + bstrand(nbstrand,2)=bfrag(2,j) + bstrand(nbstrand,3)=nbetasheet + bstrand(nbstrand,4)=nbstrand + bstrand(nbstrand,5)=bstrand(nbstrand,1) + bstrand(nbstrand,6)=bstrand(nbstrand,2) + if(bstrand(in,1).lt.bfrag(3,j)) then + call bgrow(bstrand,nbstrand,in,1,bfrag(3,j)) + else + bstrand(nbstrand,5)=bstrand(nbstrand,5)- + & (bstrand(in,5)-bfrag(3,j)) + endif + if(bstrand(in,2).gt.bfrag(4,j)) then + call bgrow(bstrand,nbstrand,in,2,bfrag(4,j)) + else + bstrand(nbstrand,6)=bstrand(nbstrand,6)+ + & (-bstrand(in,6)+bfrag(4,j)) + endif + else + bstrand(nbstrand,1)=bfrag(2,j) + bstrand(nbstrand,2)=bfrag(1,j) + bstrand(nbstrand,3)=nbetasheet + bstrand(nbstrand,4)=-nbstrand + bstrand(nbstrand,5)=bstrand(nbstrand,1) + bstrand(nbstrand,6)=bstrand(nbstrand,2) + if(bstrand(in,1).gt.bfrag(4,j)) then + call bgrow(bstrand,nbstrand,in,1,bfrag(4,j)) + else + bstrand(nbstrand,5)=bstrand(nbstrand,5)+ + & (-bstrand(in,5)+bfrag(4,j)) + endif + if(bstrand(in,2).lt.bfrag(3,j)) then + call bgrow(bstrand,nbstrand,in,2,bfrag(3,j)) + else + bstrand(nbstrand,6)=bstrand(nbstrand,6)- + & (bstrand(in,6)-bfrag(3,j)) + endif + endif + goto 11 + endif + if(betasheet(bfrag(2,j)-i+bfrag(4,j)).eq.nbetasheet) then + in=ibetasheet(bfrag(2,j)-i+bfrag(4,j)) + do k=bfrag(1,j),bfrag(2,j) + betasheet(k)=nbetasheet + ibetasheet(k)=in + enddo + nbstrand=nbstrand+1 + usedbfrag(j)=.true. + iused_nbfrag=iused_nbfrag+1 + do k=bfrag(4,j),bfrag(3,j) + betasheet(k)=nbetasheet + ibetasheet(k)=nbstrand + enddo + if (bstrand(in,4).lt.0) then + bstrand(nbstrand,1)=bfrag(4,j) + bstrand(nbstrand,2)=bfrag(3,j) + bstrand(nbstrand,3)=nbetasheet + bstrand(nbstrand,4)=nbstrand + bstrand(nbstrand,5)=bstrand(nbstrand,1) + bstrand(nbstrand,6)=bstrand(nbstrand,2) + if(bstrand(in,1).lt.bfrag(2,j)) then + call bgrow(bstrand,nbstrand,in,1,bfrag(2,j)) + else + bstrand(nbstrand,5)=bstrand(nbstrand,5)- + & (bstrand(in,5)-bfrag(2,j)) + endif + if(bstrand(in,2).gt.bfrag(1,j)) then + call bgrow(bstrand,nbstrand,in,2,bfrag(1,j)) + else + bstrand(nbstrand,6)=bstrand(nbstrand,6)+ + & (-bstrand(in,6)+bfrag(1,j)) + endif + else + bstrand(nbstrand,1)=bfrag(3,j) + bstrand(nbstrand,2)=bfrag(4,j) + bstrand(nbstrand,3)=nbetasheet + bstrand(nbstrand,4)=-nbstrand + bstrand(nbstrand,5)=bstrand(nbstrand,1) + bstrand(nbstrand,6)=bstrand(nbstrand,2) + if(bstrand(in,1).gt.bfrag(1,j)) then + call bgrow(bstrand,nbstrand,in,1,bfrag(1,j)) + else + bstrand(nbstrand,5)=bstrand(nbstrand,5)+ + & (-bstrand(in,5)+bfrag(1,j)) + endif + if(bstrand(in,2).lt.bfrag(2,j)) then + call bgrow(bstrand,nbstrand,in,2,bfrag(2,j)) + else + bstrand(nbstrand,6)=bstrand(nbstrand,6)- + & (bstrand(in,6)-bfrag(2,j)) + endif + endif + goto 11 + endif + enddo + endif + + + + ENDIF + enddo + + j=2 + do while (usedbfrag(j)) + j=j+1 + enddo + + nbstrand=nbstrand+1 + nbetasheet=nbetasheet+1 + bstrand(nbstrand,1)=bfrag(1,j) + bstrand(nbstrand,2)=bfrag(2,j) + bstrand(nbstrand,3)=nbetasheet + bstrand(nbstrand,5)=bfrag(1,j) + bstrand(nbstrand,6)=bfrag(2,j) + + bstrand(nbstrand,4)=nbstrand + do i=bfrag(1,j),bfrag(2,j) + betasheet(i)=nbetasheet + ibetasheet(i)=nbstrand + enddo +c + nbstrand=nbstrand+1 + bstrand(nbstrand,1)=bfrag(3,j) + bstrand(nbstrand,2)=bfrag(4,j) + bstrand(nbstrand,3)=nbetasheet + bstrand(nbstrand,5)=bfrag(3,j) + bstrand(nbstrand,6)=bfrag(4,j) + + if (bfrag(3,j).le.bfrag(4,j)) then + bstrand(nbstrand,4)=nbstrand + do i=bfrag(3,j),bfrag(4,j) + betasheet(i)=nbetasheet + ibetasheet(i)=nbstrand + enddo + else + bstrand(nbstrand,4)=-nbstrand + do i=bfrag(4,j),bfrag(3,j) + betasheet(i)=nbetasheet + ibetasheet(i)=nbstrand + enddo + endif + + iused_nbfrag=iused_nbfrag+1 + usedbfrag(j)=.true. + + + 11 continue + do jk=6,1,-1 + write (*,'(i4,a3,10i4)') jk,'A',(bstrand(i,jk),i=1,nbstrand) + enddo + + + enddo + + do i=1,nres + if (betasheet(i).ne.0) write(*,*) i,betasheet(i),ibetasheet(i) + enddo + write(*,*) + do j=6,1,-1 + write (*,'(i4,a3,10i4)') j,':',(bstrand(i,j),i=1,nbstrand) + enddo + +c------------------------ + nifb=0 + do i=1,nbstrand + do j=i+1,nbstrand + if(iabs(bstrand(i,5)-bstrand(j,5)).le.5 .or. + & iabs(bstrand(i,6)-bstrand(j,6)).le.5 ) then + nifb=nifb+1 + ifb(nifb,1)=bstrand(i,4) + ifb(nifb,2)=bstrand(j,4) + endif + enddo + enddo + + write(*,*) + do i=1,nifb + write (*,'(a3,20i4)') "ifb",i,ifb(i,1),ifb(i,2) + enddo + + do i=1,nbstrand + ifa(i)=bstrand(i,4) + enddo + write (*,'(a3,20i4)') "ifa",(ifa(i),i=1,nbstrand) + + nif=iabs(bstrand(1,6)-bstrand(1,5))+1 + do j=2,nbstrand + if (iabs(bstrand(j,6)-bstrand(j,5))+1.gt.nif) + & nif=iabs(bstrand(j,6)-bstrand(j,5))+1 + enddo + + write(*,*) nif + do i=1,nif + do j=1,nbstrand + if(j,i)=bstrand(j,6)+(i-1)*sign(1,bstrand(j,5)-bstrand(j,6)) + if (if(j,i).gt.0) then + if(betasheet(if(j,i)).eq.0 .or. + & ibetasheet(if(j,i)).ne.iabs(bstrand(j,4))) if(j,i)=0 + else + if(j,i)=0 + endif + enddo + write(*,'(a3,10i4)') 'if ',(if(j,i),j=1,nbstrand) + enddo + +c read (inp,*) (ifa(i),i=1,4) +c do i=1,nres +c read (inp,*,err=20,end=20) (if(j,i),j=1,4) +c enddo +c 20 nif=i-1 + stop +c------------------------ + + isa=4 + is=2*isa-1 + iconf=0 +cccccccccccccccccccccccccccccccccc + DO ig=1,is**isa-1 +cccccccccccccccccccccccccccccccccc + + ii=ig + do j=1,is + istrand(is-j+1)=int(ii/is**(is-j)) + ii=ii-istrand(is-j+1)*is**(is-j) + enddo + ltest=.true. + do k=1,isa + istrand(k)=istrand(k)+1 + if(istrand(k).gt.isa) istrand(k)=istrand(k)-2*isa-1 + enddo + do k=1,isa + do l=1,isa + if(istrand(k).eq.istrand(l).and.k.ne.l.or. + & istrand(k).eq.-istrand(l).and.k.ne.l) ltest=.false. + enddo + enddo + + lifb0=1 + do m=1,nifb + lifb(m)=0 + do k=1,isa-1 + if( + & ifb(m,1).eq.istrand(k).and.ifb(m,2).eq.istrand(k+1).or. + & ifb(m,2).eq.istrand(k).and.ifb(m,1).eq.istrand(k+1).or. + & -ifb(m,1).eq.istrand(k).and.-ifb(m,2).eq.istrand(k+1).or. + & -ifb(m,2).eq.istrand(k).and.-ifb(m,1).eq.istrand(k+1)) + & lifb(m)=1 + enddo + lifb0=lifb0*lifb(m) + enddo + + if (mod(isa,2).eq.0) then + do k=isa/2+1,isa + if (istrand(k).eq.1) ltest=.false. + enddo + else + do k=(isa+1)/2+1,isa + if (istrand(k).eq.1) ltest=.false. + enddo + endif + + IF (ltest.and.lifb0.eq.1) THEN + iconf=iconf+1 + + call var_to_geom(nvar,vorg) + + write (*,'(i5,i10,10i3)') iconf,ig,(istrand(k),k=1,isa) + write (iout,'(i5,i10,10i3)') iconf,ig,(istrand(k),k=1,isa) + write (linia,'(10i3)') (istrand(k),k=1,isa) + + do i=1,nres + do j=1,nres + ibc(i,j)=0 + enddo + enddo + + + do i=1,4 + if ( sign(1,istrand(i)).eq.sign(1,ifa(iabs(istrand(i)))) ) then + do j=1,nif + itmp(iabs(istrand(i)),j)=if(iabs(ifa(iabs(istrand(i)))),j) + enddo + else + do j=1,nif + itmp(iabs(istrand(i)),j)=if(iabs(ifa(iabs(istrand(i)))),nif-j+1) + enddo + endif + enddo + + do i=1,nif + write(*,*) (itmp(j,i),j=1,4) + enddo + + do i=1,nif +c ifa(1),ifa(2),ifa(3),ifa(4) +c if(1,i),if(2,i),if(3,i),if(4,i) + do k=1,isa-1 + ltest=.false. + do m=1,nifb + if( + & ifb(m,1).eq.istrand(k).and.ifb(m,2).eq.istrand(k+1).or. + & ifb(m,2).eq.istrand(k).and.ifb(m,1).eq.istrand(k+1).or. + & -ifb(m,1).eq.istrand(k).and.-ifb(m,2).eq.istrand(k+1).or. + & -ifb(m,2).eq.istrand(k).and.-ifb(m,1).eq.istrand(k+1)) + & then + ltest=.true. + goto 110 + endif + enddo + 110 continue + if (ltest) then + ibc(itmp(iabs(istrand(k)),i),itmp(iabs(istrand(k+1)),i))=-1 + else + ibc(itmp(iabs(istrand(k)),i),itmp(iabs(istrand(k+1)),i))=-2 + endif +c + if (k.lt.3) + & ibc(itmp(iabs(istrand(k)),i),itmp(iabs(istrand(k+2)),i))=-3 + if (k.lt.2) + & ibc(itmp(iabs(istrand(k)),i),itmp(iabs(istrand(k+3)),i))=-4 + enddo + enddo +c------------------------ + +c +c freeze sec.elements +c + do i=1,nres + mask(i)=1 + mask_phi(i)=1 + mask_theta(i)=1 + mask_side(i)=1 + enddo + + do j=1,nbfrag + do i=bfrag(1,j),bfrag(2,j) + mask(i)=0 + mask_phi(i)=0 + mask_theta(i)=0 + enddo + if (bfrag(3,j).le.bfrag(4,j)) then + do i=bfrag(3,j),bfrag(4,j) + mask(i)=0 + mask_phi(i)=0 + mask_theta(i)=0 + enddo + else + do i=bfrag(4,j),bfrag(3,j) + mask(i)=0 + mask_phi(i)=0 + mask_theta(i)=0 + enddo + endif + enddo + do j=1,nhfrag + do i=hfrag(1,j),hfrag(2,j) + mask(i)=0 + mask_phi(i)=0 + mask_theta(i)=0 + enddo + enddo + mask_r=.true. + +c------------------------ +c generate constrains +c + nhpb0=nhpb + call chainbuild + ind=0 + do i=1,nres-3 + do j=i+3,nres + ind=ind+1 + if ( ibc(i,j).eq.-1 .or. ibc(j,i).eq.-1) then + d0(ind)=DIST(i,j) + w(ind)=10.0 + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=10.0 + dhpb(nhpb)=d0(ind) + else if ( ibc(i,j).eq.-2 .or. ibc(j,i).eq.-2) then + d0(ind)=5.0 + w(ind)=10.0 + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=10.0 + dhpb(nhpb)=d0(ind) + else if ( ibc(i,j).eq.-3 .or. ibc(j,i).eq.-3) then + d0(ind)=11.0 + w(ind)=10.0 + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=10.0 + dhpb(nhpb)=d0(ind) + else if ( ibc(i,j).eq.-4 .or. ibc(j,i).eq.-4) then + d0(ind)=16.0 + w(ind)=10.0 + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=10.0 + dhpb(nhpb)=d0(ind) + else if ( ibc(i,j).gt.0 ) then + d0(ind)=DIST(i,ibc(i,j)) + w(ind)=10.0 + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=10.0 + dhpb(nhpb)=d0(ind) + else if ( ibc(j,i).gt.0 ) then + d0(ind)=DIST(ibc(j,i),j) + w(ind)=10.0 + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=10.0 + dhpb(nhpb)=d0(ind) + else + w(ind)=0.0 + endif + dd(ind)=d0(ind) + enddo + enddo + call hpb_partition +cd-------------------------- + + write(iout,'(i3,2i4,a3,2i4,f7.2)') (i,ibc(ihpb(i),jhpb(i)), + & ibc(jhpb(i),ihpb(i)),' --', + & ihpb(i),jhpb(i),dhpb(i),i=1,nhpb) + +cd nhpb=0 +cd goto 901 +c +c + call contact_cp_min(varia,ifun,iconf,linia,debug) + if (minim) then +#ifdef MPI + time0=MPI_WTIME() +#else + time0=tcpu() +#endif + call minimize(etot,varia,iretcode,nfun) + write(iout,*)'------------------------------------------------' + write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun, + & '+ DIST eval',ifun + +#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' + + write (linia,'(a10,10i3)') 'full_min',(istrand(k),k=1,isa) + call var_to_geom(nvar,varia) + call chainbuild + call write_pdb(900+iconf,linia,etot) + endif + + call etotal(energy(0)) + etot=energy(0) + call enerprint(energy(0)) +cd call intout +cd call briefout(0,etot) +cd call secondary2(.true.) + + 901 CONTINUE +ctest return +cccccccccccccccccccccccccccccccccccc + ENDIF + ENDDO +cccccccccccccccccccccccccccccccccccc + + return + 10 write (iout,'(a)') 'Error reading test structure.' + return + end +c-------------------------------------------------------- + + subroutine test3 + 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' +c + include 'COMMON.DISTFIT' + integer if(3,maxres),nif + integer ibc(maxres,maxres),istrand(20) + integer ibd(maxres),ifb(10,2),nifb,lifb(10),lifb0 + double precision time0,time1 + double precision energy(0:n_ene),ee + double precision varia(maxvar) +c + logical debug,ltest + character*50 linia +c + do i=1,nres + read (inp,*,err=20,end=20) if(1,i),if(2,i),if(3,i) + enddo + 20 nif=i-1 + write (*,'(a4,3i5)') ('if =',if(1,i),if(2,i),if(3,i), + & i=1,nif) + + +c------------------------ + call secondary2(debug) +c------------------------ + do i=1,nres + do j=1,nres + ibc(i,j)=0 + enddo + enddo + +c +c freeze sec.elements and store indexes for beta constrains +c + do i=1,nres + mask(i)=1 + mask_phi(i)=1 + mask_theta(i)=1 + mask_side(i)=1 + enddo + + do j=1,nbfrag + do i=bfrag(1,j),bfrag(2,j) + mask(i)=0 + mask_phi(i)=0 + mask_theta(i)=0 + enddo + if (bfrag(3,j).le.bfrag(4,j)) then + do i=bfrag(3,j),bfrag(4,j) + mask(i)=0 + mask_phi(i)=0 + mask_theta(i)=0 + ibc(bfrag(1,j)+i-bfrag(3,j),i)=-1 + enddo + else + do i=bfrag(4,j),bfrag(3,j) + mask(i)=0 + mask_phi(i)=0 + mask_theta(i)=0 + ibc(bfrag(2,j)-i+bfrag(4,j),i)=-1 + enddo + endif + enddo + do j=1,nhfrag + do i=hfrag(1,j),hfrag(2,j) + mask(i)=0 + mask_phi(i)=0 + mask_theta(i)=0 + enddo + enddo + mask_r=.true. + + +c ---------------- test -------------- + do i=1,nif + if (ibc(if(1,i),if(2,i)).eq.-1) then + ibc(if(1,i),if(2,i))=if(3,i) + ibc(if(1,i),if(3,i))=if(2,i) + else if (ibc(if(2,i),if(1,i)).eq.-1) then + ibc(if(2,i),if(1,i))=0 + ibc(if(1,i),if(2,i))=if(3,i) + ibc(if(1,i),if(3,i))=if(2,i) + else + ibc(if(1,i),if(2,i))=if(3,i) + ibc(if(1,i),if(3,i))=if(2,i) + endif + enddo + + do i=1,nres + do j=1,nres + if (ibc(i,j).ne.0) write(*,'(3i5)') i,j,ibc(i,j) + enddo + enddo +c------------------------ + call chainbuild + ind=0 + do i=1,nres-3 + do j=i+3,nres + ind=ind+1 + if ( ibc(i,j).eq.-1 ) then + d0(ind)=DIST(i,j) + w(ind)=10.0 + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=10.0 + dhpb(nhpb)=d0(ind) + else if ( ibc(i,j).gt.0 ) then + d0(ind)=DIST(i,ibc(i,j)) + w(ind)=10.0 + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=10.0 + dhpb(nhpb)=d0(ind) + else if ( ibc(j,i).gt.0 ) then + d0(ind)=DIST(ibc(j,i),j) + w(ind)=10.0 + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=10.0 + dhpb(nhpb)=d0(ind) + else + w(ind)=0.0 + endif + enddo + enddo + call hpb_partition + +cd-------------------------- + write(*,'(i3,2i4,a3,2i4,f7.2)') (i,ibc(ihpb(i),jhpb(i)), + & ibc(jhpb(i),ihpb(i)),' --', + & ihpb(i),jhpb(i),dhpb(i),i=1,nhpb) + + + linia='dist' + debug=.true. + in_pdb=7 +c + call contact_cp_min(varia,ieval,in_pdb,linia,debug) + if (minim) then +#ifdef MPI + time0=MPI_WTIME() +#else + time0=tcpu() +#endif + call minimize(etot,varia,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,varia) + call chainbuild + call write_pdb(999,'full min',etot) + endif + + call etotal(energy(0)) + etot=energy(0) + call enerprint(energy(0)) + call intout + call briefout(0,etot) + call secondary2(.true.) + + return + 10 write (iout,'(a)') 'Error reading test structure.' + return + end + + + + + subroutine test__ + 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' +c + include 'COMMON.DISTFIT' + integer if(2,2),ind + integer iff(maxres) + double precision time0,time1 + double precision energy(0:n_ene),ee + double precision theta2(maxres),phi2(maxres),alph2(maxres), + & omeg2(maxres), + & theta1(maxres),phi1(maxres),alph1(maxres), + & omeg1(maxres) + double precision varia(maxvar),varia2(maxvar) +c + + + read (inp,*,err=10,end=10) if(1,1),if(1,2),if(2,1),if(2,2) + write (iout,'(a4,4i5)') 'if =',if(1,1),if(1,2),if(2,1),if(2,2) + read (inp,*,err=10,end=10) (theta2(i),i=3,nres) + read (inp,*,err=10,end=10) (phi2(i),i=4,nres) + read (inp,*,err=10,end=10) (alph2(i),i=2,nres-1) + read (inp,*,err=10,end=10) (omeg2(i),i=2,nres-1) + do i=1,nres + theta2(i)=deg2rad*theta2(i) + phi2(i)=deg2rad*phi2(i) + alph2(i)=deg2rad*alph2(i) + omeg2(i)=deg2rad*omeg2(i) + enddo + do i=1,nres + theta1(i)=theta(i) + phi1(i)=phi(i) + alph1(i)=alph(i) + omeg1(i)=omeg(i) + enddo + + do i=1,nres + mask(i)=1 + enddo + + +c------------------------ + do i=1,nres + iff(i)=0 + enddo + do j=1,2 + do i=if(j,1),if(j,2) + iff(i)=1 + enddo + enddo + + call chainbuild + call geom_to_var(nvar,varia) + call write_pdb(1,'first structure',0d0) + + call secondary(.true.) + + call secondary2(.true.) + + do j=1,nbfrag + if ( (bfrag(3,j).lt.bfrag(4,j) .or. + & bfrag(4,j)-bfrag(2,j).gt.4) .and. + & bfrag(2,j)-bfrag(1,j).gt.3 ) then + nn=nn+1 + + if (bfrag(3,j).lt.bfrag(4,j)) then + write(iout,'(a6,i3,a1,i3,a1,i3,a1,i3)') + & "select",bfrag(1,j)-1,"-",bfrag(2,j)-1 + & ,",",bfrag(3,j)-1,"-",bfrag(4,j)-1 + else + write(iout,'(a6,i3,a1,i3,a1,i3,a1,i3)') + & "select",bfrag(1,j)-1,"-",bfrag(2,j)-1 + & ,",",bfrag(4,j)-1,"-",bfrag(3,j)-1 + endif + endif + enddo + + do i=1,nres + theta(i)=theta2(i) + phi(i)=phi2(i) + alph(i)=alph2(i) + omeg(i)=omeg2(i) + enddo + + call chainbuild + call geom_to_var(nvar,varia2) + call write_pdb(2,'second structure',0d0) + + + +c------------------------------------------------------- + + ifun=-1 + call contact_cp(varia,varia2,iff,ifun,7) + if (minim) then +#ifdef MPI + time0=MPI_WTIME() +#else + time0=tcpu() +#endif + call minimize(etot,varia,iretcode,nfun) + write(iout,*)'------------------------------------------------' + write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun, + & '+ DIST eval',ifun + +#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,varia) + call chainbuild + call write_pdb(999,'full min',etot) + endif + + call etotal(energy(0)) + etot=energy(0) + call enerprint(energy(0)) + call intout + call briefout(0,etot) + + return + 10 write (iout,'(a)') 'Error reading test structure.' + return + end + +c------------------------------------------------- +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 contact_cp2(var,var2,iff,ieval,in_pdb) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.SBRIDGE' + include 'COMMON.FFIELD' + include 'COMMON.IOUNITS' + include 'COMMON.DISTFIT' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.MINIM' + + character*50 linia + integer nf,ij(4) + double precision var(maxvar),var2(maxvar) + double precision time0,time1 + integer iff(maxres),ieval + double precision theta1(maxres),phi1(maxres),alph1(maxres), + & omeg1(maxres) + + + call var_to_geom(nvar,var) + call chainbuild + nhpb0=nhpb + ind=0 + do i=1,nres-3 + do j=i+3,nres + ind=ind+1 + if ( iff(i).eq.1.and.iff(j).eq.1 ) then + d0(ind)=DIST(i,j) + w(ind)=10.0 + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=10.0 + dhpb(nhpb)=d0(ind) + else + w(ind)=0.0 + endif + enddo + enddo + call hpb_partition + + do i=1,nres + theta1(i)=theta(i) + phi1(i)=phi(i) + alph1(i)=alph(i) + omeg1(i)=omeg(i) + enddo + + call var_to_geom(nvar,var2) + + do i=1,nres + if ( iff(i).eq.1 ) then + theta(i)=theta1(i) + phi(i)=phi1(i) + alph(i)=alph1(i) + omeg(i)=omeg1(i) + endif + enddo + + call chainbuild + + NX=NRES-3 + NY=((NRES-4)*(NRES-5))/2 + call distfit(.true.,200) + + + ipot0=ipot + maxmin0=maxmin + maxfun0=maxfun + wstrain0=wstrain + + ipot=6 + maxmin=2000 + maxfun=5000 + call geom_to_var(nvar,var) + call minimize(etot,var,iretcode,nfun) + write(iout,*)'SUMSL return code is',iretcode,' eval SOFT',nfun + + call var_to_geom(nvar,var) + call chainbuild + + + iwsk=0 + nf=0 + if (iff(1).eq.1) then + iwsk=1 + nf=nf+1 + ij(nf)=0 + endif + do i=2,nres + if ( iwsk.eq.0.and.iff(i-1).eq.0.and.iff(i).eq.1 ) then + iwsk=1 + nf=nf+1 + ij(nf)=i + endif + if ( iwsk.eq.1.and.iff(i-1).eq.1.and.iff(i).eq.0 ) then + iwsk=0 + nf=nf+1 + ij(nf)=i-1 + endif + enddo + if (iff(nres).eq.1) then + nf=nf+1 + ij(nf)=nres + endif + + +cd write(linia,'(a6,i3,a1,i3,a1,i3,a1,i3)') +cd & "select",ij(1),"-",ij(2), +cd & ",",ij(3),"-",ij(4) +cd call write_pdb(in_pdb,linia,etot) + + + ipot=ipot0 + maxmin=maxmin0 + maxfun=maxfun0 + call minimize(etot,var,iretcode,nfun) + ieval=nfun + + nhpb= nhpb0 + link_start=1 + link_end=nhpb + wstrain=wstrain0 + + return + end +c----------------------------------------------------------- + subroutine contact_cp(var,var2,iff,ieval,in_pdb) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.SBRIDGE' + include 'COMMON.FFIELD' + include 'COMMON.IOUNITS' + include 'COMMON.DISTFIT' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.MINIM' + + character*50 linia + integer nf,ij(4) + double precision energy(0:n_ene) + double precision var(maxvar),var2(maxvar) + double precision time0,time1 + integer iff(maxres),ieval + double precision theta1(maxres),phi1(maxres),alph1(maxres), + & omeg1(maxres) + logical debug + + debug=.false. +c debug=.true. + if (ieval.eq.-1) debug=.true. + + +c +c store selected dist. constrains from 1st structure +c +#ifdef OSF +c Intercept NaNs in the coordinates +c write(iout,*) (var(i),i=1,nvar) + x_sum=0.D0 + do i=1,nvar + x_sum=x_sum+var(i) + enddo + if (x_sum.ne.x_sum) then + write(iout,*)" *** contact_cp : Found NaN in coordinates" + call flush(iout) + print *," *** contact_cp : Found NaN in coordinates" + return + endif +#endif + + + call var_to_geom(nvar,var) + call chainbuild + nhpb0=nhpb + ind=0 + do i=1,nres-3 + do j=i+3,nres + ind=ind+1 + if ( iff(i).eq.1.and.iff(j).eq.1 ) then + d0(ind)=DIST(i,j) + w(ind)=10.0 + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=10.0 + dhpb(nhpb)=d0(ind) + else + w(ind)=0.0 + endif + enddo + enddo + call hpb_partition + + do i=1,nres + theta1(i)=theta(i) + phi1(i)=phi(i) + alph1(i)=alph(i) + omeg1(i)=omeg(i) + enddo + +c +c freeze sec.elements from 2nd structure +c + do i=1,nres + mask_phi(i)=1 + mask_theta(i)=1 + mask_side(i)=1 + enddo + + call var_to_geom(nvar,var2) + call secondary2(debug) + do j=1,nbfrag + do i=bfrag(1,j),bfrag(2,j) + mask(i)=0 + mask_phi(i)=0 + mask_theta(i)=0 + enddo + if (bfrag(3,j).le.bfrag(4,j)) then + do i=bfrag(3,j),bfrag(4,j) + mask(i)=0 + mask_phi(i)=0 + mask_theta(i)=0 + enddo + else + do i=bfrag(4,j),bfrag(3,j) + mask(i)=0 + mask_phi(i)=0 + mask_theta(i)=0 + enddo + endif + enddo + do j=1,nhfrag + do i=hfrag(1,j),hfrag(2,j) + mask(i)=0 + mask_phi(i)=0 + mask_theta(i)=0 + enddo + enddo + mask_r=.true. + +c +c copy selected res from 1st to 2nd structure +c + + do i=1,nres + if ( iff(i).eq.1 ) then + theta(i)=theta1(i) + phi(i)=phi1(i) + alph(i)=alph1(i) + omeg(i)=omeg1(i) + endif + enddo + + if(debug) then +c +c prepare description in linia variable +c + iwsk=0 + nf=0 + if (iff(1).eq.1) then + iwsk=1 + nf=nf+1 + ij(nf)=1 + endif + do i=2,nres + if ( iwsk.eq.0.and.iff(i-1).eq.0.and.iff(i).eq.1 ) then + iwsk=1 + nf=nf+1 + ij(nf)=i + endif + if ( iwsk.eq.1.and.iff(i-1).eq.1.and.iff(i).eq.0 ) then + iwsk=0 + nf=nf+1 + ij(nf)=i-1 + endif + enddo + if (iff(nres).eq.1) then + nf=nf+1 + ij(nf)=nres + endif + + write(linia,'(a6,i3,a1,i3,a1,i3,a1,i3)') + & "SELECT",ij(1)-1,"-",ij(2)-1, + & ",",ij(3)-1,"-",ij(4)-1 + + endif +c +c run optimization +c + call contact_cp_min(var,ieval,in_pdb,linia,debug) + + return + end + + subroutine contact_cp_min(var,ieval,in_pdb,linia,debug) +c +c input : theta,phi,alph,omeg,in_pdb,linia,debug +c output : var,ieval +c + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.SBRIDGE' + include 'COMMON.FFIELD' + include 'COMMON.IOUNITS' + include 'COMMON.DISTFIT' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.MINIM' + + character*50 linia + integer nf,ij(4) + double precision energy(0:n_ene) + double precision var(maxvar) + double precision time0,time1 + integer ieval,info(3) + logical debug,fail,check_var,reduce,change + + write(iout,'(a20,i6,a20)') + & '------------------',in_pdb,'-------------------' + + if (debug) then + call chainbuild + call write_pdb(1000+in_pdb,'combined structure',0d0) +#ifdef MPI + time0=MPI_WTIME() +#else + time0=tcpu() +#endif + endif + +c +c run optimization of distances +c +c uses d0(),w() and mask() for frozen 2D +c +ctest--------------------------------------------- +ctest NX=NRES-3 +ctest NY=((NRES-4)*(NRES-5))/2 +ctest call distfit(debug,5000) + + do i=1,nres + mask_side(i)=0 + enddo + + ipot01=ipot + maxmin01=maxmin + maxfun01=maxfun +c wstrain01=wstrain + wsc01=wsc + wscp01=wscp + welec01=welec + wvdwpp01=wvdwpp +c wang01=wang + wscloc01=wscloc + wtor01=wtor + wtor_d01=wtor_d + + ipot=6 + maxmin=2000 + maxfun=4000 +c wstrain=1.0 + wsc=0.0 + wscp=0.0 + welec=0.0 + wvdwpp=0.0 +c wang=0.0 + wscloc=0.0 + wtor=0.0 + wtor_d=0.0 + + call geom_to_var(nvar,var) +cde change=reduce(var) + if (check_var(var,info)) then + write(iout,*) 'cp_min error in input' + print *,'cp_min error in input' + return + endif + +cd call etotal(energy(0)) +cd call enerprint(energy(0)) +cd call check_eint + +#ifdef MPI + time0=MPI_WTIME() +#else + time0=tcpu() +#endif +cdtest call minimize(etot,var,iretcode,nfun) +cdtest write(iout,*)'SUMSL return code is',iretcode,' eval SDIST',nfun +#ifdef MPI + time1=MPI_WTIME() +#else + time1=tcpu() +#endif + +cd call etotal(energy(0)) +cd call enerprint(energy(0)) +cd call check_eint + + do i=1,nres + mask_side(i)=1 + enddo + + ipot=ipot01 + maxmin=maxmin01 + maxfun=maxfun01 +c wstrain=wstrain01 + wsc=wsc01 + wscp=wscp01 + welec=welec01 + wvdwpp=wvdwpp01 +c wang=wang01 + wscloc=wscloc01 + wtor=wtor01 + wtor_d=wtor_d01 +ctest-------------------------------------------------- + + if(debug) then +#ifdef MPI + time1=MPI_WTIME() +#else + time1=tcpu() +#endif + write (iout,'(a,f6.2,a)')' Time for distfit ',time1-time0,' sec' + call write_pdb(2000+in_pdb,'distfit structure',0d0) + endif + + + ipot0=ipot + maxmin0=maxmin + maxfun0=maxfun + wstrain0=wstrain +c +c run soft pot. optimization +c with constrains: +c nhpb,ihpb(),jhpb(),forcon(),dhpb() and hpb_partition +c and frozen 2D: +c mask_phi(),mask_theta(),mask_side(),mask_r +c + ipot=6 + maxmin=2000 + maxfun=4000 + +cde change=reduce(var) +cde if (check_var(var,info)) write(iout,*) 'error before soft' +#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(3000+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 + maxmin=maxmin0 + maxfun=maxfun0 +c +c check overlaps before calling full UNRES minim +c + call var_to_geom(nvar,var) + call chainbuild + call etotal(energy(0)) +#ifdef OSF + write(iout,*) 'N7 ',energy(0) + if (energy(0).ne.energy(0)) then + write(iout,*) 'N7 error - gives NaN',energy(0) + endif +#endif + ieval=1 + if (energy(1).eq.1.0d20) then + write (iout,'(a,1pe14.5)')'#N7_OVERLAP evdw=1d20',energy(1) + call overlap_sc(fail) + if(.not.fail) then + call etotal(energy(0)) + ieval=ieval+1 + write (iout,'(a,1pe14.5)')'#N7_OVERLAP evdw after',energy(1) + else + mask_r=.false. + nhpb= nhpb0 + link_start=1 + link_end=nhpb + wstrain=wstrain0 + return + endif + endif + call flush(iout) +c +cdte time0=MPI_WTIME() +cde change=reduce(var) +cde if (check_var(var,info)) then +cde write(iout,*) 'error before mask dist' +cde call var_to_geom(nvar,var) +cde call chainbuild +cde call write_pdb(10000+in_pdb,'before mask dist',etot) +cde endif +cdte call minimize(etot,var,iretcode,nfun) +cdte write(iout,*)'SUMSL MASK DIST return code is',iretcode, +cdte & ' eval ',nfun +cdte ieval=ieval+nfun +cdte +cdte time1=MPI_WTIME() +cdte write (iout,'(a,f6.2,f8.2,a)') +cdte & ' Time for mask dist min.',time1-time0, +cdte & nfun/(time1-time0),' eval/s' +cdte call flush(iout) + if (debug) then + call var_to_geom(nvar,var) + call chainbuild + call write_pdb(4000+in_pdb,'mask dist',etot) + endif +c +c switch off freezing of 2D and +c run full UNRES optimization with constrains +c + mask_r=.false. +#ifdef MPI + time0=MPI_WTIME() +#else + time0=tcpu() +#endif +cde change=reduce(var) +cde if (check_var(var,info)) then +cde write(iout,*) 'error before dist' +cde call var_to_geom(nvar,var) +cde call chainbuild +cde call write_pdb(11000+in_pdb,'before dist',etot) +cde endif + + call minimize(etot,var,iretcode,nfun) + +cde change=reduce(var) +cde if (check_var(var,info)) then +cde write(iout,*) 'error after dist',ico +cde call var_to_geom(nvar,var) +cde call chainbuild +cde call write_pdb(12000+in_pdb+ico*1000,'after dist',etot) +cde endif + write(iout,*)'SUMSL DIST 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 dist min.',time1-time0, + & nfun/(time1-time0),' eval/s' +cde call etotal(energy(0)) +cde write(iout,*) 'N7 after dist',energy(0) + call flush(iout) + + if (debug) then + call var_to_geom(nvar,var) + call chainbuild + call write_pdb(in_pdb,linia,etot) + endif +c +c reset constrains +c + nhpb= nhpb0 + link_start=1 + link_end=nhpb + wstrain=wstrain0 + + 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 + + + subroutine beta_slide(i1,i2,i3,i4,i5,ieval,ij) + 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) + integer jdata(5),isec(maxres) +c + jdata(1)=i1 + jdata(2)=i2 + jdata(3)=i3 + jdata(4)=i4 + jdata(5)=i5 + + call secondary2(.false.) + + do i=1,nres + isec(i)=0 + enddo + do j=1,nbfrag + do i=bfrag(1,j),bfrag(2,j) + isec(i)=1 + enddo + do i=bfrag(4,j),bfrag(3,j),sign(1,bfrag(3,j)-bfrag(4,j)) + isec(i)=1 + enddo + enddo + do j=1,nhfrag + do i=hfrag(1,j),hfrag(2,j) + isec(i)=2 + enddo + enddo + +c +c cut strands at the ends +c + if (jdata(2)-jdata(1).gt.3) then + jdata(1)=jdata(1)+1 + jdata(2)=jdata(2)-1 + if (jdata(3).lt.jdata(4)) then + jdata(3)=jdata(3)+1 + jdata(4)=jdata(4)-1 + else + jdata(3)=jdata(3)-1 + jdata(4)=jdata(4)+1 + endif + endif + +cv call chainbuild +cv call etotal(energy(0)) +cv etot=energy(0) +cv write(iout,*) nnt,nct,etot +cv call write_pdb(ij*100,'first structure',etot) +cv write(iout,*) 'N16 test',(jdata(i),i=1,5) + +c------------------------ +c generate constrains +c + ishift=jdata(5)-2 + if(ishift.eq.0) ishift=-2 + nhpb0=nhpb + call chainbuild + do i=jdata(1),jdata(2) + isec(i)=-1 + if(jdata(4).gt.jdata(3))then + do j=jdata(3)+i-jdata(1)-2,jdata(3)+i-jdata(1)+2 + isec(j)=-1 +cd print *,i,j,j+ishift + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=1000.0 + dhpb(nhpb)=DIST(i,j+ishift) + enddo + else + do j=jdata(3)-i+jdata(1)+2,jdata(3)-i+jdata(1)-2,-1 + isec(j)=-1 +cd print *,i,j,j+ishift + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=1000.0 + dhpb(nhpb)=DIST(i,j+ishift) + enddo + endif + enddo + + do i=nnt,nct-2 + do j=i+2,nct + if(isec(i).gt.0.or.isec(j).gt.0) then +cd print *,i,j + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=0.1 + dhpb(nhpb)=DIST(i,j) + endif + enddo + enddo + + call hpb_partition + + call geom_to_var(nvar,var) + maxfun0=maxfun + wstrain0=wstrain + maxfun=4000/5 + + do ico=1,5 + + wstrain=wstrain0/ico + + 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=ieval+nfun + + enddo +c + nhpb=nhpb0 + call hpb_partition + wstrain=wstrain0 + maxfun=maxfun0 +c +cd print *,etot + wscloc0=wscloc + wscloc=10.0 + call sc_move(nnt,nct,100,100d0,nft_sc,etot) + wscloc=wscloc0 +cv call chainbuild +cv call etotal(energy(0)) +cv etot=energy(0) +cv call write_pdb(ij*100+10,'sc_move',etot) +cd call intout +cd print *,nft_sc,etot + + return + end + + subroutine beta_zip(i1,i2,ieval,ij) + 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) + character*10 test + +cv call chainbuild +cv call etotal(energy(0)) +cv etot=energy(0) +cv write(test,'(2i5)') i1,i2 +cv call write_pdb(ij*100,test,etot) +cv write(iout,*) 'N17 test',i1,i2,etot,ij + +c +c generate constrains +c + nhpb0=nhpb + nhpb=nhpb+1 + ihpb(nhpb)=i1 + jhpb(nhpb)=i2 + forcon(nhpb)=1000.0 + dhpb(nhpb)=4.0 + + call hpb_partition + + call geom_to_var(nvar,var) + maxfun0=maxfun + wstrain0=wstrain + maxfun=1000/5 + + do ico=1,5 + wstrain=wstrain0/ico + 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=ieval+nfun +c do not comment the next line + call var_to_geom(nvar,var) +cv call chainbuild +cv call write_pdb(ij*100+ico,'dist cons',etot) + enddo + + nhpb=nhpb0 + call hpb_partition + wstrain=wstrain0 + maxfun=maxfun0 + +cv call etotal(energy(0)) +cv etot=energy(0) +cv write(iout,*) 'N17 test end',i1,i2,etot,ij + + + return + end diff --git a/source/unres/src_CSA_DiL/timing.F b/source/unres/src_CSA_DiL/timing.F new file mode 100644 index 0000000..340ff3d --- /dev/null +++ b/source/unres/src_CSA_DiL/timing.F @@ -0,0 +1,340 @@ +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' +c 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 + 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 diff --git a/source/unres/src_CSA_DiL/together.F b/source/unres/src_CSA_DiL/together.F new file mode 100644 index 0000000..8bc9d7a --- /dev/null +++ b/source/unres/src_CSA_DiL/together.F @@ -0,0 +1,1293 @@ +#ifdef MPI + Subroutine together +c feeds tasks for parallel processing + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'mpif.h' + real ran1,ran2 + include 'COMMON.CSA' + include 'COMMON.BANK' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.TIME1' + include 'COMMON.SETUP' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.CONTROL' + include 'COMMON.SBRIDGE' + real tcpu + double precision time_start,time_start_c,time0f,time0i + logical ovrtim,sync_iter,timeout,flag,timeout1 + dimension muster(mpi_status_size) + dimension t100(0:100),indx(mxio) + dimension xout(maxvar),eout(mxch*(mxch+1)/2+1),ind(9) + dimension cout(2) + parameter (rad=1.745329252d-2) + +cccccccccccccccccccccccccccccccccccccccccccccccc + IF (ME.EQ.KING) THEN + + time0f=MPI_WTIME() + ilastnstep=1 + sync_iter=.false. + numch=1 + nrmsdb=0 + nrmsdb1=0 + rmsdbc1c=rmsdbc1 + nstep=0 + call csa_read + call make_array + + if(iref.ne.0) call from_int(1,0,idum) + +c To minimize input conformation (bank conformation) +c Output to $mol.reminimized + if (irestart.lt.0) then + call read_bank(0,nft,cutdifr) + if (irestart.lt.-10) then + p_cut=nres*4.d0 + call prune_bank(p_cut) + return + endif + call reminimize(jlee) + return + endif + + if (irestart.eq.0) then + call initial_write + nbank=nconf + ntbank=nconf + if (ntbankm.eq.0) ntbank=0 + nstep=0 + nft=0 + do i=1,mxio + ibank(i)=0 + jbank(i)=0 + enddo + else + call restart_write +c!bankt call read_bankt(jlee,nft,cutdifr) + call read_bank(jlee,nft,cutdifr) + call read_rbank(jlee,adif) + if(iref.ne.0) call from_int(1,0,idum) + endif + + nstmax=nstmax+nstep + ntrial=n1+n2+n3+n4+n5+n6+n7+n8 + ntry=ntrial+1 + ntry=ntry*nseed + +c ntrial : number of trial conformations per seed. +c ntry : total number of trial conformations including seed conformations. + + idum2=-123 +#ifdef G77 + imax=2**30-1 +#else + imax=2**31-1 +#endif + ENDIF + + call mpi_bcast(jend,1,mpi_integer,0,CG_COMM,ierr) +cccccccccccccccccccccccccccccccccccccccc + do 300 jlee=1,jend +cccccccccccccccccccccccccccccccccccccccc + 331 continue + IF (ME.EQ.KING) THEN + if(sync_iter) goto 333 + idum=- ran2(idum2)*imax + if(jlee.lt.jstart) goto 300 + +C Restart the random number generator for conformation generation + + if(irestart.gt.0) then + idum2=idum2+nstep + if(idum2.le.0) idum2=-idum2+1 + idum=- ran2(idum2)*imax + endif + + idumm=idum + call vrndst(idumm) + + open(icsa_seed,file=csa_seed,status="old") + write(icsa_seed,*) "jlee : ",jlee + close(icsa_seed) + + call history_append + write(icsa_history,*) "number of procs is ",nodes + write(icsa_history,*) jlee,idum,idum2 + close(icsa_history) + +cccccccccccccccccccccccccccccccccccccccccccccccc + 333 icycle=0 + + call history_append + write(icsa_history,*) "nbank is ",nbank + close(icsa_history) + + if(irestart.eq.1) goto 111 + if(irestart.eq.2) then + icycle=0 + do i=1,nbank + ibank(i)=1 + enddo + do i=nbank+1,nbank+nconf + ibank(i)=0 + enddo + endif + +c start energy minimization + nconfr=max0(nconf+nadd,nodes-1) + if (sync_iter) nconf_in=0 +c king-emperor - feed input and sort output + write (iout,*) "NCONF_IN",nconf_in + m=0 + if (nconf_in.gt.0) then +c al 7/2/00 - added possibility to read in some of the initial conformations + do m=1,nconf_in + read (intin,'(i5)',end=11,err=12) iconf + 12 continue + write (iout,*) "write READ_ANGLES",iconf,m + call read_angles(intin,*11) + if (iref.eq.0) then + mm=m + else + mm=m+1 + endif + do j=2,nres-1 + dihang_in(1,j,1,mm)=theta(j+1) + dihang_in(2,j,1,mm)=phi(j+2) + dihang_in(3,j,1,mm)=alph(j) + dihang_in(4,j,1,mm)=omeg(j) + enddo + enddo ! m + goto 13 + 11 write (iout,*) nconf_in," conformations requested, but only", + & m-1," found in the angle file." + nconf_in=m-1 + 13 continue + m=nconf_in + write (iout,*) nconf_in, + & " initial conformations have been read in." + endif + if (iref.eq.0) then + if (nconfr.gt.nconf_in) then + call make_ranvar(nconfr,m,idum) + write (iout,*) nconfr-nconf_in, + & " conformations have been generated randomly." + endif + else + nconfr=nconfr*2 + call from_int(nconfr,m,idum) +c call from_pdb(nconfr,idum) + endif + write (iout,*) 'Exitted from make_ranvar nconfr=',nconfr + write (*,*) 'Exitted from make_ranvar nconfr=',nconfr + do m=1,nconfr + write (iout,*) 'Initial conformation',m + write(iout,'(8f10.4)') (rad2deg*dihang_in(1,j,1,m),j=2,nres-1) + write(iout,'(8f10.4)') (rad2deg*dihang_in(2,j,1,m),j=2,nres-1) + write(iout,'(8f10.4)') (rad2deg*dihang_in(3,j,1,m),j=2,nres-1) + write(iout,'(8f10.4)') (rad2deg*dihang_in(4,j,1,m),j=2,nres-1) + enddo + write(iout,*)'Calling FEEDIN NCONF',nconfr + time1i=MPI_WTIME() + call feedin(nconfr,nft) + write (iout,*) ' Time for first bank min.',MPI_WTIME()-time1i + call history_append + write(icsa_history,*) jlee,nft,nbank + write(icsa_history,851) (etot(i),i=1,nconfr) + write(icsa_history,850) (rmsn(i),i=1,nconfr) + write(icsa_history,850) (pncn(i),i=1,nconfr) + write(icsa_history,*) + close(icsa_history) + ELSE +c To minimize input conformation (bank conformation) +c Output to $mol.reminimized + if (irestart.lt.0) then + call reminimize(jlee) + return + endif + if (irestart.eq.1) goto 111 +c soldier - perform energy minimization + 334 call minim_jlee + + + ENDIF + +ccccccccccccccccccccccccccccccccccc +c need to syncronize all procs + call mpi_barrier(CG_COMM,ierr) + if (ierr.ne.0) then + print *, ' cannot synchronize MPI' + stop + endif +ccccccccccccccccccccccccccccccccccc + + IF (ME.EQ.KING) THEN + +c print *,"ok after minim" + nstep=nstep+nconf + if(irestart.eq.2) then + nbank=nbank+nconf +c ntbank=ntbank+nconf + if(ntbank.gt.ntbankm) ntbank=ntbankm + endif +c print *,"ok before indexx" + if(iref.eq.0) then + call indexx(nconfr,etot,indx) + else +c cc/al 7/6/00 + do k=1,nconfr + indx(k)=k + enddo + call indexx(nconfr-nconf_in,rmsn(nconf_in+1),indx(nconf_in+1)) + do k=nconf_in+1,nconfr + indx(k)=indx(k)+nconf_in + enddo +c cc/al +c call indexx(nconfr,rmsn,indx) + endif +c print *,"ok after indexx" + do im=1,nconf + m=indx(im) + if (m.gt.mxio .or. m.lt.1) then + write (iout,*) 'Dimension ERROR in TOGEHER: IM',im,' M',m + call mpi_abort(mpi_comm_world,ierror,ierrcode) + endif + jbank(im+nbank-nconf)=0 + bene(im+nbank-nconf)=etot(m) + rene(im+nbank-nconf)=etot(m) +c!bankt btene(im)=etot(m) +c + brmsn(im+nbank-nconf)=rmsn(m) + bpncn(im+nbank-nconf)=pncn(m) + rrmsn(im+nbank-nconf)=rmsn(m) + rpncn(im+nbank-nconf)=pncn(m) + if (im+nbank-nconf.gt.mxio .or. im+nbank-nconf.lt.1) then + write (iout,*) 'Dimension ERROR in TOGEHER: IM',im, + & ' NBANK',nbank,' NCONF',nconf,' IM+NBANK-NCONF',im+nbank-nconf + call mpi_abort(mpi_comm_world,ierror,ierrcode) + endif + do k=1,numch + do j=2,nres-1 + do i=1,4 + bvar(i,j,k,im+nbank-nconf)=dihang(i,j,k,m) + rvar(i,j,k,im+nbank-nconf)=dihang(i,j,k,m) +c!bankt btvar(i,j,k,im)=dihang(i,j,k,m) +c + enddo + enddo + enddo + if(iref.eq.1) then + if(brmsn(im+nbank-nconf).gt.rmscut.or. + & bpncn(im+nbank-nconf).lt.pnccut) ibank(im+nbank-nconf)=9 + endif + if(vdisulf) then + bvar_ns(im+nbank-nconf)=ns-2*nss + k=0 + do i=1,ns + j=1 + do while( iss(i).ne.ihpb(j)-nres .and. + & iss(i).ne.jhpb(j)-nres .and. j.le.nss) + j=j+1 + enddo + if (j.gt.nss) then + k=k+1 + bvar_s(k,im+nbank-nconf)=iss(i) + endif + enddo + endif + bvar_nss(im+nbank-nconf)=nss + do i=1,nss + bvar_ss(1,i,im+nbank-nconf)=ihpb(i) + bvar_ss(2,i,im+nbank-nconf)=jhpb(i) + enddo + enddo + ENDIF + + 111 continue + + IF (ME.EQ.KING) THEN + + call find_max + call find_min + + if (tm_score) then + call get_diff_p + else + call get_diff + endif + if(nbank.eq.nconf.and.irestart.eq.0) then + adif=avedif + endif + + write (iout,*) "AVEDIF",avedif + cutdif=adif/cut1 + ctdif1=adif/cut2 + +cd print *,"adif,xctdif,cutdifr" +cd print *,adif,xctdif,cutdifr + nst=ntotal/ntrial/nseed + xctdif=(cutdif/ctdif1)**(-1.0/nst) + if(irestart.ge.1) call estimate_cutdif(adif,xctdif,cutdifr) +c print *,"ok after estimate" + + irestart=0 + + call write_rbank(jlee,adif,nft) + call write_bank(jlee,nft) +c!bankt call write_bankt(jlee,nft) +c call write_bank1(jlee) + call history_append + write(icsa_history,*) "xctdif: ", xctdif,nst,adif/cut1,ctdif1 + write(icsa_history,851) (bene(i),i=1,nbank) + write(icsa_history,850) (brmsn(i),i=1,nbank) + write(icsa_history,850) (bpncn(i),i=1,nbank) + close(icsa_history) + 850 format(10f8.3) + 851 format(5e15.6) + + ifar=nseed/4*3+1 + ifar=nseed+1 + ENDIF + + + finished=.false. + iter = 0 + irecv = 0 + isent =0 + ifrom= 0 + time0i=MPI_WTIME() + time1i=time0i + time_start_c=time0i + if (.not.sync_iter) then + time_start=time0i + nft00=nft + else + sync_iter=.false. + endif + nft00_c=nft + nft0i=nft +ccccccccccccccccccccccccccccccccccccccc + do while (.not. finished) +ccccccccccccccccccccccccccccccccccccccc +crc print *,"iter ", iter,' isent=',isent + + IF (ME.EQ.KING) THEN +c start energy minimization + + if (isent.eq.0) then +c king-emperor - select seeds & make var & feed input +cd print *,'generating new conf',ntrial,MPI_WTIME() + call select_is(nseed,ifar,idum) + + open(icsa_seed,file=csa_seed,status="old") + write(icsa_seed,39) + & jlee,icycle,nstep,(is(i),bene(is(i)),i=1,nseed) + close(icsa_seed) + call history_append + write(icsa_history,40) jlee,icycle,nstep,cutdif,ibmin,ibmax, + * ebmin,ebmax,nft,iuse,nbank,ntbank + close(icsa_history) + + + + call make_var(ntry,idum,iter) +cd print *,'new trial generated',ntrial,MPI_WTIME() + time2i=MPI_WTIME() + write (iout,'(a20,i4,f12.2)') + & 'Time for make trial',iter+1,time2i-time1i + endif + +crc write(iout,*)'1:Calling FEEDIN NTRY',NTRY,' ntrial',ntrial +crc call feedin(ntry,nft) + + isent=isent+1 + if (isent.ge.nodes.or.iter.gt.0) then +ct print *,'waiting ',MPI_WTIME() + irecv=irecv+1 + call recv(0,ifrom,xout,eout,ind,timeout) +ct print *,' ',irecv,' received from',ifrom,MPI_WTIME() + + if(tm_score) then + nft=nft+ind(3) + movernx(irecv)=iabs(ind(5)) + call getx(ind,xout,eout,cout,rad,iw_pdb,irecv) + if(vdisulf) then + nss_out(irecv)=nss + do i=1,nss + iss_out(i,irecv)=ihpb(i) + jss_out(i,irecv)=jhpb(i) + enddo + endif + if(iw_pdb.gt.0) + & call write_csa_pdb(xout,eout,nft,irecv,iw_pdb) + endif + + if(tm_score.and.eout(1).lt.ebmax) then + if(iref.eq.0 .or. + & (rmsn(irecv).le.rmscut.and.pncn(irecv).ge.pnccut)) + & call refresh_bank_master_tmscore(ifrom,eout(1),irecv) + endif + else + ifrom=ifrom+1 + endif + +ct print *,'sending to',ifrom,MPI_WTIME() + call send(isent,ifrom,iter) +ct print *,isent,' sent ',MPI_WTIME() + +c store results ----------------------------------------------- + if ((isent.ge.nodes.or.iter.gt.0).and..not.tm_score) then + nft=nft+ind(3) + movernx(irecv)=iabs(ind(5)) + call getx(ind,xout,eout,cout,rad,iw_pdb,irecv) + if(vdisulf) then + nss_out(irecv)=nss + do i=1,nss + iss_out(i,irecv)=ihpb(i) + jss_out(i,irecv)=jhpb(i) + enddo + endif + if(iw_pdb.gt.0) + & call write_csa_pdb(xout,eout,nft,irecv,iw_pdb) + endif +c-------------------------------------------------------------- + if (isent.eq.ntry) then + time1i=MPI_WTIME() + write (iout,'(a18,f12.2,a14,f10.2)') + & 'Nonsetup time ',time1i-time_start_c, + & ' sec, Eval/s =',(nft-nft00_c)/(time1i-time_start_c) + write (iout,'(a14,i4,f12.2,a14,f10.2)') + & 'Time for iter ',iter+1,time1i-time0i, + & ' sec, Eval/s =',(nft-nft0i)/(time1i-time0i) + time0i=time1i + nft0i=nft + cutdif=cutdif*xctdif + if(cutdif.lt.ctdif1) cutdif=ctdif1 + if (iter.eq.0) then + print *,'UPDATING ',ntry-nodes+1,irecv + write(iout,*) 'UPDATING ',ntry-nodes+1 + iter=iter+1 +c----------------- call update(ntry-nodes+1) ------------------- + nstep=nstep+ntry-nseed-(nodes-1) + if (tm_score) then +ctm call refresh_bank(ntry) + call print_mv_stat + do i=0,mxmv + do j=1,3 + nstatnx_tot(i,j)=nstatnx_tot(i,j)+nstatnx(i,j) + nstatnx(i,j)=0 + enddo + enddo + else + call refresh_bank(ntry-nodes+1) + endif +c!bankt call refresh_bankt(ntry-nodes+1) + else +c----------------- call update(ntry) --------------------------- + iter=iter+1 + print *,'UPDATING ',ntry,irecv + write(iout,*) 'UPDATING ',ntry + nstep=nstep+ntry-nseed + if (tm_score) then +ctm call refresh_bank(ntry) + call print_mv_stat + do i=0,mxmv + do j=1,3 + nstatnx_tot(i,j)=nstatnx_tot(i,j)+nstatnx(i,j) + nstatnx(i,j)=0 + enddo + enddo + else + call refresh_bank(ntry) + endif +c!bankt call refresh_bankt(ntry) + endif +c----------------------------------------------------------------- + + call write_bank(jlee,nft) +c!bankt call write_bankt(jlee,nft) + call find_min + + time1i=MPI_WTIME() + write (iout,'(a20,i4,f12.2)') + & 'Time for refresh ',iter,time1i-time0i + + if(ebmin.lt.estop) finished=.true. + if(icycle.gt.icmax) then + call write_bank1(jlee) + do i=1,nbank +c ibank(i)=2 + ibank(i)=1 + enddo + nbank=nbank+nconf + if(nbank.gt.nbankm) then + nbank=nbank-nconf + finished=.true. + else +crc goto 333 + sync_iter=.true. + endif + endif + if(nstep.gt.nstmax) finished=.true. + + if(finished.or.sync_iter) then + do ij=1,nodes-1 + call recv(1,ifrom,xout,eout,ind,timeout) + if (timeout) then + nstep=nstep+ij-1 + print *,'ERROR worker is not responding' + write(iout,*) 'ERROR worker is not responding' + time1i=MPI_WTIME()-time_start_c + print *,'End of cycle, master time for ',iter,' iters ', + & time1i,'sec, Eval/s ',(nft-nft00_c)/time1i + write (iout,*) 'End of cycle, master time for ',iter, + & ' iters ',time1i,' sec' + write (iout,*) 'Total eval/s ',(nft-nft00_c)/time1i + print *,'UPDATING ',ij-1 + write(iout,*) 'UPDATING ',ij-1 + call flush(iout) + call refresh_bank(ij-1) +c!bankt call refresh_bankt(ij-1) + goto 1002 + endif +c print *,'node ',ifrom,' finished ',ij,nft + write(iout,*) 'node ',ifrom,' finished ',ij,nft + call flush(iout) + nft=nft+ind(3) + movernx(ij)=iabs(ind(5)) + call getx(ind,xout,eout,cout,rad,iw_pdb,ij) + if(vdisulf) then + nss_out(ij)=nss + do i=1,nss + iss_out(i,ij)=ihpb(i) + jss_out(i,ij)=jhpb(i) + enddo + endif + if(iw_pdb.gt.0) + & call write_csa_pdb(xout,eout,nft,ij,iw_pdb) + enddo + nstep=nstep+nodes-1 +crc print *,'---------bcast finished--------',finished + time1i=MPI_WTIME()-time_start_c + print *,'End of cycle, master time for ',iter,' iters ', + & time1i,'sec, Eval/s ',(nft-nft00_c)/time1i + write (iout,*) 'End of cycle, master time for ',iter, + & ' iters ',time1i,' sec' + write (iout,*) 'Total eval/s ',(nft-nft00_c)/time1i + +ctimeout call mpi_bcast(finished,1,mpi_logical,0,CG_COMM,ierr) +ctimeout call mpi_bcast(sync_iter,1,mpi_logical,0, +ctimeout & CG_COMM,ierr) + do ij=1,nodes-1 + tstart=MPI_WTIME() + call mpi_issend(finished,1,mpi_logical,ij,idchar, + & CG_COMM,ireq,ierr) + call mpi_issend(sync_iter,1,mpi_logical,ij,idchar, + & CG_COMM,ireq2,ierr) + flag=.false. + timeout1=.false. + do while(.not. (flag .or. timeout1)) + call MPI_TEST(ireq2,flag,muster,ierr) + tend1=MPI_WTIME() + if(tend1-tstart.gt.60) then + print *,'ERROR worker ',ij,' is not responding' + write(iout,*) 'ERROR worker ',ij,' is not responding' + timeout1=.true. + endif + enddo + if(timeout1) then + write(iout,*) 'worker ',ij,' NOT OK ',tend1-tstart + timeout=.true. + else + write(iout,*) 'worker ',ij,' OK ',tend1-tstart + endif + enddo + print *,'UPDATING ',nodes-1,ij + write(iout,*) 'UPDATING ',nodes-1 + call refresh_bank(nodes-1) +c!bankt call refresh_bankt(nodes-1) + 1002 continue + call write_bank(jlee,nft) +c!bankt call write_bankt(jlee,nft) + call find_min + + do i=0,mxmv + do j=1,3 + nstatnx_tot(i,j)=nstatnx_tot(i,j)+nstatnx(i,j) + nstatnx(i,j)=0 + enddo + enddo + + write(iout,*)'### Total stats:' + do i=0,mxmv + if(nstatnx_tot(i,1).ne.0) then + if (i.le.9) then + write(iout,'(a5,i1,a7,i6,a7,i4,a5,i4,a5,f5.1)') + & '### N',i,' total=',nstatnx_tot(i,1), + & ' close=',nstatnx_tot(i,2),' far=',nstatnx_tot(i,3),'%acc', + & (nstatnx_tot(i,2)+nstatnx_tot(i,3))*100.0/nstatnx_tot(i,1) + else + write(iout,'(a4,i2,a7,i6,a7,i4,a5,i4,a5,f5.1)') + & '###N',i,' total=',nstatnx_tot(i,1), + & ' close=',nstatnx_tot(i,2),' far=',nstatnx_tot(i,3),'%acc', + & (nstatnx_tot(i,2)+nstatnx_tot(i,3))*100.0/nstatnx_tot(i,1) + endif + else + if (i.le.9) then + write(iout,'(a5,i1,a7,i6,a7,i4,a5,i4,a5,f5.1)') + & '### N',i,' total=',nstatnx_tot(i,1), + & ' close=',nstatnx_tot(i,2),' far=',nstatnx_tot(i,3), + & ' %acc',0.0 + else + write(iout,'(a4,i2,a7,i6,a7,i4,a5,i4,a5,f5.1)') + & '###N',i,' total=',nstatnx_tot(i,1), + & ' close=',nstatnx_tot(i,2),' far=',nstatnx_tot(i,3), + & ' %acc',0.0 + endif + endif + enddo + + endif + if(sync_iter) goto 331 + + 39 format(2i3,i7,5(i4,f8.3,1x),19(/,13x,5(i4,f8.3,1x))) + 40 format(2i2,i8,f8.1,2i4,2(1pe14.5),i10,3i4) + 43 format(10i8) + 44 format('jlee =',i3,':',4f10.1,' E =',f15.5,i7,i10) + + isent=0 + irecv=0 + endif + ELSE + if (tm_score) then + call get_diff_p + endif +c soldier - perform energy minimization + call minim_jlee + print *,'End of minim, proc',me,'time ',MPI_WTIME()-time_start + write (iout,*) 'End of minim, proc',me,'time ', + & MPI_WTIME()-time_start + call flush(iout) +ctimeout call mpi_bcast(finished,1,mpi_logical,0,CG_COMM,ierr) +ctimeout call mpi_bcast(sync_iter,1,mpi_logical,0,CG_COMM,ierr) + call mpi_recv(finished,1,mpi_logical,0,idchar, + * CG_COMM,muster,ierr) + call mpi_recv(sync_iter,1,mpi_logical,0,idchar, + * CG_COMM,muster,ierr) + if(sync_iter) goto 331 + ENDIF + +ccccccccccccccccccccccccccccccccccccccc + enddo +ccccccccccccccccccccccccccccccccccccccc + + IF (ME.EQ.KING) THEN + call history_append + write(icsa_history,40) jlee,icycle,nstep,cutdif,ibmin,ibmax, + * ebmin,ebmax,nft,iuse,nbank,ntbank + + write(icsa_history,44) jlee,0.0,0.0,0.0, + & 0.0,ebmin,nstep,nft + write(icsa_history,*) + close(icsa_history) + + time1i=MPI_WTIME()-time_start + print *,'End of RUN, master time ', + & time1i,'sec, Eval/s ',(nft-nft00)/time1i + write (iout,*) 'End of RUN, master time ', + & time1i,' sec' + write (iout,*) 'Total eval/s ',(nft-nft00)/time1i + + if(timeout) then + write(iout,*) '!!!! ERROR worker was not responding' + write(iout,*) '!!!! cannot finish work normally' + write(iout,*) 'Processor0 is calling MPI_ABORT' + print *,'!!!! ERROR worker was not responding' + print *,'!!!! cannot finish work normally' + print *,'Processor0 is calling MPI_ABORT' + call flush(iout) + call mpi_abort(mpi_comm_world, 111, ierr) + endif + ENDIF + +cccccccccccccccccccccccccccccc + 300 continue +cccccccccccccccccccccccccccccc + + return + end +#else + Subroutine together +c feeds tasks for parallel processing + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + write (iout,*) "Unsupported option for the serial version" + return + end +#endif +#ifdef MPI +c------------------------------------------------- + subroutine feedin(nconf,nft) +c sends out starting conformations and receives results of energy minimization + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.CONTROL' + include 'mpif.h' + dimension xin(maxvar),xout(maxvar),eout(mxch*(mxch+1)/2+1), + * cout(2),ind(9),info(12) + dimension muster(mpi_status_size) + include 'COMMON.SETUP' + parameter (rad=1.745329252d-2) + + print *,'FEEDIN: NCONF=',nconf + mm=0 +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + if (nconf .lt. nodes-1) then + write (*,*) 'FATAL ERROR in FEEDIN, nconf < nodes -1', + & nconf,nodes-1 + write (iout,*) 'FATAL ERROR in FEEDIN, nconf < nodes -1', + & nconf,nodes-1 + call mpi_abort(mpi_comm_world,ierror,ierrcode) + endif + do n=1,nconf +c pull out external and internal variables for next start + call putx(xin,n,rad) +! write (iout,*) 'XIN from FEEDIN N=',n +! write(iout,'(8f10.4)') (xin(j),j=1,nvar) + mm=mm+1 + if (mm.lt.nodes) then +c feed task to soldier +! print *, ' sending input for start # ',n + info(1)=n + info(2)=-1 + info(3)=0 + info(4)=0 + info(5)=0 + info(6)=0 + call mpi_send(info,12,mpi_integer,mm,idint,CG_COMM, + * ierr) + call mpi_send(xin,nvar,mpi_double_precision,mm, + * idreal,CG_COMM,ierr) + else +c find an available soldier + call mpi_recv(ind,9,mpi_integer,mpi_any_source,idint, + * CG_COMM,muster,ierr) +! print *, ' receiving output from start # ',ind(1) + man=muster(mpi_source) +c receive final energies and variables + nft=nft+ind(3) + call mpi_recv(eout,1,mpi_double_precision, + * man,idreal,CG_COMM,muster,ierr) +! print *,eout +#ifdef CO_BIAS + call mpi_recv(co,1,mpi_double_precision, + * man,idreal,CG_COMM,muster,ierr) + write (iout,'(a15,f3.2,$)') ' BIAS by contact order*100 ',co +#endif + call mpi_recv(xout,nvar,mpi_double_precision, + * man,idreal,CG_COMM,muster,ierr) +! print *,nvar , ierr +c feed next task to soldier +! print *, ' sending input for start # ',n + info(1)=n + info(2)=-1 + info(3)=0 + info(4)=0 + info(5)=0 + info(6)=0 + info(7)=0 + info(8)=0 + info(9)=0 + call mpi_send(info,12,mpi_integer,man,idint,CG_COMM, + * ierr) + call mpi_send(xin,nvar,mpi_double_precision,man, + * idreal,CG_COMM,ierr) +c retrieve latest results + call getx(ind,xout,eout,cout,rad,iw_pdb,ind(1)) + if(iw_pdb.gt.0) + & call write_csa_pdb(xout,eout,nft,ind(1),iw_pdb) + endif + enddo +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c no more input +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + do j=1,nodes-1 +c wait for a soldier + call mpi_recv(ind,9,mpi_integer,mpi_any_source,idint, + * CG_COMM,muster,ierr) +crc if (ierr.ne.0) go to 30 +! print *, ' receiving output from start # ',ind(1) + man=muster(mpi_source) +c receive final energies and variables + nft=nft+ind(3) + call mpi_recv(eout,1, + * mpi_double_precision,man,idreal, + * CG_COMM,muster,ierr) +! print *,eout +#ifdef CO_BIAS + call mpi_recv(co,1,mpi_double_precision, + * man,idreal,CG_COMM,muster,ierr) + write (iout,'(a15,f3.2,$)') ' BIAS by contact order*100 ',co +#endif +crc if (ierr.ne.0) go to 30 + call mpi_recv(xout,nvar,mpi_double_precision, + * man,idreal,CG_COMM,muster,ierr) +! print *,nvar , ierr +crc if (ierr.ne.0) go to 30 +c halt soldier + info(1)=0 + info(2)=-1 + info(3)=0 + info(4)=0 + info(5)=0 + info(6)=0 + call mpi_send(info,12,mpi_integer,man,idint,CG_COMM, + * ierr) +c retrieve results + call getx(ind,xout,eout,cout,rad,iw_pdb,ind(1)) + if(iw_pdb.gt.0) + & call write_csa_pdb(xout,eout,nft,ind(1),iw_pdb) + enddo +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + return + 10 print *, ' dispatching error' + call mpi_abort(mpi_comm_world,ierror,ierrcode) + return + 20 print *, ' communication error' + call mpi_abort(mpi_comm_world,ierror,ierrcode) + return + 30 print *, ' receiving error' + call mpi_abort(mpi_comm_world,ierror,ierrcode) + return + end +cccccccccccccccccccccccccccccccccccccccccccccccccc + subroutine getx(ind,xout,eout,cout,rad,iw_pdb,k) +c receives and stores data from soldiers + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CSA' + include 'COMMON.BANK' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.CONTACTS' + dimension ind(9),xout(maxvar),eout(mxch*(mxch+1)/2+1) +cjlee + double precision przes(3),obr(3,3) + logical non_conv +cjlee + iw_pdb=2 + if (k.gt.mxio .or. k.lt.1) then + write (iout,*) + & 'ERROR - dimensions of ANGMIN have been exceeded K=',k + call mpi_abort(mpi_comm_world,ierror,ierrcode) + endif +c store ind() + do j=1,9 + indb(k,j)=ind(j) + enddo +c store energies + etot(k)=eout(1) +c retrieve dihedral angles etc + call var_to_geom(nvar,xout) + do j=2,nres-1 + dihang(1,j,1,k)=theta(j+1) + dihang(2,j,1,k)=phi(j+2) + dihang(3,j,1,k)=alph(j) + dihang(4,j,1,k)=omeg(j) + enddo + dihang(2,nres-1,1,k)=0.0d0 +cjlee + if(iref.eq.0) then + iw_pdb=1 +cd write(iout,'(i3,a3,i4,i5,a6,1pe12.4,a4,i3,i4)') +cd & ind(2),' e ',ind(3),ind(1),' etot ',etot(k),' mv ', +cd & ind(5),ind(4) + return + endif + call chainbuild +c call dihang_to_c(dihang(1,1,1,k)) +c call fitsq(rms,c(1,1),crefjlee(1,1),nres,przes,obr,non_conv) +c call fitsq(rms,c(1,2),crefjlee(1,2),nres-1,przes,obr,non_conv) +c call fitsq(rms,c(1,nstart_seq),crefjlee(1,nstart_sup), +c & nsup,przes,obr,non_conv) +c rmsn(k)=dsqrt(rms) + + call rmsd_csa(rmsn(k)) + call contact(.false.,ncont,icont,co) + pncn(k)=contact_fract(ncont,ncont_ref,icont,icont_ref) + +cd write(iout,'(i3,a3,i4,i5,a6,1pe12.4,a5 +cd & ,0pf5.2,a5,f5.1,a,f6.3,a4,i3,i4)') +cd & ind(2),' e ',ind(3),ind(1),' etot ',etot(k),' rms ', +cd & rmsn(k),' %NC ',pncn(k)*100,' cont.order',co,' mv ', +cd & ind(5),ind(4) + + + if (rmsn(k).gt.rmscut.or.pncn(k).lt.pnccut) iw_pdb=0 + return + end +cccccccccccccccccccccccccccccccccccccccccccccccccc + subroutine putx(xin,n,rad) +c gets starting variables + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CSA' + include 'COMMON.BANK' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + dimension xin(maxvar) + +c pull out starting values for variables +! write (iout,*)'PUTX: N=',n + do m=1,numch +! write (iout,'(8f10.4)') (dihang_in(1,j,m,n),j=2,nres-1) +! write (iout,'(8f10.4)') (dihang_in(2,j,m,n),j=2,nres-1) +! write (iout,'(8f10.4)') (dihang_in(3,j,m,n),j=2,nres-1) +! write (iout,'(8f10.4)') (dihang_in(4,j,m,n),j=2,nres-1) + do j=2,nres-1 + theta(j+1)=dihang_in(1,j,m,n) + phi(j+2)=dihang_in(2,j,m,n) + alph(j)=dihang_in(3,j,m,n) + omeg(j)=dihang_in(4,j,m,n) + enddo + enddo +c set up array of variables + call geom_to_var(nvar,xin) +! write (iout,*) 'xin in PUTX N=',n +! call intout +! write (iout,'(8f10.4)') (xin(i),i=1,nvar) + return + end +c-------------------------------------------------------- + subroutine putx2(xin,iff,n) +c gets starting variables + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CSA' + include 'COMMON.BANK' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + dimension xin(maxvar),iff(maxres) + +c pull out starting values for variables + do m=1,numch + do j=2,nres-1 + theta(j+1)=dihang_in2(1,j,m,n) + phi(j+2)=dihang_in2(2,j,m,n) + alph(j)=dihang_in2(3,j,m,n) + omeg(j)=dihang_in2(4,j,m,n) + enddo + enddo +c set up array of variables + call geom_to_var(nvar,xin) + + do i=1,nres + iff(i)=iff_in(i,n) + enddo + return + end + +c------------------------------------------------------- + subroutine prune_bank(p_cut) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'mpif.h' + include 'COMMON.CSA' + include 'COMMON.BANK' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.TIME1' + include 'COMMON.SETUP' +c--------------------------- +c This subroutine prunes bank conformations using p_cut +c--------------------------- + + nprune=0 + nprune=nprune+1 + m=1 + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang(i,j,k,nprune)=bvar(i,j,k,m) + enddo + enddo + enddo + bene(nprune)=bene(m) + brmsn(nprune)=brmsn(m) + bpncn(nprune)=bpncn(m) + + do m=2,nbank + ddmin=9.d190 + do ip=1,nprune + call get_diff12(dihang(1,1,1,ip),bvar(1,1,1,m),diff) + if(diff.lt.p_cut) goto 100 + if(diff.lt.ddmin) ddmin=diff + enddo + nprune=nprune+1 + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang(i,j,k,nprune)=bvar(i,j,k,m) + enddo + enddo + enddo + bene(nprune)=bene(m) + brmsn(nprune)=brmsn(m) + bpncn(nprune)=bpncn(m) + 100 continue + write (iout,*) 'Pruning :',m,nprune,p_cut,ddmin + enddo + nbank=nprune + print *, 'Pruning :',m,nprune,p_cut + call write_bank(0,0) + + return + end +c------------------------------------------------------- + + subroutine reminimize(jlee) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'mpif.h' + include 'COMMON.CSA' + include 'COMMON.BANK' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.TIME1' + include 'COMMON.SETUP' +c--------------------------- +c This subroutine re-minimizes bank conformations: +c--------------------------- + + ntry=nbank + + call find_max + call find_min + + if (me.eq.king) then + open(icsa_history,file=csa_history,status="old") + write(icsa_history,*) "Re-minimization",nodes,"nodes" + write(icsa_history,851) (bene(i),i=1,nbank) + write(icsa_history,40) jlee,icycle,nstep,cutdif,ibmin,ibmax, + * ebmin,ebmax,nft,iuse,nbank,ntbank + close(icsa_history) + do index=1,ntry + do k=1,numch + do j=2,nres-1 + do i=1,4 + dihang_in(i,j,k,index)=bvar(i,j,k,index) + enddo + enddo + enddo + enddo + nft=0 + call feedin(ntry,nft) + else + call minim_jlee + endif + + call find_max + call find_min + + if (me.eq.king) then + do i=1,ntry + call replace_bvar(i,i) + enddo + open(icsa_history,file=csa_history,status="old") + write(icsa_history,40) jlee,icycle,nstep,cutdif,ibmin,ibmax, + * ebmin,ebmax,nft,iuse,nbank,ntbank + write(icsa_history,851) (bene(i),i=1,nbank) + close(icsa_history) + call write_bank_reminimized(jlee,nft) + endif + + 40 format(2i2,i8,f8.1,2i4,2(1pe14.5),i10,3i4) + 851 format(5e15.6) + 850 format(5e15.10) +c 850 format(10f8.3) + + return + end +c------------------------------------------------------- + subroutine send(n,mm,it) +c sends out starting conformation for minimization + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.CONTROL' + include 'COMMON.BANK' + include 'COMMON.CHAIN' + include 'mpif.h' + dimension xin(maxvar),xout(maxvar),eout(mxch*(mxch+1)/2+1), + * cout(2),ind(8),xin2(maxvar),iff(maxres),info(12) + dimension muster(mpi_status_size) + include 'COMMON.SETUP' + parameter (rad=1.745329252d-2) + + if (isend2(n).eq.0) then +c pull out external and internal variables for next start + call putx(xin,n,rad) + info(1)=n + info(2)=it + info(3)=movenx(n) + info(4)=nss_in(n) + info(5)=parent(1,n) + info(6)=parent(2,n) + + if (movenx(n).eq.14.or.movenx(n).eq.17) then + info(7)=idata(1,n) + info(8)=idata(2,n) + else if (movenx(n).eq.16) then + info(7)=idata(1,n) + info(8)=idata(2,n) + info(10)=idata(3,n) + info(11)=idata(4,n) + info(12)=idata(5,n) + else + info(7)=0 + info(8)=0 + info(10)=0 + info(11)=0 + info(12)=0 + endif + + if (movenx(n).eq.15) then + info(9)=parent(3,n) + else + info(9)=0 + endif + call mpi_send(info,12,mpi_integer,mm,idint,CG_COMM, + * ierr) + call mpi_send(xin,nvar,mpi_double_precision,mm, + * idreal,CG_COMM,ierr) + else +c distfit & minimization for n7 move + info(1)=-n + info(2)=it + info(3)=movenx(n) + info(4)=nss_in(n) + info(5)=parent(1,n) + info(6)=parent(2,n) + info(7)=0 + info(8)=0 + info(9)=0 + call mpi_send(info,12,mpi_integer,mm,idint,CG_COMM, + * ierr) + call putx2(xin,iff,isend2(n)) + call mpi_send(xin,nvar,mpi_double_precision,mm, + * idreal,CG_COMM,ierr) + call mpi_send(iff,nres,mpi_integer,mm, + * idint,CG_COMM,ierr) + call putx(xin2,n,rad) + call mpi_send(xin2,nvar,mpi_double_precision,mm, + * idreal,CG_COMM,ierr) + endif + if (vdisulf.and.nss_in(n).ne.0) then + call mpi_send(iss_in(1,n),nss_in(n),mpi_integer,mm, + * idint,CG_COMM,ierr) + call mpi_send(jss_in(1,n),nss_in(n),mpi_integer,mm, + * idint,CG_COMM,ierr) + endif + return + end +c------------------------------------------------- + + subroutine recv(ihalt,man,xout,eout,ind,tout) +c receives results of energy minimization + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.CONTROL' + include 'COMMON.SBRIDGE' + include 'COMMON.BANK' + include 'COMMON.CHAIN' + include 'mpif.h' + dimension xin(maxvar),xout(maxvar),eout(mxch*(mxch+1)/2+1), + * cout(2),ind(9),info(12) + dimension muster(mpi_status_size) + include 'COMMON.SETUP' + logical tout,flag + double precision twait,tstart,tend1 + parameter(twait=600.0d0) + +c find an available soldier + tout=.false. + flag=.false. + tstart=MPI_WTIME() + do while(.not. (flag .or. tout)) + call MPI_IPROBE(mpi_any_source,idint,CG_COMM,flag, + * muster,ierr) + tend1=MPI_WTIME() + if(tend1-tstart.gt.twait .and. ihalt.eq.1) tout=.true. +c_error if(tend1-tstart.gt.twait) tout=.true. + enddo + if (tout) then + write(iout,*) 'ERROR = timeout for recv ',tend1-tstart + call flush(iout) + return + endif + man=muster(mpi_source) + +ctimeout call mpi_recv(ind,9,mpi_integer,mpi_any_source,idint, +ctimeout * CG_COMM,muster,ierr) +! print *, ' receiving output from start # ',ind(1) +ct print *,'receiving ',MPI_WTIME() +ctimeout man=muster(mpi_source) + call mpi_recv(ind,9,mpi_integer,man,idint, + * CG_COMM,muster,ierr) +ctimeout +c receive final energies and variables + call mpi_recv(eout,1,mpi_double_precision, + * man,idreal,CG_COMM,muster,ierr) +! print *,eout +#ifdef CO_BIAS + call mpi_recv(co,1,mpi_double_precision, + * man,idreal,CG_COMM,muster,ierr) + write (iout,'(a15,f3.2,$)') ' BIAS by contact order*100 ',co +#endif + call mpi_recv(xout,nvar,mpi_double_precision, + * man,idreal,CG_COMM,muster,ierr) +! print *,nvar , ierr + if(vdisulf) nss=ind(6) + if(vdisulf.and.nss.ne.0) then + call mpi_recv(ihpb,nss,mpi_integer, + * man,idint,CG_COMM,muster,ierr) + call mpi_recv(jhpb,nss,mpi_integer, + * man,idint,CG_COMM,muster,ierr) + endif +c halt soldier + if(ihalt.eq.1) then +c print *,'sending halt to ',man + write(iout,*) 'sending halt to ',man + info(1)=0 + info(2)=0 + call mpi_send(info,12,mpi_integer,man,idint,CG_COMM,ierr) + endif + return + end + +c---------------------------------------------------------- + subroutine history_append + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + +#if defined(AIX) || defined(PGI) + open(icsa_history,file=csa_history,position="append") +#else + open(icsa_history,file=csa_history,access="append") +#endif + return + end +#endif diff --git a/source/unres/src_CSA_DiL/unres_csa.F b/source/unres/src_CSA_DiL/unres_csa.F new file mode 100644 index 0000000..ce55133 --- /dev/null +++ b/source/unres/src_CSA_DiL/unres_csa.F @@ -0,0 +1,556 @@ +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' +c include 'COMMON.REMD' +c 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 11/03/09 1:19PM 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 +c if (modecalc.eq.-2) then +c call test +c stop +c else if (modecalc.eq.-1) then +c write(iout,*) "call check_sc_map next" +c call check_bond +c stop +c 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 +c else if (modecalc.eq.1) then +c call exec_regularize +c else if (modecalc.eq.2) then +c call exec_thread +c else if (modecalc.eq.3 .or. modecalc .eq.6) then +c call exec_MC + else if (modecalc.eq.4) then + call exec_mult_eeval_or_minim + else if (modecalc.eq.5) then + call exec_checkgrad +c else if (ModeCalc.eq.7) then +c call exec_map + else if (ModeCalc.eq.8) then + call exec_CSA +c else if (modecalc.eq.11) then +c call exec_softreg +c else if (modecalc.eq.12) then +c call exec_MD +c else if (modecalc.eq.14) then +c 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_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' +c include 'COMMON.REMD' +c 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 +c time00=MPI_Wtime() + call chainbuild_cart +c if (split_ene) then +c print *,"Processor",myrank," after chainbuild" +c icall=1 +c call etotal_long(energy_long(0)) +c write (iout,*) "Printing long range energy" +c call enerprint(energy_long(0)) +c call etotal_short(energy_short(0)) +c write (iout,*) "Printing short range energy" +c call enerprint(energy_short(0)) +c do i=0,n_ene +c energy(i)=energy_long(i)+energy_short(i) +c write (iout,*) i,energy_long(i),energy_short(i),energy(i) +c enddo +c write (iout,*) "Printing long+short range energy" +c call enerprint(energy(0)) +c endif + call etotal(energy(0)) +c time_ene=MPI_Wtime()-time00 + write (iout,*) "Time for energy evaluation",time_ene + print *,"after etotal" + etota = energy(0) + etot =etota + call enerprint(energy(0)) +c call hairpin(.true.,nharp,iharp) +c call secondary2(.true.) + if (minim) then + + if (dccart) then + print *, 'Calling MINIM_DC' +c time1=MPI_WTIME() + 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.' +c time1=MPI_WTIME() + call minimize(etot,varia,iretcode,nfun) + endif + print *,'SUMSL return code is',iretcode,' eval ',nfun +c evals=nfun/(MPI_WTIME()-time1) + print *,'# eval/s',evals + print *,'refstr=',refstr +c call hairpin(.true.,nharp,iharp) +c 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 + + 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' +c 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 +c call read_fragments +c read(inp,*) t_bath +c 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_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 + call together +#else + write (iout,*) "CSA works on parallel machines only" +#endif + return + end +c--------------------------------------------------------------------------- +#ifdef MPI + subroutine exec_mult_eeval_or_minim + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'mpif.h' + integer muster(mpi_status_size) + 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.SBRIDGE' + double precision varia(maxvar) + integer ind(6) + double precision energy(0:n_ene) + logical eof + eof=.false. + + if(me.ne.king) then + call minim_mcmf + return + endif + + close (intin) + open(intin,file=intinname,status='old') + write (istat,'(a5,100a12)')"# ", + & (wname(print_order(i)),i=1,nprint_ene) + if (refstr) then + write (istat,'(a5,100a12)')"# ", + & (ename(print_order(i)),i=1,nprint_ene), + & "ETOT total","RMSD","nat.contact","nnt.contact", + & "cont.order","TMscore" + else + write (istat,'(a5,100a12)')"# ", + & (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) +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) + 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.) + call calc_tmscore(tm,.true.) + write (istat,'(i5,100(f12.3))') iconf, + & (energy(print_order(i)),i=1,nprint_ene),etot, + & rms,frac,frac_nn,co,tm + else + write (istat,'(i5,100(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 + 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) +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) + 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 + + n=n+1 + write (iout,*) 'Conformation #',iconf,' read' + 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,*) 'Conformation #',iconf," sumsl return code ", + & ind(5) + + etot=energy(0) + call enerprint(energy(0)) + call briefout(iconf,etot) + if (refstr) then + call rms_nac_nnc(rms,frac,frac_nn,co,.true.) + call calc_tmscore(tm,.true.) + write (istat,'(i5,100(f12.3))') iconf, + & (energy(print_order(i)),i=1,nprint_ene),etot, + & rms,frac,frac_nn,co,tm + else + write (istat,'(i5,100(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=11,err=11) time,ene + call read_x(intin,*11) +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) + 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 + n=n+1 + write (iout,*) 'Conformation #',iconf,' read' + 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,*) 'Conformation #',iconf," sumsl return code ", + & ind(5) + + etot=energy(0) + call enerprint(energy(0)) + call briefout(iconf,etot) + if (refstr) then + call rms_nac_nnc(rms,frac,frac_nn,co,.true.) + call calc_tmscore(tm,.true.) + write (istat,'(i5,100(f12.3))') iconf, + & (energy(print_order(i)),i=1,nprint_ene),etot, + & rms,frac,frac_nn,co,tm + else + write (istat,'(i5,100(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 + return + end +#else + subroutine exec_mult_eeval_or_minim + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + write (iout,*) "Unsupported option in serial version" + return + end +#endif +c--------------------------------------------------------------------------- +