From: Adam Liwo Date: Wed, 30 Jul 2014 14:30:28 +0000 (-0400) Subject: Adam 7/30/2014 X-Git-Url: http://mmka.chem.univ.gda.pl/gitweb/?a=commitdiff_plain;h=deae9a91e2e1176a7a9652e6e896997408f1a18b;p=unres.git Adam 7/30/2014 --- diff --git a/source/cluster/wham/src-M-NEWCORR/COMMON.CONTROL b/source/cluster/wham/src-M-NEWCORR/COMMON.CONTROL index 9a2bd18..d8c773c 100644 --- a/source/cluster/wham/src-M-NEWCORR/COMMON.CONTROL +++ b/source/cluster/wham/src-M-NEWCORR/COMMON.CONTROL @@ -1,7 +1,9 @@ double precision betaT integer iscode,indpdb,outpdb,outmol2,iopt,nstart,nend,symetr logical refstr,pdbref,punch_dist,print_dist,caonly,lside, - & lprint_cart,lprint_int,from_cart,efree,from_bx,from_cx + & lprint_cart,lprint_int,from_cart,efree,from_bx,from_cx, + & with_dihed_constr common /cntrl/ betaT,iscode,indpdb,refstr,pdbref,outpdb,outmol2, & punch_dist,print_dist,caonly,lside,lprint_cart,lprint_int, - & from_cart,from_bx,from_cx,efree,iopt,nstart,nend,symetr + & from_cart,from_bx,from_cx,efree,iopt,nstart,nend,symetr, + & with_dihed_constr diff --git a/source/cluster/wham/src-M-NEWCORR/probabl.F b/source/cluster/wham/src-M-NEWCORR/probabl.F index 8979165..d7d611f 100644 --- a/source/cluster/wham/src-M-NEWCORR/probabl.F +++ b/source/cluster/wham/src-M-NEWCORR/probabl.F @@ -136,12 +136,12 @@ c call flush(iout) totfree(i)=energia(0) c write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) c write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) - call enerprint(energia(0),fT) c call pdbout(totfree(i),16,i) #ifdef DEBUG write (iout,*) i," energia",(energia(j),j=0,19) write (iout,*) "etot", etot write (iout,*) "ft(6)", ft(6) + call enerprint(energia(0),fT) #endif do k=1,max_ene enetb(k,i)=energia(k) diff --git a/source/cluster/wham/src-M-NEWCORR/readrtns.F b/source/cluster/wham/src-M-NEWCORR/readrtns.F index 321e11e..326d4ec 100644 --- a/source/cluster/wham/src-M-NEWCORR/readrtns.F +++ b/source/cluster/wham/src-M-NEWCORR/readrtns.F @@ -64,6 +64,7 @@ C write (iout,*) 'beta_h',(beta_h(i),i=1,nT) lprint_cart=index(controlcard,"PRINT_CART") .gt.0 lprint_int=index(controlcard,"PRINT_INT") .gt.0 + with_dihed_constr = index(controlcard,"WITH_DIHED_CONSTR").gt.0 if (min_var) iopt=1 return end @@ -87,6 +88,7 @@ C include 'COMMON.CONTROL' include 'COMMON.CONTACTS' include 'COMMON.TIME1' + include 'COMMON.TORCNSTR' #ifdef MPL include 'COMMON.INFO' #endif @@ -193,7 +195,11 @@ C 12/1/95 Added weight for the multi-body term WCORR bad(i,2)=scalscp*bad(i,2) enddo +#ifdef AIX + call flush_(iout) +#else call flush(iout) +#endif print *,'indpdb=',indpdb,' pdbref=',pdbref C Read sequence if not taken from the pdb file. @@ -233,6 +239,28 @@ C Convert sequence to numeric code print *,'Call Read_Bridge.' call read_bridge + + if (with_dihed_constr) then + + read (inp,*) ndih_constr + write (iout,*) "ndih_constr",ndih_constr + if (ndih_constr.gt.0) then + read (inp,*) ftors + write (iout,*) 'FTORS',ftors + read (inp,*) (idih_constr(i),phi0(i),drange(i),i=1,ndih_constr) + 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 + do i=1,ndih_constr + phi0(i)=deg2rad*phi0(i) + drange(i)=deg2rad*drange(i) + enddo + endif + + endif + nnt=1 nct=nres print *,'NNT=',NNT,' NCT=',NCT diff --git a/source/cluster/wham/src/COMMON.SCCOR b/source/cluster/wham/src/COMMON.SCCOR index 0857cd8..1991570 100644 --- a/source/cluster/wham/src/COMMON.SCCOR +++ b/source/cluster/wham/src/COMMON.SCCOR @@ -6,7 +6,7 @@ cc Parameters of the SCCOR term integer nterm_sccor,isccortyp,nsccortyp,nlor_sccor common/sccor/v1sccor(maxterm_sccor,3,20,20), & v2sccor(maxterm_sccor,3,20,20), - & v0sccor(maxterm_sccor,20), + & v0sccor(20,20), & vlor1sccor(maxterm_sccor,20,20), & vlor2sccor(maxterm_sccor,20,20), & vlor3sccor(maxterm_sccor,20,20),gloc_sc(3,0:maxres2,10), diff --git a/source/cluster/wham/src/DIMENSIONS b/source/cluster/wham/src/DIMENSIONS index 806387c..50c38b4 100644 --- a/source/cluster/wham/src/DIMENSIONS +++ b/source/cluster/wham/src/DIMENSIONS @@ -49,7 +49,7 @@ C Max. number of lobes in SC distribution parameter (maxlob=4) C Max. number of S-S bridges integer maxss - parameter (maxss=20) + parameter (maxss=1000) C Max. number of dihedral angle constraints integer maxdih_constr parameter (maxdih_constr=maxres) diff --git a/source/cluster/wham/src/Makefile b/source/cluster/wham/src/Makefile deleted file mode 100644 index b192a7b..0000000 --- a/source/cluster/wham/src/Makefile +++ /dev/null @@ -1,39 +0,0 @@ -INSTALL_DIR = /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh -BIN=../../../../bin -FC = ifort -OPT = -O3 -ip -w -OPT = -CB -g -<<<<<<< HEAD -FFLAGS = ${OPT} -c -I. -Iinclude_unres -I$(INSTALL_DIR)/include -CPPFLAGS = -DLINUX -DPGI -DSPLITELE -DPROCOR -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DMP -DMPI -LIBS = -L$(INSTALL_DIR)/lib -lmpich xdrf/libxdrf.a -g -d2 -CA -CB -======= -FFLAGS = ${OPT} -c -I. -I./include_unres -I../src_MD_T-sccor -I/users/adam/MEY_MD/src_Tc-czarek -I$(INSTALL_DIR)/include -CPPFLAGS = -DLINUX -DPGI -DSPLITELE -DPROCOR -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DMP -DMPI -LIBS = -L$(INSTALL_DIR)/lib -lmpich ./xdrf/libxdrf.a -g -d2 -CA -CB ->>>>>>> devel - -.c.o: - cc -c -DLINUX -DPGI $*.c - -.f.o: - ${FC} ${FFLAGS} $*.f - -.F.o: - ${FC} ${FFLAGS} ${CPPFLAGS} ${FFLAGS} $*.F - -objects = main_clust.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ - matmult.o readrtns.o pinorm.o rescode.o intcor.o timing.o misc.o \ - geomout.o readpdb.o read_coords.o parmread.o probabl.o fitsq.o hc.o \ - track.o wrtclust.o srtclust.o noyes.o contact.o printmat.o \ - int_from_cart1.o energy_p_new.o icant.o proc_proc.o work_partition.o \ - setup_var.o read_ref_str.o gnmr1.o - -unres_clust: $(objects) - $(FC) ${OPT} ${objects} ${LIBS} -o ${BIN}/unres_clustMD_MPI-oldparm - -clean: - /bin/rm *.o - -move: - mv *.o ${OBJ} diff --git a/source/cluster/wham/src/Makefile b/source/cluster/wham/src/Makefile new file mode 120000 index 0000000..693492e --- /dev/null +++ b/source/cluster/wham/src/Makefile @@ -0,0 +1 @@ +Makefile-MPICH-ifort \ No newline at end of file diff --git a/source/cluster/wham/src/energy_p_new.F b/source/cluster/wham/src/energy_p_new.F index 38090fe..ee00811 100644 --- a/source/cluster/wham/src/energy_p_new.F +++ b/source/cluster/wham/src/energy_p_new.F @@ -2800,10 +2800,17 @@ C include 'COMMON.VAR' include 'COMMON.INTERACT' include 'COMMON.IOUNITS' + include 'COMMON.NAMES' 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 +#ifdef DEBUG + do i=1,nres + write (iout,'(a4,2x,i4,3f10.5,5x,3f10.5)') restyp(itype(i)),i, + & (c(j,i),j=1,3),(c(j,i+nres),j=1,3) + enddo +#endif 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 @@ -2818,8 +2825,10 @@ C iii and jjj point to the residues for which the distance is assigned. iii=ii jjj=jj endif -c write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj, -c & dhpb(i),dhpb1(i),forcon(i) +#ifdef DEBUG + write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj, + & dhpb(i),dhpb1(i),forcon(i) +#endif 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 @@ -2832,8 +2841,10 @@ c Restraints from contact prediction if (dhpb1(i).gt.0.0d0) then ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd -c write (iout,*) "beta nmr", -c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) +#ifdef DEBUG + write (iout,*) "beta nmr", + & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) +#endif else dd=dist(ii,jj) rdis=dd-dhpb(i) @@ -2841,7 +2852,9 @@ C Get the force constant corresponding to this distance. waga=forcon(i) C Calculate the contribution to energy. ehpb=ehpb+waga*rdis*rdis -c write (iout,*) "beta reg",dd,waga*rdis*rdis +#ifdef DEBUG + write (iout,*) "beta reg",dd,waga*rdis*rdis +#endif C C Evaluate gradient. C @@ -2865,15 +2878,19 @@ C target distance. if (dhpb1(i).gt.0.0d0) then ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd -c write (iout,*) "alph nmr", -c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) +#ifdef DEBUG + write (iout,*) "alph nmr", + & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) +#endif else rdis=dd-dhpb(i) C Get the force constant corresponding to this distance. waga=forcon(i) C Calculate the contribution to energy. ehpb=ehpb+waga*rdis*rdis -c write (iout,*) "alpha reg",dd,waga*rdis*rdis +#ifdef DEBUG + write (iout,*) "alpha reg",dd,waga*rdis*rdis +#endif C C Evaluate gradient. C diff --git a/source/cluster/wham/src/probabl.F b/source/cluster/wham/src/probabl.F index 4c49d99..9c21be3 100644 --- a/source/cluster/wham/src/probabl.F +++ b/source/cluster/wham/src/probabl.F @@ -102,11 +102,13 @@ c write (iout,*) "i",i," ii",ii call int_from_cart1(.false.) call etotal(energia(0),fT) totfree(i)=energia(0) +#define DEBUG #ifdef DEBUG - write (iout,*) i," energia",(energia(j),j=0,21) +c write (iout,*) i," energia",(energia(j),j=0,n_ene) call enerprint(energia(0),ft) call flush(iout) #endif +#undef DEBUG do k=1,max_ene enetb(k,i)=energia(k) enddo diff --git a/source/unres/src_MD-DFA-restraints/CMakeLists.txt b/source/unres/src_MD-DFA-restraints/CMakeLists.txt new file mode 100644 index 0000000..a0353f4 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/CMakeLists.txt @@ -0,0 +1,398 @@ +# +# CMake project file for UNRES with MD for single chains +# + +enable_language (Fortran) + + +#================================ +# Set source file lists +#================================ +set(UNRES_MD_SRC0 + add.f + arcos.f + banach.f + blas.f + bond_move.f + cartder.F + cartprint.f + check_sc_distr.f + check_bond.f + chainbuild.F + checkder_p.F + compare_s1.F + contact.f + convert.f + cored.f + dihed_cons.F + djacob.f + econstr_local.F + eigen.f + elecont.f + energy_split-sep.F + entmcm.F + fitsq.f + gauss.f + gen_rand_conf.F + geomout.F + gnmr1.f + intcartderiv.F + initialize_p.F + int_to_cart.f + intcor.f + intlocal.f + kinetic_lesyng.f + lagrangian_lesyng.F + local_move.f + map.f + matmult.f + mc.F + mcm.F + MD_A-MTS.F + minimize_p.F + minim_mcmf.F + misc.f + moments.f + MP.F + MREMD.F + muca_md.f + parmread.F + pinorm.f + printmat.f + q_measure.F + randgens.f + rattle.F + readpdb.F + readrtns.F + refsys.f + regularize.F + rescode.f + rmdd.f + rmsd.F + sc_move.F + sort.f + stochfric.F + sumsld.f + surfatom.f + test.F + timing.F + thread.F + unres.F + ssMD.F +) + +if(Fortran_COMPILER_NAME STREQUAL "ifort") + set(UNRES_MD_SRC0 ${UNRES_MD_SRC0} prng.f ) +elseif(Fortran_COMPILER_NAME STREQUAL "mpif90") + set(UNRES_MD_SRC0 ${UNRES_MD_SRC0} prng.f ) +elseif(Fortran_COMPILER_NAME STREQUAL "f95") + set(UNRES_MD_SRC0 ${UNRES_MD_SRC0} prng.f ) +elseif(Fortran_COMPILER_NAME STREQUAL "gfortran") + set(UNRES_MD_SRC0 ${UNRES_MD_SRC0} prng.f ) +else() + set(UNRES_MD_SRC0 ${UNRES_MD_SRC0} prng_32.F ) +endif (Fortran_COMPILER_NAME STREQUAL "ifort") + + +set(UNRES_MD_SRC3 + energy_p_new_barrier.F + energy_p_new-sep_barrier.F + gradient_p.F ) + +set(UNRES_MD_PP_SRC + cartder.F + chainbuild.F + checkder_p.F + compare_s1.F + dihed_cons.F + econstr_local.F + energy_p_new_barrier.F + energy_p_new-sep_barrier.F + energy_split-sep.F + entmcm.F + gen_rand_conf.F + geomout.F + gradient_p.F + initialize_p.F + intcartderiv.F + lagrangian_lesyng.F + mc.F + mcm.F + MD_A-MTS.F + minimize_p.F + minim_mcmf.F + MP.F + MREMD.F + parmread.F + q_measure1.F + q_measure3.F + q_measure.F + rattle.F + readpdb.F + readrtns.F + regularize.F + rmsd.F + sc_move.F + stochfric.F + test.F + thread.F + timing.F + unres.F + proc_proc.c +) + + +if(NOT Fortran_COMPILER_NAME STREQUAL "ifort") + set(UNRES_MD_PP_SRC ${UNRES_MD_PP_SRC} prng_32.F) +endif(NOT Fortran_COMPILER_NAME STREQUAL "ifort") + +#================================================ +# Set comipiler flags for different sourcefiles +#================================================ +if (Fortran_COMPILER_NAME STREQUAL "ifort") + set(FFLAGS0 "-ip -w" ) + set(FFLAGS1 "-w -g -d2 -CA -CB" ) + set(FFLAGS2 "-w -g -00 ") + #set(FFLAGS3 "-c -w -O3 -ipo -ipo_obj -opt_report" ) + set(FFLAGS3 "-w -ipo " ) +elseif (Fortran_COMPILER_NAME STREQUAL "gfortran") + set(FFLAGS0 "-std=legacy -I. " ) + set(FFLAGS1 "-std=legacy -g -I. " ) + set(FFLAGS2 "-std=legacy -I. ") + #set(FFLAGS3 "-c -w -O3 -ipo -ipo_obj -opt_report" ) + set(FFLAGS3 "-std=legacy -I. " ) +endif (Fortran_COMPILER_NAME STREQUAL "ifort") + + +# Add MPI compiler flags +if(UNRES_WITH_MPI) + set(FFLAGS0 "${FFLAGS0} -I${MPIF_INCLUDE_DIRECTORIES}") + set(FFLAGS1 "${FFLAGS1} -I${MPIF_INCLUDE_DIRECTORIES}") + set(FFLAGS2 "${FFLAGS2} -I${MPIF_INCLUDE_DIRECTORIES}") + set(FFLAGS3 "${FFLAGS3} -I${MPIF_INCLUDE_DIRECTORIES}") +endif(UNRES_WITH_MPI) + +set_property(SOURCE ${UNRES_MD_SRC0} APPEND PROPERTY COMPILE_FLAGS ${FFLAGS0} ) +#set_property(SOURCE ${UNRES_MD_SRC1} PROPERTY COMPILE_FLAGS ${FFLAGS1} ) +#set_property(SOURCE ${UNRES_MD_SRC2} PROPERTY COMPILE_FLAGS ${FFLAGS2} ) +set_property(SOURCE ${UNRES_MD_SRC3} PROPERTY COMPILE_FLAGS ${FFLAGS3} ) + +#========================================= +# Settings for GAB force field +#========================================= +if(UNRES_MD_FF STREQUAL "GAB" ) + # set preprocesor flags + set(CPPFLAGS "PROCOR -DUNRES -DISNAN -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC" ) + +#========================================= +# Settings for E0LL2Y force field +#========================================= +elseif(UNRES_MD_FF STREQUAL "E0LL2Y") + # set preprocesor flags + set(CPPFLAGS "PROCOR -DUNRES -DISNAN -DSPLITELE -DLANG0" ) +endif(UNRES_MD_FF STREQUAL "GAB") + +#========================================= +# System specific flags +#========================================= +if(${CMAKE_SYSTEM_NAME} MATCHES "Linux") + set(CPPFLAGS "${CPPFLAGS} -DLINUX") +endif(${CMAKE_SYSTEM_NAME} MATCHES "Linux") + +#========================================= +# Compiler specific flags +#========================================= + +if (Fortran_COMPILER_NAME STREQUAL "ifort") + # Add ifort preprocessor flags + set(CPPFLAGS "${CPPFLAGS} -DPGI") +elseif (Fortran_COMPILER_NAME STREQUAL "f95") + # Add new gfortran flags + set(CPPFLAGS "${CPPFLAGS} -DG77") +elseif (Fortran_COMPILER_NAME STREQUAL "gfortran") + # Add old gfortran flags + set(CPPFLAGS "${CPPFLAGS} -DG77") +endif (Fortran_COMPILER_NAME STREQUAL "ifort") + +#========================================= +# Add MPI preprocessor flags +#========================================= +if (UNRES_WITH_MPI) + set(CPPFLAGS "${CPPFLAGS} -DMP -DMPI") +endif(UNRES_WITH_MPI) + +#========================================= +# Apply preprocesor flags to *.F files +#========================================= +set_property(SOURCE ${UNRES_MD_PP_SRC} PROPERTY COMPILE_DEFINITIONS ${CPPFLAGS} ) + + +#======================================== +# Setting binary name +#======================================== +if(UNRES_WITH_MPI) + # binary with mpi + set(UNRES_BIN "unres_${Fortran_COMPILER_NAME}_MPICH_${UNRES_MD_FF}.exe") +else(UNRES_WITH_MPI) + # binary without mpi + set(UNRES_BIN "unres_${Fortran_COMPILER_NAME}_single_${UNRES_MD_FF}.exe") +endif(UNRES_WITH_MPI) + +#========================================= +# cinfo.f workaround for cmake +#========================================= +# get the current date +TODAY(DATE) +# generate cinfo.f + +set(CINFO "${CMAKE_CURRENT_BINARY_DIR}/cinfo.f") +FILE(WRITE ${CINFO} +"C CMake generated file + subroutine cinfo + include 'COMMON.IOUNITS' + write(iout,*)'++++ Compile info ++++' + write(iout,*)'Version ${UNRES_MAJOR}.${UNRES_MINOR} build ${UNRES_PATCH}' +") + +CINFO_FORMAT(${CINFO} "Compiled" "${DATE}" ) +CINFO_FORMAT(${CINFO} "Compiled by" "$ENV{USER}@$ENV{HOST}" ) +CINFO_FORMAT(${CINFO} "OS name:" "${CMAKE_SYSTEM_NAME}" ) +CINFO_FORMAT(${CINFO} "OS release:" "${CMAKE_SYSTEM}" ) +CINFO_FORMAT(${CINFO} "Fortran Compiler:" "${CMAKE_Fortran_COMPILER}" ) +CINFO_FORMAT(${CINFO} "MD Force field:" "${UNRES_MD_FF}" ) +CINFO_FORMAT(${CINFO} "CPPFLAGS =" "${CPPFLAGS}") + +FILE(APPEND ${CINFO} +" write(iout,*)'++++ End of compile info ++++' + return + end ") + +# add include path +set_property(SOURCE ${CMAKE_CURRENT_BINARY_DIR}/cinfo.f PROPERTY COMPILE_FLAGS "${FFLAGS0} -I${CMAKE_CURRENT_SOURCE_DIR}") + +#========================================= +# Set full unres MD sources +#========================================= +set(UNRES_MD_SRCS ${UNRES_MD_SRC0} ${UNRES_MD_SRC3} ${CMAKE_CURRENT_BINARY_DIR}/cinfo.f ) + + +#========================================= +# Build the binary +#========================================= +add_executable(UNRES_BIN-MD ${UNRES_MD_SRCS} ) +set_target_properties(UNRES_BIN-MD PROPERTIES OUTPUT_NAME ${UNRES_BIN}) +#set_property(TARGET ${UNRES_BIN} PROPERTY RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/bin/unres/MD ) +#add_dependencies (${UNRES_BIN} ${UNRES_XDRFLIB}) + + +#========================================= +# Link libraries +#========================================= +# link MPI library (libmpich.a) +if(UNRES_WITH_MPI) + target_link_libraries( UNRES_BIN-MD ${MPIF_LIBRARIES} ) +endif(UNRES_WITH_MPI) +# link libxdrf.a +#message("UNRES_XDRFLIB=${UNRES_XDRFLIB}") +target_link_libraries( UNRES_BIN-MD xdrf ) + +#========================================= +# TESTS +#========================================= + +#-- Copy all the data files from the test directory into the source directory +#SET(UNRES_TEST_FILES +# ala10.inp +# ) + +#FOREACH (UNRES_TEST_FILE ${UNRES_TEST_FILES}) +# SET (unres_test_dest "${CMAKE_CURRENT_BINARY_DIR}/${UNRES_TEST_FILE}") +# MESSAGE (STATUS " Copying ${UNRES_TEST_FILE} from ${CMAKE_SOURCE_DIR}/examples/unres/MD/ff_gab/${UNRES_TEST_FILE} to ${unres_test_dest}") +# ADD_CUSTOM_COMMAND ( +# TARGET ${UNRES_BIN} +# POST_BUILD +# COMMAND ${CMAKE_COMMAND} -E copy ${CMAKE_SOURCE_DIR}/examples/unres/MD/ff_gab/${UNRES_TEST_FILE} ${unres_test_dest} +# ) +#ENDFOREACH (UNRES_TEST_FILE ${UNRES_TEST_FILES}) + +#========================================= +# Generate data test files +#========================================= +# test_single_ala.sh +#========================================= + +FILE(WRITE ${CMAKE_CURRENT_BINARY_DIR}/scripts/test_single_ala.sh +"#!/bin/sh +export POT=GB +export PREFIX=ala10 +#----------------------------------------------------------------------------- +UNRES_BIN=./${UNRES_BIN} +#----------------------------------------------------------------------------- +DD=${CMAKE_SOURCE_DIR}/PARAM +export BONDPAR=$DD/bond.parm +export THETPAR=$DD/thetaml.5parm +export ROTPAR=$DD/scgauss.parm +export TORPAR=$DD/torsion_631Gdp.parm +export TORDPAR=$DD/torsion_double_631Gdp.parm +export ELEPAR=$DD/electr_631Gdp.parm +export SIDEPAR=$DD/sc_GB_opt.1gab_3S_qclass5no310-shan2-sc-16-10-8k +export FOURIER=$DD/fourier_opt.parm.1igd_hc_iter3_3 +export SCPPAR=$DD/scp.parm +export SCCORPAR=$DD/sccor_pdb_shelly.dat +export PATTERN=$DD/patterns.cart +#----------------------------------------------------------------------------- +$UNRES_BIN +") + +# +# File permissions workaround +# +FILE( COPY ${CMAKE_CURRENT_BINARY_DIR}/scripts/test_single_ala.sh + DESTINATION ${CMAKE_CURRENT_BINARY_DIR} + FILE_PERMISSIONS OWNER_READ OWNER_WRITE OWNER_EXECUTE GROUP_READ GROUP_EXECUTE WORLD_READ WORLD_EXECUTE +) + + + +#========================================= +# ala10.inp +#========================================= + +file(WRITE ${CMAKE_CURRENT_BINARY_DIR}/ala10.inp +"ala10 unblocked +SEED=-1111333 MD ONE_LETTER rescale_mode=2 +nstep=15000 ntwe=100 ntwx=1000 dt=0.1 lang=0 tbf t_bath=300 damax=1.0 & +reset_moment=1000 reset_vel=1000 +WLONG=1.35279 WSCP=1.59304 WELEC=0.71534 WBOND=1.00000 WANG=1.13873 & +WSCLOC=0.16258 WTOR=1.98599 WTORD=1.57069 WCORRH=0.42887 WCORR5=0.00000 & +WCORR6=0.00000 WEL_LOC=0.16036 WTURN3=1.68722 WTURN4=0.66230 WTURN6=0.00000 & +WVDWPP=0.11371 WHPB=1.00000 & +CUTOFF=7.00000 WCORR4=0.00000 +12 +XAAAAAAAAAAX + 0 + 0 + 90.0000 90.0000 90.0000 90.000 90.000 90.000 90.000 90.000 + 90.0000 90.0000 + 180.0000 180.0000 180.0000 180.000 180.000 180.000 180.000 180.000 + 180.0000 + 110.0000 110.0000 110.0000 100.000 110.000 100.000 110.000 110.000 + 110.0000 110.0000 + -120.0000 -120.0000 -120.000 -120.000 -120.000 -120.000 -120.000 -120.000 + -120.0000 -120.0000 +") + + +# Add tests + +if(NOT UNRES_WITH_MPI) + + add_test(NAME UNRES_MD_Ala10 COMMAND sh ${CMAKE_CURRENT_BINARY_DIR}/test_single_ala.sh ) + +else(NOT UNRES_WITH_MPI) + + + add_test(NAME UNRES_MD_MPI_Ala10 COMMAND mpiexec -boot ${CMAKE_CURRENT_BINARY_DIR}/test_single_ala.sh ) + +endif(NOT UNRES_WITH_MPI) + diff --git a/source/unres/src_MD-DFA-restraints/COMMON.BOUNDS b/source/unres/src_MD-DFA-restraints/COMMON.BOUNDS new file mode 100644 index 0000000..f3859ae --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/COMMON.BOUNDS @@ -0,0 +1,2 @@ + double precision phibound(2,maxres) + common /bounds/ phibound diff --git a/source/unres/src_MD-DFA-restraints/COMMON.CACHE b/source/unres/src_MD-DFA-restraints/COMMON.CACHE new file mode 100644 index 0000000..8cb0cbc --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/COMMON.CACHE @@ -0,0 +1,6 @@ + integer ncache,CachSrc(max_cache),isent(max_cache), + & iused(max_cache) + logical cache_update + double precision ecache(max_cache),xcache(maxvar,max_cache) + common /cache/ ecache,xcache,ncache,CachSrc,isent,iused, + & cache_update diff --git a/source/unres/src_MD-DFA-restraints/COMMON.CALC b/source/unres/src_MD-DFA-restraints/COMMON.CALC new file mode 100644 index 0000000..67b4bb9 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/COMMON.CHAIN b/source/unres/src_MD-DFA-restraints/COMMON.CHAIN new file mode 100644 index 0000000..6e19f8d --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/COMMON.CHAIN @@ -0,0 +1,13 @@ + integer nres,nsup,nstart_sup,nz_start,nz_end,iz_sc, + & nres0,nstart_seq + double precision c,dc,dc_old,d_c_work,xloc,xrot,dc_norm,t,r, + & prod,rt,dc_work,cref,crefjlee,dc_norm2 + common /chain/ c(3,maxres2+2),dc(3,0:maxres2),dc_old(3,0:maxres2), + & xloc(3,maxres),xrot(3,maxres),dc_norm(3,0:maxres2), + & dc_norm2(3,0:maxres2), + & dc_work(MAXRES6),nres,nres0 + common /rotmat/ t(3,3,maxres),r(3,3,maxres),prod(3,3,maxres), + & rt(3,3,maxres) + common /refstruct/ cref(3,maxres2+2),crefjlee(3,maxres2+2), + & nsup,nstart_sup,nstart_seq + common /from_zscore/ nz_start,nz_end,iz_sc diff --git a/source/unres/src_MD-DFA-restraints/COMMON.CONTACTS b/source/unres/src_MD-DFA-restraints/COMMON.CONTACTS new file mode 100644 index 0000000..5b3a90d --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/COMMON.CONTACTS @@ -0,0 +1,82 @@ +C Change 12/1/95 - common block CONTACTS1 included. + integer ncont,ncont_ref,icont,icont_ref,num_cont,jcont + double precision facont,gacont + common /contacts/ ncont,ncont_ref,icont(2,maxcont), + & icont_ref(2,maxcont) + common /contacts1/ facont(maxconts,maxres), + & gacont(3,maxconts,maxres), + & num_cont(maxres),jcont(maxconts,maxres) +C 12/26/95 - H-bonding contacts + common /contacts_hb/ + & gacontp_hb1(3,maxconts,maxres),gacontp_hb2(3,maxconts,maxres), + & gacontp_hb3(3,maxconts,maxres), + & gacontm_hb1(3,maxconts,maxres),gacontm_hb2(3,maxconts,maxres), + & gacontm_hb3(3,maxconts,maxres), + & gacont_hbr(3,maxconts,maxres), + & grij_hb_cont(3,maxconts,maxres), + & facont_hb(maxconts,maxres),ees0p(maxconts,maxres), + & ees0m(maxconts,maxres),d_cont(maxconts,maxres), + & num_cont_hb(maxres),jcont_hb(maxconts,maxres) +C 9/23/99 Added improper rotation matrices and matrices of dipole-dipole +C interactions +c 7/25/08 Commented out; not needed when cumulants used +C Interactions of pseudo-dipoles generated by loc-el interactions. +c double precision dip,dipderg,dipderx +c common /dipint/ dip(4,maxconts,maxres),dipderg(4,maxconts,maxres), +c & dipderx(3,5,4,maxconts,maxres) +C 10/30/99 Added other pre-computed vectors and matrices needed +C to calculate three - six-order el-loc correlation terms + double precision Ug,Ugder,Ug2,Ug2der,obrot,obrot2,obrot_der, + & obrot2_der,Ub2,Ub2der,mu,muder,EUg,EUgder,CUg,CUgder, + & DUg,DUgder,DtUg2,DtUg2der,Ctobr,Ctobrder,Dtobr2,Dtobr2der + common /rotat/ Ug(2,2,maxres),Ugder(2,2,maxres),Ug2(2,2,maxres), + & Ug2der(2,2,maxres),obrot(2,maxres),obrot2(2,maxres), + & obrot_der(2,maxres),obrot2_der(2,maxres) +C This common block contains vectors and matrices dependent on a single +C amino-acid residue. + common /precomp1/ mu(2,maxres),muder(2,maxres),Ub2(2,maxres), + & Ub2der(2,maxres),Ctobr(2,maxres),Ctobrder(2,maxres), + & Dtobr2(2,maxres),Dtobr2der(2,maxres), + & EUg(2,2,maxres),EUgder(2,2,maxres),CUg(2,2,maxres), + & CUgder(2,2,maxres),DUg(2,2,maxres),Dugder(2,2,maxres), + & DtUg2(2,2,maxres),DtUg2der(2,2,maxres) +C This common block contains vectors and matrices dependent on two +C consecutive amino-acid residues. + double precision Ug2Db1t,Ug2Db1tder,CUgb2,CUgb2der,EUgC, + & EUgCder,EUgD,EUgDder,DtUg2EUg,DtUg2EUgder + common /precomp2/ Ug2Db1t(2,maxres),Ug2Db1tder(2,maxres), + & CUgb2(2,maxres),CUgb2der(2,maxres),EUgC(2,2,maxres), + & EUgCder(2,2,maxres),EUgD(2,2,maxres),EUgDder(2,2,maxres), + & DtUg2EUg(2,2,maxres),Ug2DtEUg(2,2,maxres), + & Ug2DtEUgder(2,2,2,maxres),DtUg2EUgder(2,2,2,maxres) + double precision costab,sintab,costab2,sintab2 + common /rotat_old/ costab(maxres),sintab(maxres), + & costab2(maxres),sintab2(maxres) +C This common block contains dipole-interaction matrices and their +C Cartesian derivatives. + double precision a_chuj,a_chuj_der + common /dipmat/ a_chuj(2,2,maxconts,maxres), + & a_chuj_der(2,2,3,5,maxconts,maxres) + double precision AEA,AEAderg,AEAderx,AECA,AECAderg,AECAderx, + & ADtEA,ADtEAderg,ADtEAderx,AEAb1,AEAb1derg,AEAb1derx, + & AEAb2,AEAb2derg,AEAb2derx,g_contij,ekont + common /diploc/ AEA(2,2,2),AEAderg(2,2,2),AEAderx(2,2,3,5,2,2), + & EAEA(2,2,2), EAEAderg(2,2,2,2), EAEAderx(2,2,3,5,2,2), + & AECA(2,2,2),AECAderg(2,2,2),AECAderx(2,2,3,5,2,2), + & ADtEA(2,2,2),ADtEAderg(2,2,2,2),ADtEAderx(2,2,3,5,2,2), + & ADtEA1(2,2,2),ADtEA1derg(2,2,2,2),ADtEA1derx(2,2,3,5,2,2), + & AEAb1(2,2,2),AEAb1derg(2,2,2),AEAb1derx(2,3,5,2,2,2), + & AEAb2(2,2,2),AEAb2derg(2,2,2,2),AEAb2derx(2,3,5,2,2,2), + & g_contij(3,2),ekont +C 12/13/2008 (again Poland-Jaruzel war anniversary) +C RE: Parallelization of 4th and higher order loc-el correlations + integer ncont_sent,ncont_recv,iint_sent,iisent_local, + & itask_cont_from,itask_cont_to,ntask_cont_from,ntask_cont_to, + & nat_sent,iat_sent,iturn3_sent,iturn4_sent,iturn3_sent_local, + & iturn4_sent_local + common /contdistrib/ ncont_sent(maxres),ncont_recv(maxres), + & iint_sent(4,maxres,maxres),iint_sent_local(4,maxres,maxres), + & iturn3_sent(4,maxres),iturn4_sent(4,maxres), + & iturn3_sent_local(4,maxres),iturn4_sent_local(4,maxres), + & nat_sent,iat_sent(maxres),itask_cont_from(0:max_fg_procs-1), + & itask_cont_to(0:max_fg_procs-1),ntask_cont_from,ntask_cont_to diff --git a/source/unres/src_MD-DFA-restraints/COMMON.CONTACTS.moment b/source/unres/src_MD-DFA-restraints/COMMON.CONTACTS.moment new file mode 100644 index 0000000..d07a0f0 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/COMMON.CONTACTS.moment @@ -0,0 +1,68 @@ +C Change 12/1/95 - common block CONTACTS1 included. + integer ncont,ncont_ref,icont,icont_ref,num_cont,jcont + double precision facont,gacont + common /contacts/ ncont,ncont_ref,icont(2,maxcont), + & icont_ref(2,maxcont) + common /contacts1/ facont(maxconts,maxres), + & gacont(3,maxconts,maxres), + & num_cont(maxres),jcont(maxconts,maxres) +C 12/26/95 - H-bonding contacts + common /contacts_hb/ + & gacontp_hb1(3,maxconts,maxres),gacontp_hb2(3,maxconts,maxres), + & gacontp_hb3(3,maxconts,maxres), + & gacontm_hb1(3,maxconts,maxres),gacontm_hb2(3,maxconts,maxres), + & gacontm_hb3(3,maxconts,maxres), + & gacont_hbr(3,maxconts,maxres), + & grij_hb_cont(3,maxconts,maxres), + & facont_hb(maxconts,maxres),ees0p(maxconts,maxres), + & ees0m(maxconts,maxres),d_cont(maxconts,maxres), + & num_cont_hb(maxres),jcont_hb(maxconts,maxres) +C 9/23/99 Added improper rotation matrices and matrices of dipole-dipole +C interactions +C Interactions of pseudo-dipoles generated by loc-el interactions. + double precision dip,dipderg,dipderx + common /dipint/ dip(4,maxconts,maxres),dipderg(4,maxconts,maxres), + & dipderx(3,5,4,maxconts,maxres) +C 10/30/99 Added other pre-computed vectors and matrices needed +C to calculate three - six-order el-loc correlation terms + double precision Ug,Ugder,Ug2,Ug2der,obrot,obrot2,obrot_der, + & obrot2_der,Ub2,Ub2der,mu,muder,EUg,EUgder,CUg,CUgder, + & DUg,DUgder,DtUg2,DtUg2der,Ctobr,Ctobrder,Dtobr2,Dtobr2der + common /rotat/ Ug(2,2,maxres),Ugder(2,2,maxres),Ug2(2,2,maxres), + & Ug2der(2,2,maxres),obrot(2,maxres),obrot2(2,maxres), + & obrot_der(2,maxres),obrot2_der(2,maxres) +C This common block contains vectors and matrices dependent on a single +C amino-acid residue. + common /precomp1/ Ub2(2,maxres),Ub2der(2,maxres),mu(2,maxres), + & EUg(2,2,maxres),EUgder(2,2,maxres),CUg(2,2,maxres), + & CUgder(2,2,maxres),DUg(2,2,maxres),Dugder(2,2,maxres), + & DtUg2(2,2,maxres),DtUg2der(2,2,maxres),Ctobr(2,maxres), + & Ctobrder(2,maxres),Dtobr2(2,maxres),Dtobr2der(2,maxres) +C This common block contains vectors and matrices dependent on two +C consecutive amino-acid residues. + double precision Ug2Db1t,Ug2Db1tder,CUgb2,CUgb2der,EUgC, + & EUgCder,EUgD,EUgDder,DtUg2EUg,DtUg2EUgder + common /precomp2/ Ug2Db1t(2,maxres),Ug2Db1tder(2,maxres), + & CUgb2(2,maxres),CUgb2der(2,maxres),EUgC(2,2,maxres), + & EUgCder(2,2,maxres),EUgD(2,2,maxres),EUgDder(2,2,maxres), + & DtUg2EUg(2,2,maxres),DtUg2EUgder(2,2,2,maxres), + & Ug2DtEUg(2,2,maxres),Ug2DtEUgder(2,2,2,maxres) + double precision costab,sintab,costab2,sintab2 + common /rotat_old/ costab(maxres),sintab(maxres), + & costab2(maxres),sintab2(maxres),muder(2,maxres) +C This common block contains dipole-interaction matrices and their +C Cartesian derivatives. + double precision a_chuj,a_chuj_der + common /dipmat/ a_chuj(2,2,maxconts,maxres), + & a_chuj_der(2,2,3,5,maxconts,maxres) + double precision AEA,AEAderg,AEAderx,AECA,AECAderg,AECAderx, + & ADtEA,ADtEAderg,ADtEAderx,AEAb1,AEAb1derg,AEAb1derx, + & AEAb2,AEAb2derg,AEAb2derx + common /diploc/ AEA(2,2,2),AEAderg(2,2,2),AEAderx(2,2,3,5,2,2), + & EAEA(2,2,2), EAEAderg(2,2,2,2), EAEAderx(2,2,3,5,2,2), + & AECA(2,2,2),AECAderg(2,2,2),AECAderx(2,2,3,5,2,2), + & ADtEA(2,2,2),ADtEAderg(2,2,2,2),ADtEAderx(2,2,3,5,2,2), + & ADtEA1(2,2,2),ADtEA1derg(2,2,2,2),ADtEA1derx(2,2,3,5,2,2), + & AEAb1(2,2,2),AEAb1derg(2,2,2),AEAb1derx(2,3,5,2,2,2), + & AEAb2(2,2,2),AEAb2derg(2,2,2,2),AEAb2derx(2,3,5,2,2,2), + & g_contij(3,2),ekont diff --git a/source/unres/src_MD-DFA-restraints/COMMON.CONTROL b/source/unres/src_MD-DFA-restraints/COMMON.CONTROL new file mode 100644 index 0000000..9fce3c5 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/COMMON.CONTROL @@ -0,0 +1,15 @@ + integer modecalc,iscode,indpdb,indback,indphi,iranconf,icheckgrad, + & inprint,i2ndstr,mucadyn,constr_dist,constr_homology + real*8 waga_dist, waga_angle + 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,constr_homology, + & waga_dist, waga_angle +C... minim = .true. means DO minimization. +C... energy_dec = .true. means print energy decomposition matrix diff --git a/source/unres/src_MD-DFA-restraints/COMMON.DBASE b/source/unres/src_MD-DFA-restraints/COMMON.DBASE new file mode 100644 index 0000000..4f07780 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/COMMON.DBASE @@ -0,0 +1,3 @@ + common /struct/ cart_base(3,maxres_base,maxseq),str_nam(maxseq), + & nres_base(3,maxseq),nseq + character*8 str_nam diff --git a/source/unres/src_MD-DFA-restraints/COMMON.DERIV b/source/unres/src_MD-DFA-restraints/COMMON.DERIV new file mode 100644 index 0000000..67ebfdc --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/COMMON.DERIV @@ -0,0 +1,37 @@ + 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,gvdwx + 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_MD-DFA-restraints/COMMON.DFA b/source/unres/src_MD-DFA-restraints/COMMON.DFA new file mode 100644 index 0000000..c6add4f --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/COMMON.DFA @@ -0,0 +1,101 @@ +C ======= +C COMMON.DFA +C ======= +C 2010/12/20 By Juyong Lee +C +c parameter +C [ 8 * ( Nres - 8 ) ] distance restraints +C [ 2 * ( Nres - 8 ) ] angle restraints +C [ Nres ] neighbor restraints +C Total : ~ 11 * Nres restraints +C +C + INTEGER IDFAMAX,IDFAMX2,IDFACMD,IDMAXMIN, MAXN + PARAMETER(IDFAMAX=4000,IDFAMX2=1000,IDFACMD=500,IDMAXMIN=500) + PARAMETER(MAXN=4) + real*8 wwdist,wwangle,wwnei + parameter(wwdist=1.0d0,wwangle=1.0d0,wwnei=1.0d0) + +C IDFAMAX - maximum number of DFA restraint including distance, angle and +C number of neighbors ( Max of assign statement ) +C IDFAMX2 - maximum number of atoms which are targets of restraints +C IDFACMD - maximum number of 'DFA' command call +C IDMAXMIN - Maximum number of minima of dist, angle and neighbor info. from fragments +C MAXN - Maximum Number of shell, currently 4 +C MAXRES - Maximum number of CAs + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCc +C INTEGER +C DFANUM - Number of ALL DFA restrants +c IDFA[DIS, PHI, THE, NEI] - NUMBER of restraints +c IDISNUM - number of minima for a distance restraint +c IPHINUM - number of minima for a phi angle restraint +c ITHENUM - number of minima for a theta angle restraint +c INEINUM - number of minima for a number of neighbors restraint + +c IDISLIS - atom number of two atoms for distance restraint +c IPHILIS - atom numbers of four atoms for angle restraint +c ITHELIS - atom numbers of four atoms for angle restraint +c INEILIS - atom number of center of neighbor calculation +c JNEILIS - atom number of target of neighboring calculation +c JNEINUM - number of target atoms of neighboring term +C KSHELL - SHELL number + +C ishiftca - index shift for CA atoms in UNRES (1 if the 1st aa != GLY) +C ilastca - index of the last CA atom in UNRES (nres-1 if last aa != GLY) + +C old only for CHARMM +C STOAGDF - Store assign information ( How many assign within one command ) +C NMAP - mapping between dfanum and ndis, nphi, nthe, nnei + + INTEGER IDFADIS,IDFAPHI,IDFATHE,IDFANEI, + & IDISLIS,IPHILIS,ITHELIS,INEILIS, + & IDISNUM,IPHINUM,ITHENUM,INEINUM, + & FNEI,DFACMD, DFANUM, + & NCA,ICAIDX, + & STOAGDF, NMAP, IDFACAT, KDISNUM, KSHELL + & ishiftca,ilastca + COMMON /IDFA/ DFACMD, DFANUM, + & IDFADIS, IDFAPHI, IDFANEI, IDFATHE, + & IDISNUM(IDFAMAX), IPHINUM(IDFAMAX), + & ITHENUM(IDFAMAX), INEINUM(IDFAMAX), + & FNEI(IDFAMAX,IDMAXMIN), IDISLIS(2,IDFAMAX), + & IPHILIS(5,IDFAMAX), ITHELIS(5,IDFAMAX), + & INEILIS(IDFAMAX), + & KSHELL(IDFAMAX), + & IDFACAT(IDFACMD), + & KDISNUM(IDFAMAX), + & NCA, ICAIDX(MAXRES) + COMMON /IDFA2/ ishiftca,ilastca + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C REAL VARIABLES +C +c SCC[DIST, PHI, THE] - weight of each calculations +c FDIST - distance minima +C FPHI - phi minima +c FTHE - theta minima +C DFAEXP : calculate expential function in advance +C + REAL*8 SCCDIST, SCCPHI, SCCTHE, SCCNEI, FDIST, FPHI1, FPHI2, + & FTHE1, FTHE2, + & DIS_INC, PHI_INC, THE_INC, NEI_INC, BETA_INC, + & WSHET, EDFABET, + & CK, SCK, S1, S2 +c & ,DFAEXP + + COMMON /RDFA/ SCCDIST(IDFAMAX,IDMAXMIN),FDIST(IDFAMAX,IDMAXMIN), + & SCCPHI(IDFAMAX,IDMAXMIN), SCCTHE(IDFAMAX,IDMAXMIN), + & SCCNEI(IDFAMAX,IDMAXMIN), + & FPHI1(IDFAMAX,IDMAXMIN), FPHI2(IDFAMAX,IDMAXMIN), + & FTHE1(IDFAMAX,IDMAXMIN), FTHE2(IDFAMAX,IDMAXMIN), + & DIS_INC, PHI_INC, THE_INC, NEI_INC, BETA_INC, + & WSHET(MAXRES,MAXRES), EDFABET, + & CK(4),SCK(4),S1(4),S2(4) +c & ,DFAEXP(15001), + + DATA CK/1.0D0,1.58740105197D0,2.08008382305D0,2.51984209979D0/ + DATA SCK/1.0D0,1.25992104989D0,1.44224957031D0,1.58740105197D0/ + DATA S1/3.75D0,5.75D0,7.75D0,9.75D0/ + DATA S2/4.25D0,6.25D0,8.25D0,10.25D0/ diff --git a/source/unres/src_MD-DFA-restraints/COMMON.DISTFIT b/source/unres/src_MD-DFA-restraints/COMMON.DISTFIT new file mode 100644 index 0000000..683228a --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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) +csa COMMON /frag/ bvar_frag(mxio,6),hvar_frag(mxio,3), +csa 1 lvar_frag(mxio,3),svar_frag(mxio,3), +csa 2 avar_frag(mxio,5) + COMMON /WAGI/ w(MAXRES22),d0(MAXRES22) + COMMON /POCHODNE/ NX,NY,DRDG(MAXRES22,MAXRES),DD(MAXRES22), + 1 H(MAXRES,MAXRES),XX(MAXRES) + COMMON /frozen/ mask(maxres) + COMMON /store0/ nhpb0 diff --git a/source/unres/src_MD-DFA-restraints/COMMON.FFIELD b/source/unres/src_MD-DFA-restraints/COMMON.FFIELD new file mode 100644 index 0000000..29c73f0 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/COMMON.GEO b/source/unres/src_MD-DFA-restraints/COMMON.GEO new file mode 100644 index 0000000..8cfbbde --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/COMMON.HAIRPIN b/source/unres/src_MD-DFA-restraints/COMMON.HAIRPIN new file mode 100644 index 0000000..f103268 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/COMMON.HEADER b/source/unres/src_MD-DFA-restraints/COMMON.HEADER new file mode 100644 index 0000000..7154812 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/COMMON.HEADER @@ -0,0 +1,2 @@ + character*80 titel + common /header/ titel diff --git a/source/unres/src_MD-DFA-restraints/COMMON.INFO b/source/unres/src_MD-DFA-restraints/COMMON.INFO new file mode 100644 index 0000000..4f63708 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/COMMON.INTERACT b/source/unres/src_MD-DFA-restraints/COMMON.INTERACT new file mode 100644 index 0000000..fabad93 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/COMMON.IOUNITS b/source/unres/src_MD-DFA-restraints/COMMON.IOUNITS new file mode 100644 index 0000000..49b6db3 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/COMMON.LANGEVIN b/source/unres/src_MD-DFA-restraints/COMMON.LANGEVIN new file mode 100644 index 0000000..6a703e2 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/COMMON.LANGEVIN @@ -0,0 +1,21 @@ + double precision friction(3,0:MAXRES2),stochforc(3,0:MAXRES2), + & fricmat(MAXRES2,MAXRES2),fric_work(MAXRES6), + & stoch_work(MAXRES6), + & fricgam(MAXRES6),fricvec(MAXRES2,MAXRES2), + & pfric_mat(MAXRES2,MAXRES2),vfric_mat(MAXRES2,MAXRES2), + & afric_mat(MAXRES2,MAXRES2),prand_mat(MAXRES2,MAXRES2), + & vrand_mat1(MAXRES2,MAXRES2),vrand_mat2(MAXRES2,MAXRES2), + & pfric0_mat(MAXRES2,MAXRES2,0:maxflag_stoch), + & afric0_mat(MAXRES2,MAXRES2,0:maxflag_stoch), + & vfric0_mat(MAXRES2,MAXRES2,0:maxflag_stoch), + & prand0_mat(MAXRES2,MAXRES2,0:maxflag_stoch), + & vrand0_mat1(MAXRES2,MAXRES2,0:maxflag_stoch), + & vrand0_mat2(MAXRES2,MAXRES2,0:maxflag_stoch), + & mt1(maxres2,maxres2),mt2(maxres2,maxres2),mt3(maxres2,maxres2) + logical flag_stoch(0:maxflag_stoch) + common /langforc/ friction,stochforc, + & fricmat,fric_work,fricgam,stoch_work,fricvec,vrand_mat1, + & vrand_mat2,prand_mat,vfric_mat,afric_mat,pfric_mat, + & pfric0_mat,afric0_mat,vfric0_mat,prand0_mat,vrand0_mat1, + & vrand0_mat2,flag_stoch + common /langmat/ mt1,mt2,mt3 diff --git a/source/unres/src_MD-DFA-restraints/COMMON.LANGEVIN.lang0 b/source/unres/src_MD-DFA-restraints/COMMON.LANGEVIN.lang0 new file mode 100644 index 0000000..354a0c4 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/COMMON.LANGEVIN.lang0 @@ -0,0 +1,11 @@ + double precision friction(3,0:MAXRES2),stochforc(3,0:MAXRES2), + & fricmat(MAXRES2,MAXRES2),fric_work(MAXRES6), + & stoch_work(MAXRES6), + & fricgam(MAXRES6),fricvec(MAXRES2,MAXRES2) + logical flag_stoch(0:maxflag_stoch) + common /langforc/ friction,stochforc, + & fricmat,fric_work,fricgam,stoch_work,fricvec,vrand_mat1, + & vrand_mat2,prand_mat,vfric_mat,afric_mat,pfric_mat, + & pfric0_mat,afric0_mat,vfric0_mat,prand0_mat,vrand0_mat1, + & vrand0_mat2,flag_stoch + common /langmat/ mt1,mt2,mt3 diff --git a/source/unres/src_MD-DFA-restraints/COMMON.LOCAL b/source/unres/src_MD-DFA-restraints/COMMON.LOCAL new file mode 100644 index 0000000..a3f68dc --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/COMMON.LOCAL @@ -0,0 +1,55 @@ + double precision a0thet,athet,bthet,polthet,gthet,theta0,sig0, + & sigc0,dsc,dsc_inv,bsc,censc,gaussc,dsc0 + integer nlob +C Parameters of the virtual-bond-angle probability distribution + common /thetas/ a0thet(ntyp),athet(2,ntyp),bthet(2,ntyp), + & polthet(0:3,ntyp),gthet(3,ntyp),theta0(ntyp),sig0(ntyp), + & sigc0(ntyp) +C Parameters of the side-chain probability distribution + common /sclocal/ dsc(ntyp1),dsc_inv(ntyp1),bsc(maxlob,ntyp), + & censc(3,maxlob,ntyp),gaussc(3,3,maxlob,ntyp),dsc0(ntyp1), + & nlob(ntyp1) +C Parameters of ab initio-derived potential of virtual-bond-angle bending + integer nthetyp,ntheterm,ntheterm2,ntheterm3,nsingle,ndouble, + & ithetyp(ntyp1),nntheterm + double precision aa0thet(maxthetyp1,maxthetyp1,maxthetyp1), + & aathet(maxtheterm,maxthetyp1,maxthetyp1,maxthetyp1), + & bbthet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), + & ccthet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), + & ddthet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), + & eethet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), + & ffthet(maxdouble,maxdouble,maxtheterm3,maxthetyp1,maxthetyp1, + & maxthetyp1), + & ggthet(maxdouble,maxdouble,maxtheterm3,maxthetyp1,maxthetyp1, + & maxthetyp1) + common /theta_abinitio/aa0thet,aathet,bbthet,ccthet,ddthet,eethet, + & ffthet, + & ggthet,ithetyp,nthetyp,ntheterm,ntheterm2,ntheterm3,nsingle, + & ndouble,nntheterm +C Virtual-bond lenghts + double precision vbl,vblinv,vblinv2,vbl_cis,vbl0,vbld_inv + integer loc_start,loc_end,ithet_start,ithet_end,iphi_start, + & iphi_end,iphid_start,iphid_end,itau_start,itau_end,ibond_start, + & ibond_end, + & ibondp_start,ibondp_end,ivec_start,ivec_end,iset_start,iset_end, + & iturn3_start,iturn3_end,iturn4_start,iturn4_end,iint_start, + & iint_end,iphi1_start,iphi1_end, + & ibond_displ(0:max_fg_procs-1),ibond_count(0:max_fg_procs-1), + & ithet_displ(0:max_fg_procs-1),ithet_count(0:max_fg_procs-1), + & iphi_displ(0:max_fg_procs-1),iphi_count(0:max_fg_procs-1), + & iphi1_displ(0:max_fg_procs-1),iphi1_count(0:max_fg_procs-1), + & ivec_displ(0:max_fg_procs-1),ivec_count(0:max_fg_procs-1), + & iset_displ(0:max_fg_procs-1),iset_count(0:max_fg_procs-1), + & iint_count(0:max_fg_procs-1),iint_displ(0:max_fg_procs-1) + common /peptbond/ vbl,vblinv,vblinv2,vbl_cis,vbl0 + common /indices/ loc_start,loc_end,ithet_start,ithet_end, + & iphi_start,iphi_end,iphid_start,iphid_end,itau_start,itau_end, + & ibond_start,ibond_end, + & ibondp_start,ibondp_end,ivec_start,ivec_end,iset_start,iset_end, + & iturn3_start,iturn3_end,iturn4_start,iturn4_end,iint_start, + & iint_end,iphi1_start,iphi1_end,iint_count,iint_displ,ivec_displ, + & ivec_count,iset_displ, + & iset_count,ibond_displ,ibond_count,ithet_displ,ithet_count, + & iphi_displ,iphi_count,iphi1_displ,iphi1_count +C Inverses of the actual virtual bond lengths + common /invlen/ vbld_inv(maxres2) diff --git a/source/unres/src_MD-DFA-restraints/COMMON.LOCMOVE b/source/unres/src_MD-DFA-restraints/COMMON.LOCMOVE new file mode 100644 index 0000000..211516d --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/COMMON.MAP b/source/unres/src_MD-DFA-restraints/COMMON.MAP new file mode 100644 index 0000000..77e97e7 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/COMMON.MAP @@ -0,0 +1,4 @@ + integer nmap,res1,res2,nstep + double precision ang_from,ang_to + common /mapp/ ang_from(maxvar),ang_to(maxvar),nmap,kang(maxvar), + & res1(maxvar),res2(maxvar),nstep(maxvar) diff --git a/source/unres/src_MD-DFA-restraints/COMMON.MAXGRAD b/source/unres/src_MD-DFA-restraints/COMMON.MAXGRAD new file mode 100644 index 0000000..285241a --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/COMMON.MCE b/source/unres/src_MD-DFA-restraints/COMMON.MCE new file mode 100644 index 0000000..2d79184 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/COMMON.MCE @@ -0,0 +1,13 @@ + double precision entropy(-max_ene-4:max_ene),nminima(maxsave), + & nhist(-max_ene:max_ene) + logical ent_read,multican + common /mce/ entropy,emin,emax,nhist,nminima,ent_read,multican, + & indminn,indmaxx + integer npool + double precision xpool,epool,pool_fraction + common /pool/ xpool(maxvar,max_pool),epool(max_pool), + & pool_fraction,npool + integer save_frequency,message_frequency,pool_read_freq, + & pool_save_freq,print_freq + common /mce_counters/ save_frequency,message_frequency, + & pool_read_freq,pool_save_freq,print_freq diff --git a/source/unres/src_MD-DFA-restraints/COMMON.MCM b/source/unres/src_MD-DFA-restraints/COMMON.MCM new file mode 100644 index 0000000..576f912 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/COMMON.MD b/source/unres/src_MD-DFA-restraints/COMMON.MD new file mode 100644 index 0000000..bd38d1b --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/COMMON.MD @@ -0,0 +1,87 @@ + 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) + + real*8 odl(max_template,maxdim),sigma_odl(max_template,maxdim), + & dih(max_template,maxres),sigma_dih(max_template,maxres) + + integer ires_homo(maxdim),jres_homo(maxdim) + + 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,lim_odl,lim_dih,link_start_homo,link_end_homo, + & idihconstr_start_homo,idihconstr_end_homo + 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 /homrestr/ odl,dih,sigma_dih,sigma_odl, + & lim_odl,lim_dih,ires_homo,jres_homo,link_start_homo, + & link_end_homo,idihconstr_start_homo,idihconstr_end_homo + common /qmeas/ qfrag,qpair,qinfrag,qinpair,wfrag,wpair,eq_time, + & Ucdfrag,Ucdpair,dUdconst,dUdxconst,dqwol,dxqwol,Uconst, + & iset,mset,nset,usampl,ifrag,ipair,npair,nfrag + common /mdpar/ v_ini,d_time,d_time0,scal_fric, + & t_bath,tau_bath,dvmax,damax,n_timestep,mdpdb, + & ntime_split,ntime_split0,maxtime_split, + & ntwx,ntwe,large,print_compon,tbf,rest,tnp,tnp1,tnh + common /MDcalc/ totT,totE,potE,potEcomp,EK,amax,edriftmax, + & kinetic_T + common /lagrange/ d_t,d_t_old,d_t_new,d_t_work, + & d_t_work_new,d_a,d_a_old,d_a_work,d_af_work,d_as_work,d_a_short, + & kinetic_force, + & A,Ginv,Gmat,Gvec,Geigen,Gsqrp,Gsqrm, + & vtot,dimen,dimen1,dimen3,lang, + & reset_moment,reset_vel,count_reset_moment,count_reset_vel, + & rattle,RESPA + common /inertia/ IP,ISC,MP,MSC + double precision scal_fric,rwat,etawat,gamp, + & gamsc(ntyp),stdfp,stdfsc(ntyp),stdforcp(MAXRES), + & stdforcsc(MAXRES),pstok,restok(ntyp+1),cPoise,Rb + common /langevin/ pstok,restok,gamp,gamsc, + & stdfp,stdfsc,stdforcp,stdforcsc,rwat,etawat,cPoise,Rb,surfarea, + & reset_fricmat + common /mdpmpi/ igmult_start,igmult_end,my_ng_count, + & myginv_ng_count, + & ng_start(0:MaxProcs-1),ng_counts(0:MaxProcs-1), + & nginv_start(0:MaxProcs),nginv_counts(0:MaxProcs-1) + double precision pi_np,pistar,s_np,s12_np,Q_np,E_old,H0,E_long, + & sold_np,d_t_half,Csplit,hhh + common /nosepoincare/ pi_np,pistar,s_np,s12_np,Q_np,E_old,H0, + & E_long,sold_np,d_t_half(3,0:MAXRES2),Csplit,hhh + common /nosehoover/ glogs(maxmnh),qmass(maxmnh), + & vlogs(maxmnh),xlogs(maxmnh), + & nresn,nyosh,nnos,xiresp + integer hmc,hmc_acc + double precision dc_hmc,hmc_etot,totThmc + common /hmc_md/ dc_hmc(3,0:maxres2),hmc_etot,totThmc,hmc,hmc_acc diff --git a/source/unres/src_MD-DFA-restraints/COMMON.MINIM b/source/unres/src_MD-DFA-restraints/COMMON.MINIM new file mode 100644 index 0000000..e44f9cd --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/COMMON.MUCA b/source/unres/src_MD-DFA-restraints/COMMON.MUCA new file mode 100644 index 0000000..7529c15 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/COMMON.MUCA @@ -0,0 +1,10 @@ + double precision emuca(4*maxres),nemuca(4*maxres), + & nemuca2(4*maxres),elow,ehigh,factor, + & elowi(maxprocs),ehighi(maxprocs),hbin, + & hist(4*maxres),factor_min + integer nmuca,imtime,muca_smooth + common /double_muca/ emuca,nemuca, + & nemuca2,elow,ehigh,factor,hbin,hist,factor_min + common /integer_muca/ nmuca,imtime,muca_smooth + common /mucarem/ elowi,ehighi + diff --git a/source/unres/src_MD-DFA-restraints/COMMON.NAMES b/source/unres/src_MD-DFA-restraints/COMMON.NAMES new file mode 100644 index 0000000..e6f926b --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/COMMON.REMD b/source/unres/src_MD-DFA-restraints/COMMON.REMD new file mode 100644 index 0000000..b283b5b --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/COMMON.REMD @@ -0,0 +1,36 @@ + integer nrep,nstex,hremd + logical remd_tlist,remd_mlist,mremdsync,restart1file,traj1file + double precision retmin,retmax,remd_t(maxprocs) + double precision hweights(maxprocs/20,n_ene) + integer remd_m(maxprocs),i_sync_step + integer*2 i2rep(0:maxprocs),i2set(0:maxprocs) + integer*2 ifirst(maxprocs) + integer*2 nupa(0:maxprocs/4,0:maxprocs), + & ndowna(0:maxprocs/4,0:maxprocs) + real t_restart1(5,maxprocs) + integer iset_restart1(maxprocs) + logical t_exchange_only + common /remdcommon/ nrep,nstex,retmin,retmax,remd_t,remd_tlist, + & remd_mlist,remd_m,mremdsync,restart1file, + & traj1file,i_sync_step,t_exchange_only + common /hamilt_remd/ hweights,hremd + common /remdrestart/ i2rep,i2set,ifirst,nupa,ndowna,t_restart1, + & iset_restart1 + real totT_cache,EK_cache,potE_cache,t_bath_cache,Uconst_cache, + & qfrag_cache,qpair_cache,c_cache,uscdiff_cache, + & ugamma_cache,utheta_cache + integer ntwx_cache,ii_write,max_cache_traj_use + common /traj1cache/ totT_cache(max_cache_traj), + & EK_cache(max_cache_traj), + & potE_cache(max_cache_traj), + & t_bath_cache(max_cache_traj), + & Uconst_cache(max_cache_traj), + & qfrag_cache(50,max_cache_traj), + & qpair_cache(100,max_cache_traj), + & ugamma_cache(maxfrag_back,max_cache_traj), + & utheta_cache(maxfrag_back,max_cache_traj), + & uscdiff_cache(maxfrag_back,max_cache_traj), + & c_cache(3,maxres2+2,max_cache_traj), + & iset_cache(max_cache_traj),ntwx_cache, + & ii_write,max_cache_traj_use + diff --git a/source/unres/src_MD-DFA-restraints/COMMON.SBRIDGE b/source/unres/src_MD-DFA-restraints/COMMON.SBRIDGE new file mode 100644 index 0000000..91dd2cd --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/COMMON.SBRIDGE @@ -0,0 +1,17 @@ + double precision ss_depth,ebr,d0cm,akcm,akth,akct,v1ss,v2ss,v3ss + integer ns,nss,nfree,iss + common /sbridge/ ss_depth,ebr,d0cm,akcm,akth,akct,v1ss,v2ss,v3ss, + & ns,nss,nfree,iss(maxss) + double precision dhpb,dhpb1,forcon + integer ihpb,jhpb,nhpb,idssb,jdssb + common /links/ dhpb(maxdim),dhpb1(maxdim),forcon(maxdim), + & ihpb(maxdim),jhpb(maxdim),ibecarb(maxdim),nhpb + double precision weidis + common /restraints/ weidis + integer link_start,link_end + common /links_split/ link_start,link_end + double precision Ht,dyn_ssbond_ij + logical dyn_ss,dyn_ss_mask + common /dyn_ssbond/ dyn_ssbond_ij(maxres,maxres), + & idssb(maxdim),jdssb(maxdim), + & Ht,dyn_ss,dyn_ss_mask(maxres) diff --git a/source/unres/src_MD-DFA-restraints/COMMON.SCCOR b/source/unres/src_MD-DFA-restraints/COMMON.SCCOR new file mode 100644 index 0000000..8de6d3c --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/COMMON.SCCOR @@ -0,0 +1,17 @@ +cc Parameters of the SCCOR term + double precision v1sccor,v2sccor,vlor1sccor, + & vlor2sccor,vlor3sccor,gloc_sc, + & dcostau,dsintau,dtauangle,dcosomicron, + & domicron,v0sccor + integer nterm_sccor,isccortyp,nsccortyp,nlor_sccor + common/sccor/v1sccor(maxterm_sccor,3,20,20), + & v2sccor(maxterm_sccor,3,20,20), + & vlor1sccor(maxterm_sccor,20,20), + & vlor2sccor(maxterm_sccor,20,20), + & vlor3sccor(maxterm_sccor,20,20),gloc_sc(3,0:maxres2,10), + & v0sccor(ntyp,ntyp), + & dcostau(3,3,3,maxres2),dsintau(3,3,3,maxres2), + & dtauangle(3,3,3,maxres2),dcosomicron(3,3,3,maxres2), + & domicron(3,3,3,maxres2), + & nterm_sccor(ntyp,ntyp),isccortyp(ntyp),nsccortyp, + & nlor_sccor(ntyp,ntyp) diff --git a/source/unres/src_MD-DFA-restraints/COMMON.SCROT b/source/unres/src_MD-DFA-restraints/COMMON.SCROT new file mode 100644 index 0000000..2da7b8f --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/COMMON.SETUP b/source/unres/src_MD-DFA-restraints/COMMON.SETUP new file mode 100644 index 0000000..5039116 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/COMMON.SPLITELE b/source/unres/src_MD-DFA-restraints/COMMON.SPLITELE new file mode 100644 index 0000000..a2f0447 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/COMMON.SPLITELE @@ -0,0 +1,2 @@ + double precision r_cut,rlamb + common /splitele/ r_cut,rlamb diff --git a/source/unres/src_MD-DFA-restraints/COMMON.THREAD b/source/unres/src_MD-DFA-restraints/COMMON.THREAD new file mode 100644 index 0000000..5c814cc --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/COMMON.TIME1 b/source/unres/src_MD-DFA-restraints/COMMON.TIME1 new file mode 100644 index 0000000..d6203a6 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/COMMON.TORCNSTR b/source/unres/src_MD-DFA-restraints/COMMON.TORCNSTR new file mode 100644 index 0000000..e4af17c --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/COMMON.TORSION b/source/unres/src_MD-DFA-restraints/COMMON.TORSION new file mode 100644 index 0000000..6b6605f --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/COMMON.VAR b/source/unres/src_MD-DFA-restraints/COMMON.VAR new file mode 100644 index 0000000..edc81d7 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/COMMON.VAR @@ -0,0 +1,21 @@ +C Store the geometric variables in the following COMMON block. + integer ntheta,nphi,nside,nvar,Origin,nstore,ialph,ivar, + & mask_theta,mask_phi,mask_side + double precision theta,phi,alph,omeg,varsave,esave,varall,vbld, + & thetaref,phiref,costtab,sinttab,cost2tab,sint2tab, + & xxtab,yytab,zztab,xxref,yyref,zzref,tauangle,omicron + common /var/ theta(maxres),phi(maxres),alph(maxres),omeg(maxres), + & omicron(2,maxres),tauangle(3,maxres), + & vbld(2*maxres),thetaref(maxres),phiref(maxres), + & costtab(maxres), sinttab(maxres), cost2tab(maxres), + & sint2tab(maxres),xxtab(maxres),yytab(maxres), + & zztab(maxres),xxref(maxres),yyref(maxres),zzref(maxres), + & ialph(maxres,2),ivar(4*maxres2),ntheta,nphi,nside,nvar +C Store the angles and variables corresponding to old conformations (for use +C in MCM). + common /oldgeo/ varsave(maxvar,maxsave),esave(maxsave), + & Origin(maxsave),nstore +C freeze some variables + logical mask_r + common /restr/ varall(maxvar),mask_r,mask_theta(maxres), + & mask_phi(maxres),mask_side(maxres) diff --git a/source/unres/src_MD-DFA-restraints/COMMON.VECTORS b/source/unres/src_MD-DFA-restraints/COMMON.VECTORS new file mode 100644 index 0000000..d880c24 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/DIMENSIONS b/source/unres/src_MD-DFA-restraints/DIMENSIONS new file mode 100644 index 0000000..6546327 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/DIMENSIONS @@ -0,0 +1,142 @@ +******************************************************************************** +* Settings for the program of united-residue peptide simulation in real space * +* * +* ------- As of 6/23/01 ----------- * +* * +******************************************************************************** +C Max. number of processors. + integer maxprocs + parameter (maxprocs=2048) +C Max. number of fine-grain processors + integer max_fg_procs +c parameter (max_fg_procs=maxprocs) + parameter (max_fg_procs=512) +C Max. number of coarse-grain processors + integer max_cg_procs + parameter (max_cg_procs=maxprocs) +C Max. number of AA residues + integer maxres + parameter (maxres=800) +C Appr. max. number of interaction sites + integer maxres2,maxres6,mmaxres2 + parameter (maxres2=2*maxres,maxres6=6*maxres) + parameter (mmaxres2=(maxres2*(maxres2+1)/2)) +C Max. number of variables + integer maxvar + parameter (maxvar=6*maxres) +C Max. number of groups of interactions that a given SC is involved in + integer maxint_gr + parameter (maxint_gr=2) +C Max. number of derivatives of virtual-bond and side-chain vectors in theta +C or phi. + integer maxdim + parameter (maxdim=(maxres-1)*(maxres-2)/2) +C Max. number of SC contacts + integer maxcont + parameter (maxcont=12*maxres) +C Max. number of contacts per residue + integer maxconts + parameter (maxconts=maxres/4) +c parameter (maxconts=50) +C Number of AA types (at present only natural AA's will be handled + integer ntyp,ntyp1 + parameter (ntyp=20,ntyp1=ntyp+1) +C Max. number of types of dihedral angles & multiplicity of torsional barriers +C and the number of terms in double torsionals + integer maxtor,maxterm,maxlor,maxtermd_1,maxtermd_2 + parameter (maxtor=4,maxterm=10,maxlor=3,maxtermd_1=8,maxtermd_2=8) +C Max. number of residue types and parameters in expressions for +C virtual-bond angle bending potentials + integer maxthetyp,maxthetyp1,maxtheterm,maxtheterm2,maxtheterm3, + & maxsingle,maxdouble,mmaxtheterm + parameter (maxthetyp=3,maxthetyp1=maxthetyp+1,maxtheterm=20, + & maxtheterm2=6,maxtheterm3=4,maxsingle=6,maxdouble=4, + & mmaxtheterm=maxtheterm) +c Max number of torsional terms in SCCOR + integer maxterm_sccor + parameter (maxterm_sccor=6) +C Max. number of lobes in SC distribution + integer maxlob + parameter (maxlob=4) +C Max. number of S-S bridges + integer maxss + parameter (maxss=20) +C Max. number of dihedral angle constraints + integer maxdih_constr + parameter (maxdih_constr=maxres) +C Max. number of patterns in the pattern database + integer maxseq + parameter (maxseq=10) +C Max. number of residues in a peptide in the database + integer maxres_base + parameter (maxres_base=10) +C Max. number of threading attempts + integer maxthread + parameter (maxthread=20) +C Max. number of move types in MCM + integer maxmovetype + parameter (maxmovetype=4) +C Max. number of stored confs. in MC/MCM simulation + integer maxsave + parameter (maxsave=20) +C Max. number of energy intervals + integer max_ene + parameter (max_ene=10) +C Max. number of conformations in Master's cache array + integer max_cache + parameter (max_cache=10) +C Max. number of conformations in the pool + integer max_pool + parameter (max_pool=10) +C Number of energy components + integer n_ene,n_ene2 + parameter (n_ene=28,n_ene2=2*n_ene) +C Number of threads in deformation + integer max_thread,max_thread2 + parameter (max_thread=4,max_thread2=2*max_thread) +C Number of structures to compare at t=0 + integer max_threadss,max_threadss2 + parameter (max_threadss=8,max_threadss2=2*max_threadss) +C Maxmimum number of angles per residue + integer mxang + parameter (mxang=4) +C Maximum number of groups of angles + integer mxgr + parameter (mxgr=2*maxres) +C Maximum number of chains + integer mxch + parameter (mxch=1) +csaC Maximum number of generated conformations +csa integer mxio +csa parameter (mxio=2) +csaC Maximum number of n7 generated conformations +csa integer mxio2 +csa parameter (mxio2=2) +csaC Maximum number of moves (n1-n8) +csa integer mxmv +csa parameter (mxmv=18) +csaC Maximum number of seed +csa integer max_seed +csa parameter (max_seed=1) +C Maximum number of timesteps for which stochastic MD matrices can be stored + integer maxflag_stoch + parameter (maxflag_stoch=0) +C Maximum number of backbone fragments in restraining + integer maxfrag_back + parameter (maxfrag_back=4) +C Maximum number of SC local term fitting function coefficiants + integer maxsccoef + parameter (maxsccoef=65) +C Maximum number of terms in SC bond-stretching potential + integer maxbondterm + parameter (maxbondterm=3) +C Maximum number of conformation stored in cache on each CPU before sending +C to master; depends on nstex / ntwx ratio + integer max_cache_traj + parameter (max_cache_traj=10) +C Nose-Hoover chain - chain length and order of Yoshida algorithm + integer maxmnh,maxyosh + parameter(maxmnh=10,maxyosh=5) +C Maximum number of templates in homology-modeling restraints + integer max_template + parameter(max_template=19) diff --git a/source/unres/src_MD-DFA-restraints/DIMENSIONS.2100 b/source/unres/src_MD-DFA-restraints/DIMENSIONS.2100 new file mode 100644 index 0000000..7990793 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/DIMENSIONS.2100 @@ -0,0 +1,80 @@ +******************************************************************************** +* Settings for the program of united-residue peptide simulation in real space * +* * +* ------- As of 6/23/01 ----------- * +* * +******************************************************************************** +C Max. number of processors. + parameter (maxprocs=2100) +C Max. number of fine-grain processors + parameter (max_fg_procs=maxprocs) +C Max. number of coarse-grain processors + parameter (max_cg_procs=maxprocs) +C Max. number of AA residues + parameter (maxres=150) +C Appr. max. number of interaction sites + parameter (maxres2=2*maxres,maxres6=6*maxres) + parameter (mmaxres6=(maxres6*(maxres6+1)/2)) +C Max. number of variables + parameter (maxvar=6*maxres) +C Max. number of groups of interactions that a given SC is involved in + parameter (maxint_gr=2) +C Max. number of derivatives of virtual-bond and side-chain vectors in theta +C or phi. + parameter (maxdim=(maxres-1)*(maxres-2)/2) +C Max. number of SC contacts + parameter (maxcont=12*maxres) +C Max. number of contacts per residue + parameter (maxconts=maxres) +C Number of AA types (at present only natural AA's will be handled + parameter (ntyp=20,ntyp1=ntyp+1) +C Max. number of types of dihedral angles & multiplicity of torsional barriers +C and the number of terms in double torsionals + parameter (maxtor=4,maxterm=10,maxlor=3,maxtermd_1=8,maxtermd_2=8) +C Max. number of lobes in SC distribution + parameter (maxlob=4) +C Max. number of S-S bridges + parameter (maxss=20) +C Max. number of dihedral angle constraints + parameter (maxdih_constr=maxres) +C Max. number of patterns in the pattern database + parameter (maxseq=10) +C Max. number of residues in a peptide in the database + parameter (maxres_base=10) +C Max. number of threading attempts + parameter (maxthread=20) +C Max. number of move types in MCM + parameter (maxmovetype=4) +C Max. number of stored confs. in MC/MCM simulation + parameter (maxsave=20) +C Max. number of energy intervals + parameter (max_ene=10) +C Max. number of conformations in Master's cache array + parameter (max_cache=10) +C Max. number of conformations in the pool + parameter (max_pool=10) +C Number of energy components + parameter (n_ene=22,n_ene2=2*n_ene) +C Number of threads in deformation + integer max_thread,max_thread2 + parameter (max_thread=4,max_thread2=2*max_thread) +C Number of structures to compare at t=0 + integer max_threadss,max_threadss2 + parameter (max_threadss=8,max_threadss2=2*max_threadss) +C Maxmimum number of angles per residue + parameter (mxang=4) +C Maximum number of groups of angles + parameter (mxgr=2*maxres) +C Maximum number of chains + parameter (mxch=1) +C Maximum number of generated conformations + parameter (mxio=2) +C Maximum number of n7 generated conformations + parameter (mxio2=2) +C Maximum number of moves (n1-n8) + parameter (mxmv=18) +C Maximum number of seed + parameter (max_seed=1) +C Maximum number of timesteps for which stochastic MD matrices can be stored + integer maxflag_stoch + parameter (maxflag_stoch=0) diff --git a/source/unres/src_MD-DFA-restraints/DIMENSIONS.4100 b/source/unres/src_MD-DFA-restraints/DIMENSIONS.4100 new file mode 100644 index 0000000..2a68d39 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/DIMENSIONS.4100 @@ -0,0 +1,80 @@ +******************************************************************************** +* Settings for the program of united-residue peptide simulation in real space * +* * +* ------- As of 6/23/01 ----------- * +* * +******************************************************************************** +C Max. number of processors. + parameter (maxprocs=4100) +C Max. number of fine-grain processors + parameter (max_fg_procs=maxprocs) +C Max. number of coarse-grain processors + parameter (max_cg_procs=maxprocs) +C Max. number of AA residues + parameter (maxres=150) +C Appr. max. number of interaction sites + parameter (maxres2=2*maxres,maxres6=6*maxres) + parameter (mmaxres6=(maxres6*(maxres6+1)/2)) +C Max. number of variables + parameter (maxvar=6*maxres) +C Max. number of groups of interactions that a given SC is involved in + parameter (maxint_gr=2) +C Max. number of derivatives of virtual-bond and side-chain vectors in theta +C or phi. + parameter (maxdim=(maxres-1)*(maxres-2)/2) +C Max. number of SC contacts + parameter (maxcont=12*maxres) +C Max. number of contacts per residue + parameter (maxconts=maxres) +C Number of AA types (at present only natural AA's will be handled + parameter (ntyp=20,ntyp1=ntyp+1) +C Max. number of types of dihedral angles & multiplicity of torsional barriers +C and the number of terms in double torsionals + parameter (maxtor=4,maxterm=10,maxlor=3,maxtermd_1=8,maxtermd_2=8) +C Max. number of lobes in SC distribution + parameter (maxlob=4) +C Max. number of S-S bridges + parameter (maxss=20) +C Max. number of dihedral angle constraints + parameter (maxdih_constr=maxres) +C Max. number of patterns in the pattern database + parameter (maxseq=10) +C Max. number of residues in a peptide in the database + parameter (maxres_base=10) +C Max. number of threading attempts + parameter (maxthread=20) +C Max. number of move types in MCM + parameter (maxmovetype=4) +C Max. number of stored confs. in MC/MCM simulation + parameter (maxsave=20) +C Max. number of energy intervals + parameter (max_ene=10) +C Max. number of conformations in Master's cache array + parameter (max_cache=10) +C Max. number of conformations in the pool + parameter (max_pool=10) +C Number of energy components + parameter (n_ene=22,n_ene2=2*n_ene) +C Number of threads in deformation + integer max_thread,max_thread2 + parameter (max_thread=4,max_thread2=2*max_thread) +C Number of structures to compare at t=0 + integer max_threadss,max_threadss2 + parameter (max_threadss=8,max_threadss2=2*max_threadss) +C Maxmimum number of angles per residue + parameter (mxang=4) +C Maximum number of groups of angles + parameter (mxgr=2*maxres) +C Maximum number of chains + parameter (mxch=1) +C Maximum number of generated conformations + parameter (mxio=2) +C Maximum number of n7 generated conformations + parameter (mxio2=2) +C Maximum number of moves (n1-n8) + parameter (mxmv=18) +C Maximum number of seed + parameter (max_seed=1) +C Maximum number of timesteps for which stochastic MD matrices can be stored + integer maxflag_stoch + parameter (maxflag_stoch=0) diff --git a/source/unres/src_MD-DFA-restraints/MD_A-MTS.F b/source/unres/src_MD-DFA-restraints/MD_A-MTS.F new file mode 100644 index 0000000..95f174d --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/MD_A-MTS.F @@ -0,0 +1,3461 @@ + subroutine MD +c------------------------------------------------ +c The driver for molecular dynamics subroutines +c------------------------------------------------ + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include "mpif.h" + integer IERROR,ERRCODE +#endif + include 'COMMON.SETUP' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' +#ifndef LANG0 + include 'COMMON.LANGEVIN' +#else + include 'COMMON.LANGEVIN.lang0' +#endif + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.TIME1' + double precision cm(3),L(3),vcm(3) +#ifdef VOUT + double precision v_work(maxres6),v_transf(maxres6) +#endif + integer ilen,rstcount + external ilen + character*50 tytul + common /gucio/ cm + integer itime +c +#ifdef MPI + if (ilen(tmpdir).gt.0) + & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_" + & //liczba(:ilen(liczba))//'.rst') +#else + if (ilen(tmpdir).gt.0) + & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_"//'.rst') +#endif + t_MDsetup=0.0d0 + t_langsetup=0.0d0 + t_MD=0.0d0 + t_enegrad=0.0d0 + t_sdsetup=0.0d0 + write (iout,'(20(1h=),a20,20(1h=))') "MD calculation started" +#ifdef MPI + tt0=MPI_Wtime() +#else + tt0 = tcpu() +#endif +c Determine the inverse of the inertia matrix. + call setup_MD_matrices +c Initialize MD + call init_MD +#ifdef MPI + t_MDsetup = MPI_Wtime()-tt0 +#else + t_MDsetup = tcpu()-tt0 +#endif + rstcount=0 +c Entering the MD loop +#ifdef MPI + tt0 = MPI_Wtime() +#else + tt0 = tcpu() +#endif + if (lang.eq.2 .or. lang.eq.3) then +#ifndef LANG0 + call setup_fricmat + if (lang.eq.2) then + call sd_verlet_p_setup + else + call sd_verlet_ciccotti_setup + endif + do i=1,dimen3 + do j=1,dimen3 + pfric0_mat(i,j,0)=pfric_mat(i,j) + afric0_mat(i,j,0)=afric_mat(i,j) + vfric0_mat(i,j,0)=vfric_mat(i,j) + prand0_mat(i,j,0)=prand_mat(i,j) + vrand0_mat1(i,j,0)=vrand_mat1(i,j) + vrand0_mat2(i,j,0)=vrand_mat2(i,j) + enddo + enddo + flag_stoch(0)=.true. + do i=1,maxflag_stoch + flag_stoch(i)=.false. + enddo +#else + write (iout,*) + & "LANG=2 or 3 NOT SUPPORTED. Recompile without -DLANG0" +#ifdef MPI + call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) +#endif + stop +#endif + else if (lang.eq.1 .or. lang.eq.4) then + call setup_fricmat + endif +#ifdef MPI + t_langsetup=MPI_Wtime()-tt0 + tt0=MPI_Wtime() +#else + t_langsetup=tcpu()-tt0 + tt0=tcpu() +#endif + do itime=1,n_timestep + rstcount=rstcount+1 + if (lang.gt.0 .and. surfarea .and. + & mod(itime,reset_fricmat).eq.0) then + if (lang.eq.2 .or. lang.eq.3) then +#ifndef LANG0 + call setup_fricmat + if (lang.eq.2) then + call sd_verlet_p_setup + else + call sd_verlet_ciccotti_setup + endif + do i=1,dimen3 + do j=1,dimen3 + pfric0_mat(i,j,0)=pfric_mat(i,j) + afric0_mat(i,j,0)=afric_mat(i,j) + vfric0_mat(i,j,0)=vfric_mat(i,j) + prand0_mat(i,j,0)=prand_mat(i,j) + vrand0_mat1(i,j,0)=vrand_mat1(i,j) + vrand0_mat2(i,j,0)=vrand_mat2(i,j) + enddo + enddo + flag_stoch(0)=.true. + do i=1,maxflag_stoch + flag_stoch(i)=.false. + enddo +#endif + else if (lang.eq.1 .or. lang.eq.4) then + call setup_fricmat + endif + write (iout,'(a,i10)') + & "Friction matrix reset based on surface area, itime",itime + endif + if (reset_vel .and. tbf .and. lang.eq.0 + & .and. mod(itime,count_reset_vel).eq.0) then + call random_vel + write(iout,'(a,f20.2)') + & "Velocities reset to random values, time",totT + do i=0,2*nres + do j=1,3 + d_t_old(j,i)=d_t(j,i) + enddo + enddo + endif + if (reset_moment .and. mod(itime,count_reset_moment).eq.0) then + call inertia_tensor + call vcm_vel(vcm) + do j=1,3 + d_t(j,0)=d_t(j,0)-vcm(j) + enddo + call kinetic(EK) + kinetic_T=2.0d0/(dimen3*Rb)*EK + scalfac=dsqrt(T_bath/kinetic_T) + write(iout,'(a,f20.2)') "Momenta zeroed out, time",totT + do i=0,2*nres + do j=1,3 + d_t_old(j,i)=scalfac*d_t(j,i) + enddo + enddo + endif + if (lang.ne.4) then + if (RESPA) then +c Time-reversible RESPA algorithm +c (Tuckerman et al., J. Chem. Phys., 97, 1990, 1992) + call RESPA_step(itime) + else +c Variable time step algorithm. + call velverlet_step(itime) + endif + else +#ifdef BROWN + call brown_step(itime) +#else + print *,"Brown dynamics not here!" +#ifdef MPI + call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) +#endif + stop +#endif + endif + if (ntwe.ne.0) then + if (mod(itime,ntwe).eq.0) call statout(itime) +#ifdef VOUT + do j=1,3 + v_work(j)=d_t(j,0) + enddo + ind=3 + do i=nnt,nct-1 + do j=1,3 + ind=ind+1 + v_work(ind)=d_t(j,i) + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + do j=1,3 + ind=ind+1 + v_work(ind)=d_t(j,i+nres) + enddo + endif + enddo + + write (66,'(80f10.5)') + & ((d_t(j,i),j=1,3),i=0,nres-1),((d_t(j,i+nres),j=1,3),i=1,nres) + do i=1,ind + v_transf(i)=0.0d0 + do j=1,ind + v_transf(i)=v_transf(i)+gvec(j,i)*v_work(j) + enddo + v_transf(i)= v_transf(i)*dsqrt(geigen(i)) + enddo + write (67,'(80f10.5)') (v_transf(i),i=1,ind) +#endif + endif + if (mod(itime,ntwx).eq.0) then + write (tytul,'("time",f8.2)') totT + if(mdpdb) then + call pdbout(potE,tytul,ipdb) + else + call cartout(totT) + endif + endif + if (rstcount.eq.1000.or.itime.eq.n_timestep) then + open(irest2,file=rest2name,status='unknown') + write(irest2,*) totT,EK,potE,totE,t_bath + do i=1,2*nres + write (irest2,'(3e15.5)') (d_t(j,i),j=1,3) + enddo + do i=1,2*nres + write (irest2,'(3e15.5)') (dc(j,i),j=1,3) + enddo + close(irest2) + rstcount=0 + endif + enddo +#ifdef MPI + t_MD=MPI_Wtime()-tt0 +#else + t_MD=tcpu()-tt0 +#endif + write (iout,'(//35(1h=),a10,35(1h=)/10(/a40,1pe15.5))') + & ' Timing ', + & 'MD calculations setup:',t_MDsetup, + & 'Energy & gradient evaluation:',t_enegrad, + & 'Stochastic MD setup:',t_langsetup, + & 'Stochastic MD step setup:',t_sdsetup, + & 'MD steps:',t_MD + write (iout,'(/28(1h=),a25,27(1h=))') + & ' End of MD calculation ' +#ifdef TIMING_ENE + write (iout,*) "time for etotal",t_etotal," elong",t_elong, + & " eshort",t_eshort + write (iout,*) "time_fric",time_fric," time_stoch",time_stoch, + & " time_fricmatmult",time_fricmatmult," time_fsample ", + & time_fsample +#endif + return + end +c------------------------------------------------------------------------------- + subroutine velverlet_step(itime) +c------------------------------------------------------------------------------- +c Perform a single velocity Verlet step; the time step can be rescaled if +c increments in accelerations exceed the threshold +c------------------------------------------------------------------------------- + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' + integer ierror,ierrcode +#endif + include 'COMMON.SETUP' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' +#ifndef LANG0 + include 'COMMON.LANGEVIN' +#else + include 'COMMON.LANGEVIN.lang0' +#endif + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.TIME1' + include 'COMMON.MUCA' + double precision vcm(3),incr(3) + double precision cm(3),L(3) + integer ilen,count,rstcount + external ilen + character*50 tytul + integer maxcount_scale /20/ + common /gucio/ cm + double precision stochforcvec(MAXRES6) + common /stochcalc/ stochforcvec + integer itime + logical scale + double precision HNose1,HNose,HNose_nh,H,vtnp(maxres6) + double precision vtnp_(maxres6),vtnp_a(maxres6) +c + scale=.true. + icount_scale=0 + if (lang.eq.1) then + call sddir_precalc + else if (lang.eq.2 .or. lang.eq.3) then +#ifndef LANG0 + call stochastic_force(stochforcvec) +#else + write (iout,*) + & "LANG=2 or 3 NOT SUPPORTED. Recompile without -DLANG0" +#ifdef MPI + call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) +#endif + stop +#endif + endif + itime_scal=0 + do while (scale) + icount_scale=icount_scale+1 + if (icount_scale.gt.maxcount_scale) then + write (iout,*) + & "ERROR: too many attempts at scaling down the time step. ", + & "amax=",amax,"epdrift=",epdrift, + & "damax=",damax,"edriftmax=",edriftmax, + & "d_time=",d_time + call flush(iout) +#ifdef MPI + call MPI_Abort(MPI_COMM_WORLD,IERROR,IERRCODE) +#endif + stop + endif +c First step of the velocity Verlet algorithm + if (lang.eq.2) then +#ifndef LANG0 + call sd_verlet1 +#endif + else if (lang.eq.3) then +#ifndef LANG0 + call sd_verlet1_ciccotti +#endif + else if (lang.eq.1) then + call sddir_verlet1 + else if (tnp1) then + call tnp1_step1 + else if (tnp) then + call tnp_step1 + else + if (tnh) then + call nhcint(EK,scale_nh,wdti,wdti2,wdti4,wdti8) + do i=0,2*nres + do j=1,3 + d_t_old(j,i)=d_t_old(j,i)*scale_nh + enddo + enddo + endif + call verlet1 + endif +c Build the chain from the newly calculated coordinates + call chainbuild_cart + if (rattle) call rattle1 + if (ntwe.ne.0) then + if (large.and. mod(itime,ntwe).eq.0) then + write (iout,*) "Cartesian and internal coordinates: step 1" + call cartprint + call intout + write (iout,*) "dC" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(dc(j,i),j=1,3), + & (dc(j,i+nres),j=1,3) + enddo + write (iout,*) "Accelerations" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), + & (d_a(j,i+nres),j=1,3) + enddo + write (iout,*) "Velocities, step 1" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), + & (d_t(j,i+nres),j=1,3) + enddo + endif + endif +#ifdef MPI + tt0 = MPI_Wtime() +#else + tt0 = tcpu() +#endif +c Calculate energy and forces + call zerograd + call etotal(potEcomp) +#ifdef TIMING_ENE +#ifdef MPI + t_etotal=t_etotal+MPI_Wtime()-tt0 +#else + t_etotal=t_etotal+tcpu()-tt0 +#endif +#endif + E_old=potE + potE=potEcomp(0)-potEcomp(20) + call cartgrad +c Get the new accelerations + call lagrangian +#ifdef MPI + t_enegrad=t_enegrad+MPI_Wtime()-tt0 +#else + t_enegrad=t_enegrad+tcpu()-tt0 +#endif +c Determine maximum acceleration and scale down the timestep if needed + call max_accel + amax=amax/(itime_scal+1)**2 + call predict_edrift(epdrift) + if (amax/(itime_scal+1).gt.damax .or. epdrift.gt.edriftmax) then +c Maximum acceleration or maximum predicted energy drift exceeded, rescale the time step + scale=.true. + ifac_time=dmax1(dlog(amax/damax),dlog(epdrift/edriftmax)) + & /dlog(2.0d0)+1 + itime_scal=itime_scal+ifac_time +c fac_time=dmin1(damax/amax,0.5d0) + fac_time=0.5d0**ifac_time + d_time=d_time*fac_time + if (lang.eq.2 .or. lang.eq.3) then +#ifndef LANG0 +c write (iout,*) "Calling sd_verlet_setup: 1" +c Rescale the stochastic forces and recalculate or restore +c the matrices of tinker integrator + if (itime_scal.gt.maxflag_stoch) then + if (large) write (iout,'(a,i5,a)') + & "Calculate matrices for stochastic step;", + & " itime_scal ",itime_scal + if (lang.eq.2) then + call sd_verlet_p_setup + else + call sd_verlet_ciccotti_setup + endif + write (iout,'(2a,i3,a,i3,1h.)') + & "Warning: cannot store matrices for stochastic", + & " integration because the index",itime_scal, + & " is greater than",maxflag_stoch + write (iout,'(2a)')"Increase MAXFLAG_STOCH or use direct", + & " integration Langevin algorithm for better efficiency." + else if (flag_stoch(itime_scal)) then + if (large) write (iout,'(a,i5,a,l1)') + & "Restore matrices for stochastic step; itime_scal ", + & itime_scal," flag ",flag_stoch(itime_scal) + do i=1,dimen3 + do j=1,dimen3 + pfric_mat(i,j)=pfric0_mat(i,j,itime_scal) + afric_mat(i,j)=afric0_mat(i,j,itime_scal) + vfric_mat(i,j)=vfric0_mat(i,j,itime_scal) + prand_mat(i,j)=prand0_mat(i,j,itime_scal) + vrand_mat1(i,j)=vrand0_mat1(i,j,itime_scal) + vrand_mat2(i,j)=vrand0_mat2(i,j,itime_scal) + enddo + enddo + else + if (large) write (iout,'(2a,i5,a,l1)') + & "Calculate & store matrices for stochastic step;", + & " itime_scal ",itime_scal," flag ",flag_stoch(itime_scal) + if (lang.eq.2) then + call sd_verlet_p_setup + else + call sd_verlet_ciccotti_setup + endif + flag_stoch(ifac_time)=.true. + do i=1,dimen3 + do j=1,dimen3 + pfric0_mat(i,j,itime_scal)=pfric_mat(i,j) + afric0_mat(i,j,itime_scal)=afric_mat(i,j) + vfric0_mat(i,j,itime_scal)=vfric_mat(i,j) + prand0_mat(i,j,itime_scal)=prand_mat(i,j) + vrand0_mat1(i,j,itime_scal)=vrand_mat1(i,j) + vrand0_mat2(i,j,itime_scal)=vrand_mat2(i,j) + enddo + enddo + endif + fac_time=1.0d0/dsqrt(fac_time) + do i=1,dimen3 + stochforcvec(i)=fac_time*stochforcvec(i) + enddo +#endif + else if (lang.eq.1) then +c Rescale the accelerations due to stochastic forces + fac_time=1.0d0/dsqrt(fac_time) + do i=1,dimen3 + d_as_work(i)=d_as_work(i)*fac_time + enddo + endif + if (large) write (iout,'(a,i10,a,f8.6,a,i3,a,i3)') + & "itime",itime," Timestep scaled down to ", + & d_time," ifac_time",ifac_time," itime_scal",itime_scal + else +c Second step of the velocity Verlet algorithm + if (lang.eq.2) then +#ifndef LANG0 + call sd_verlet2 +#endif + else if (lang.eq.3) then +#ifndef LANG0 + call sd_verlet2_ciccotti +#endif + else if (lang.eq.1) then + call sddir_verlet2 + else if (tnp1) then + call tnp1_step2 + else if (tnp) then + call tnp_step2 + else + call verlet2 + if (tnh) then + call kinetic(EK) + call nhcint(EK,scale_nh,wdti,wdti2,wdti4,wdti8) + do i=0,2*nres + do j=1,3 + d_t(j,i)=d_t(j,i)*scale_nh + enddo + enddo + endif + endif + if (rattle) call rattle2 + totT=totT+d_time + if (d_time.ne.d_time0) then + d_time=d_time0 +#ifndef LANG0 + if (lang.eq.2 .or. lang.eq.3) then + if (large) write (iout,'(a)') + & "Restore original matrices for stochastic step" +c write (iout,*) "Calling sd_verlet_setup: 2" +c Restore the matrices of tinker integrator if the time step has been restored + do i=1,dimen3 + do j=1,dimen3 + pfric_mat(i,j)=pfric0_mat(i,j,0) + afric_mat(i,j)=afric0_mat(i,j,0) + vfric_mat(i,j)=vfric0_mat(i,j,0) + prand_mat(i,j)=prand0_mat(i,j,0) + vrand_mat1(i,j)=vrand0_mat1(i,j,0) + vrand_mat2(i,j)=vrand0_mat2(i,j,0) + enddo + enddo + endif +#endif + endif + scale=.false. + endif + enddo +c Calculate the kinetic and the total energy and the kinetic temperature + if (tnp .or. tnp1) then + do i=0,2*nres + do j=1,3 + d_t_old(j,i)=d_t(j,i) + d_t(j,i)=d_t(j,i)/s_np + enddo + enddo + endif + call kinetic(EK) + totE=EK+potE +c diagnostics +c call kinetic1(EK1) +c write (iout,*) "step",itime," EK",EK," EK1",EK1 +c end diagnostics +c Couple the system to Berendsen bath if needed + if (tbf .and. lang.eq.0) then + call verlet_bath + endif + kinetic_T=2.0d0/(dimen3*Rb)*EK +c Backup the coordinates, velocities, and accelerations + do i=0,2*nres + do j=1,3 + dc_old(j,i)=dc(j,i) + if(.not.(tnp .or. tnp1)) d_t_old(j,i)=d_t(j,i) + d_a_old(j,i)=d_a(j,i) + enddo + enddo + if (ntwe.ne.0) then + if (mod(itime,ntwe).eq.0) then + + if(tnp .or. tnp1) then + HNose1=Hnose(EK,s_np,potE,pi_np,Q_np,t_bath,dimen3) + H=(HNose1-H0)*s_np +cd write (iout,'(a,10f)') "hhh",EK,s_np,potE,pi_np,H0 +cd & ,EK+potE+pi_np**2/(2*Q_np)+dimen3*0.001986d0*t_bath*log(s_np) +cd write (iout,*) "HHH H=",H,abs(HNose1-H0)/H0 + hhh=h + endif + + if(tnh) then + HNose1=Hnose_nh(EK,potE) + H=HNose1-H0 + hhh=h +cd write (iout,*) "HHH H=",H,abs(HNose1-H0)/H0 + endif + + if (large) then + itnp=0 + do j=1,3 + itnp=itnp+1 + vtnp(itnp)=d_t(j,0) + enddo + do i=nnt,nct-1 + do j=1,3 + itnp=itnp+1 + vtnp(itnp)=d_t(j,i) + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + inres=i+nres + do j=1,3 + itnp=itnp+1 + vtnp(itnp)=d_t(j,inres) + enddo + endif + enddo + +c Transform velocities from UNRES coordinate space to cartesian and Gvec +c eigenvector space + + do i=1,dimen3 + vtnp_(i)=0.0d0 + vtnp_a(i)=0.0d0 + do j=1,dimen3 + vtnp_(i)=vtnp_(i)+Gvec(j,i)*vtnp(j) + vtnp_a(i)=vtnp_a(i)+A(i,j)*vtnp(j) + enddo + vtnp_(i)=vtnp_(i)*dsqrt(geigen(i)) + enddo + + do i=1,dimen3 + write (iout,'("WWW",i3,3f10.5)') i,vtnp(i),vtnp_(i),vtnp_a(i) + enddo + + write (iout,*) "Velocities, step 2" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), + & (d_t(j,i+nres),j=1,3) + enddo + endif + endif + endif + return + end +c------------------------------------------------------------------------------- + subroutine RESPA_step(itime) +c------------------------------------------------------------------------------- +c Perform a single RESPA step. +c------------------------------------------------------------------------------- + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' + integer IERROR,ERRCODE +#endif + include 'COMMON.SETUP' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' +#ifndef LANG0 + include 'COMMON.LANGEVIN' +#else + include 'COMMON.LANGEVIN.lang0' +#endif + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.TIME1' + double precision energia_short(0:n_ene), + & energia_long(0:n_ene) + double precision cm(3),L(3),vcm(3),incr(3) + double precision dc_old0(3,0:maxres2),d_t_old0(3,0:maxres2), + & d_a_old0(3,0:maxres2) + integer ilen,count,rstcount + external ilen + character*50 tytul + integer maxcount_scale /10/ + common /gucio/ cm,energia_short + double precision stochforcvec(MAXRES6) + common /stochcalc/ stochforcvec + integer itime + logical scale + double precision vtnp(maxres6), vtnp_(maxres6), vtnp_a(maxres6) + common /cipiszcze/ itt + itt=itime + if (ntwe.ne.0) then + if (large.and. mod(itime,ntwe).eq.0) then + write (iout,*) "***************** RESPA itime",itime + write (iout,*) "Cartesian and internal coordinates: step 0" +c call cartprint + call pdbout(0.0d0,"cipiszcze",iout) + call intout + write (iout,*) "Accelerations from long-range forces" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), + & (d_a(j,i+nres),j=1,3) + enddo + write (iout,*) "Velocities, step 0" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), + & (d_t(j,i+nres),j=1,3) + enddo + endif + endif +c +c Perform the initial RESPA step (increment velocities) +c write (iout,*) "*********************** RESPA ini" + if (tnp1) then + call tnp_respa_step1 + else if (tnp) then + call tnp_respa_step1 + else + if (tnh.and..not.xiresp) then + call nhcint(EK,scale_nh,wdti,wdti2,wdti4,wdti8) + do i=0,2*nres + do j=1,3 + d_t(j,i)=d_t(j,i)*scale_nh + enddo + enddo + endif + call RESPA_vel + endif + +cd if(tnp .or. tnp1) then +cd write (iout,'(a,3f)') "EE1 NP S, pi",totT, s_np, pi_np +cd endif + + if (ntwe.ne.0) then + if (mod(itime,ntwe).eq.0 .and. large) then + write (iout,*) "Velocities, end" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), + & (d_t(j,i+nres),j=1,3) + enddo + endif + endif +c Compute the short-range forces +#ifdef MPI + tt0 =MPI_Wtime() +#else + tt0 = tcpu() +#endif +C 7/2/2009 commented out +c call zerograd +c call etotal_short(energia_short) + if (tnp.or.tnp1) potE=energia_short(0) +c call cartgrad +c call lagrangian +C 7/2/2009 Copy accelerations due to short-lange forces from previous MD step + do i=0,2*nres + do j=1,3 + d_a(j,i)=d_a_short(j,i) + enddo + enddo + if (ntwe.ne.0) then + if (large.and. mod(itime,ntwe).eq.0) then + write (iout,*) "energia_short",energia_short(0) + write (iout,*) "Accelerations from short-range forces" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), + & (d_a(j,i+nres),j=1,3) + enddo + endif + endif +#ifdef MPI + t_enegrad=t_enegrad+MPI_Wtime()-tt0 +#else + t_enegrad=t_enegrad+tcpu()-tt0 +#endif + do i=0,2*nres + do j=1,3 + dc_old(j,i)=dc(j,i) + if(.not.(tnp .or. tnp1)) d_t_old(j,i)=d_t(j,i) + d_a_old(j,i)=d_a(j,i) + enddo + enddo +c 6/30/08 A-MTS: attempt at increasing the split number + do i=0,2*nres + do j=1,3 + dc_old0(j,i)=dc_old(j,i) + d_t_old0(j,i)=d_t_old(j,i) + d_a_old0(j,i)=d_a_old(j,i) + enddo + enddo + if (ntime_split.gt.ntime_split0) ntime_split=ntime_split/2 + if (ntime_split.lt.ntime_split0) ntime_split=ntime_split0 +c + scale=.true. + d_time0=d_time + do while (scale) + + scale=.false. +c write (iout,*) "itime",itime," ntime_split",ntime_split +c Split the time step + d_time=d_time0/ntime_split +c Perform the short-range RESPA steps (velocity Verlet increments of +c positions and velocities using short-range forces) +c write (iout,*) "*********************** RESPA split" + do itsplit=1,ntime_split + if (lang.eq.1) then + call sddir_precalc + else if (lang.eq.2 .or. lang.eq.3) then +#ifndef LANG0 + call stochastic_force(stochforcvec) +#else + write (iout,*) + & "LANG=2 or 3 NOT SUPPORTED. Recompile without -DLANG0" +#ifdef MPI + call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) +#endif + stop +#endif + endif +c First step of the velocity Verlet algorithm + if (lang.eq.2) then +#ifndef LANG0 + call sd_verlet1 +#endif + else if (lang.eq.3) then +#ifndef LANG0 + call sd_verlet1_ciccotti +#endif + else if (lang.eq.1) then + call sddir_verlet1 + else if (tnp1) then + call tnp1_respa_i_step1 + else if (tnp) then + call tnp_respa_i_step1 + else + if (tnh.and.xiresp) then + call kinetic(EK) + call nhcint(EK,scale_nh,wdtii,wdtii2,wdtii4,wdtii8) + do i=0,2*nres + do j=1,3 + d_t_old(j,i)=d_t_old(j,i)*scale_nh + enddo + enddo +cd write(iout,*) "SSS1",itsplit,EK,scale_nh + endif + call verlet1 + endif +c Build the chain from the newly calculated coordinates + call chainbuild_cart + if (rattle) call rattle1 + if (ntwe.ne.0) then + if (large.and. mod(itime,ntwe).eq.0) then + write (iout,*) "***** ITSPLIT",itsplit + write (iout,*) "Cartesian and internal coordinates: step 1" + call pdbout(0.0d0,"cipiszcze",iout) +c call cartprint + call intout + write (iout,*) "Velocities, step 1" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), + & (d_t(j,i+nres),j=1,3) + enddo + endif + endif +#ifdef MPI + tt0 = MPI_Wtime() +#else + tt0 = tcpu() +#endif +c Calculate energy and forces + call zerograd + call etotal_short(energia_short) + E_old=potE + potE=energia_short(0) +#ifdef TIMING_ENE +#ifdef MPI + t_eshort=t_eshort+MPI_Wtime()-tt0 +#else + t_eshort=t_eshort+tcpu()-tt0 +#endif +#endif + call cartgrad +c Get the new accelerations + call lagrangian +C 7/2/2009 Copy accelerations due to short-lange forces to an auxiliary array + do i=0,2*nres + do j=1,3 + d_a_short(j,i)=d_a(j,i) + enddo + enddo + if (ntwe.ne.0) then + if (large.and. mod(itime,ntwe).eq.0) then + write (iout,*)"energia_short",energia_short(0) + write (iout,*) "Accelerations from short-range forces" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), + & (d_a(j,i+nres),j=1,3) + enddo + endif + endif +c 6/30/08 A-MTS +c Determine maximum acceleration and scale down the timestep if needed + call max_accel + amax=amax/ntime_split**2 + call predict_edrift(epdrift) + if (ntwe.gt.0 .and. large .and. mod(itime,ntwe).eq.0) + & write (iout,*) "amax",amax," damax",damax, + & " epdrift",epdrift," epdriftmax",epdriftmax +c Exit loop and try with increased split number if the change of +c acceleration is too big + if (amax.gt.damax .or. epdrift.gt.edriftmax) then + if (ntime_split.lt.maxtime_split) then + scale=.true. + ntime_split=ntime_split*2 + do i=0,2*nres + do j=1,3 + dc_old(j,i)=dc_old0(j,i) + d_t_old(j,i)=d_t_old0(j,i) + d_a_old(j,i)=d_a_old0(j,i) + enddo + enddo + write (iout,*) "acceleration/energy drift too large",amax, + & epdrift," split increased to ",ntime_split," itime",itime, + & " itsplit",itsplit + exit + else + write (iout,*) + & "Uh-hu. Bumpy landscape. Maximum splitting number", + & maxtime_split, + & " already reached!!! Trying to carry on!" + endif + endif +#ifdef MPI + t_enegrad=t_enegrad+MPI_Wtime()-tt0 +#else + t_enegrad=t_enegrad+tcpu()-tt0 +#endif +c Second step of the velocity Verlet algorithm + if (lang.eq.2) then +#ifndef LANG0 + call sd_verlet2 +#endif + else if (lang.eq.3) then +#ifndef LANG0 + call sd_verlet2_ciccotti +#endif + else if (lang.eq.1) then + call sddir_verlet2 + else if (tnp1) then + call tnp1_respa_i_step2 + else if (tnp) then + call tnp_respa_i_step2 + else + call verlet2 + if (tnh.and.xiresp) then + call kinetic(EK) + call nhcint(EK,scale_nh,wdtii,wdtii2,wdtii4,wdtii8) + do i=0,2*nres + do j=1,3 + d_t(j,i)=d_t(j,i)*scale_nh + enddo + enddo +cd write(iout,*) "SSS2",itsplit,EK,scale_nh + endif + endif + if (rattle) call rattle2 +c Backup the coordinates, velocities, and accelerations + if (tnp .or. tnp1) then + do i=0,2*nres + do j=1,3 + d_t_old(j,i)=d_t(j,i) + if (tnp) d_t(j,i)=d_t(j,i)/s_np + if (tnp1) d_t(j,i)=d_t(j,i)/s_np + enddo + enddo + endif + + do i=0,2*nres + do j=1,3 + dc_old(j,i)=dc(j,i) + if(.not.(tnp .or. tnp1)) d_t_old(j,i)=d_t(j,i) + d_a_old(j,i)=d_a(j,i) + enddo + enddo + enddo + + enddo ! while scale + +c Restore the time step + d_time=d_time0 +c Compute long-range forces +#ifdef MPI + tt0 =MPI_Wtime() +#else + tt0 = tcpu() +#endif + call zerograd + call etotal_long(energia_long) + E_long=energia_long(0) + potE=energia_short(0)+energia_long(0) +#ifdef TIMING_ENE +#ifdef MPI + t_elong=t_elong+MPI_Wtime()-tt0 +#else + t_elong=t_elong+tcpu()-tt0 +#endif +#endif + call cartgrad + call lagrangian +#ifdef MPI + t_enegrad=t_enegrad+MPI_Wtime()-tt0 +#else + t_enegrad=t_enegrad+tcpu()-tt0 +#endif +c Compute accelerations from long-range forces + if (ntwe.ne.0) then + if (large.and. mod(itime,ntwe).eq.0) then + write (iout,*) "energia_long",energia_long(0) + write (iout,*) "Cartesian and internal coordinates: step 2" +c call cartprint + call pdbout(0.0d0,"cipiszcze",iout) + call intout + write (iout,*) "Accelerations from long-range forces" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), + & (d_a(j,i+nres),j=1,3) + enddo + write (iout,*) "Velocities, step 2" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), + & (d_t(j,i+nres),j=1,3) + enddo + endif + endif +c Compute the final RESPA step (increment velocities) +c write (iout,*) "*********************** RESPA fin" + if (tnp1) then + call tnp_respa_step2 + else if (tnp) then + call tnp_respa_step2 + else + call RESPA_vel + if (tnh.and..not.xiresp) then + call kinetic(EK) + call nhcint(EK,scale_nh,wdti,wdti2,wdti4,wdti8) + do i=0,2*nres + do j=1,3 + d_t(j,i)=d_t(j,i)*scale_nh + enddo + enddo + endif + endif + + if (tnp .or. tnp1) then + do i=0,2*nres + do j=1,3 + d_t(j,i)=d_t_old(j,i)/s_np + enddo + enddo + endif + +c Compute the complete potential energy + do i=0,n_ene + potEcomp(i)=energia_short(i)+energia_long(i) + enddo + potE=potEcomp(0)-potEcomp(20) +c potE=energia_short(0)+energia_long(0) + totT=totT+d_time +c Calculate the kinetic and the total energy and the kinetic temperature + call kinetic(EK) + totE=EK+potE +c Couple the system to Berendsen bath if needed + if (tbf .and. lang.eq.0) then + call verlet_bath + endif + kinetic_T=2.0d0/(dimen3*Rb)*EK +c Backup the coordinates, velocities, and accelerations + if (ntwe.ne.0) then + if (mod(itime,ntwe).eq.0 .and. large) then + write (iout,*) "Velocities, end" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), + & (d_t(j,i+nres),j=1,3) + enddo + endif + + if (mod(itime,ntwe).eq.0) then + + if(tnp .or. tnp1) then +#ifndef G77 + write (iout,'(a3,7f20.10)') "TTT",EK,s_np,potE,pi_np,Csplit, + & E_long,energia_short(0) +#else + write (iout,'(a3,7f20.10)') "TTT",EK,s_np,potE,pi_np,Csplit, + & E_long,energia_short(0) +#endif + HNose1=Hnose(EK,s_np,potE,pi_np,Q_np,t_bath,dimen3) + H=(HNose1-H0)*s_np +cd write (iout,'(a,10f)') "hhh",EK,s_np,potE,pi_np,H0 +cd & ,EK+potE+pi_np**2/(2*Q_np)+dimen3*0.001986d0*t_bath*log(s_np) +cd write (iout,*) "HHH H=",H,abs(HNose1-H0)/H0 + hhh=h +cd write (iout,'(a,3f)') "EE2 NP S, pi",totT, s_np, pi_np + endif + + if(tnh) then + HNose1=Hnose_nh(EK,potE) + H=HNose1-H0 +cd write (iout,*) "HHH H=",H,abs(HNose1-H0)/H0 + hhh=h + endif + + + if (large) then + itnp=0 + do j=1,3 + itnp=itnp+1 + vtnp(itnp)=d_t(j,0) + enddo + do i=nnt,nct-1 + do j=1,3 + itnp=itnp+1 + vtnp(itnp)=d_t(j,i) + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + inres=i+nres + do j=1,3 + itnp=itnp+1 + vtnp(itnp)=d_t(j,inres) + enddo + endif + enddo + +c Transform velocities from UNRES coordinate space to cartesian and Gvec +c eigenvector space + + do i=1,dimen3 + vtnp_(i)=0.0d0 + vtnp_a(i)=0.0d0 + do j=1,dimen3 + vtnp_(i)=vtnp_(i)+Gvec(j,i)*vtnp(j) + vtnp_a(i)=vtnp_a(i)+A(i,j)*vtnp(j) + enddo + vtnp_(i)=vtnp_(i)*dsqrt(geigen(i)) + enddo + + do i=1,dimen3 + write (iout,'("WWW",i3,3f10.5)') i,vtnp(i),vtnp_(i),vtnp_a(i) + enddo + + endif + endif + endif + + + return + end +c--------------------------------------------------------------------- + subroutine RESPA_vel +c First and last RESPA step (incrementing velocities using long-range +c forces). + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + do j=1,3 + d_t(j,0)=d_t(j,0)+0.5d0*d_a(j,0)*d_time + enddo + do i=nnt,nct-1 + do j=1,3 + d_t(j,i)=d_t(j,i)+0.5d0*d_a(j,i)*d_time + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + inres=i+nres + do j=1,3 + d_t(j,inres)=d_t(j,inres)+0.5d0*d_a(j,inres)*d_time + enddo + endif + enddo + return + end +c----------------------------------------------------------------- + subroutine verlet1 +c Applying velocity Verlet algorithm - step 1 to coordinates + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + double precision adt,adt2 + +#ifdef DEBUG + write (iout,*) "VELVERLET1 START: DC" + do i=0,nres + write (iout,'(i3,3f10.5,5x,3f10.5)') i,(dc(j,i),j=1,3), + & (dc(j,i+nres),j=1,3) + enddo +#endif + do j=1,3 + adt=d_a_old(j,0)*d_time + adt2=0.5d0*adt + dc(j,0)=dc_old(j,0)+(d_t_old(j,0)+adt2)*d_time + d_t_new(j,0)=d_t_old(j,0)+adt2 + d_t(j,0)=d_t_old(j,0)+adt + enddo + do i=nnt,nct-1 + do j=1,3 + adt=d_a_old(j,i)*d_time + adt2=0.5d0*adt + dc(j,i)=dc_old(j,i)+(d_t_old(j,i)+adt2)*d_time + d_t_new(j,i)=d_t_old(j,i)+adt2 + d_t(j,i)=d_t_old(j,i)+adt + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + inres=i+nres + do j=1,3 + adt=d_a_old(j,inres)*d_time + adt2=0.5d0*adt + dc(j,inres)=dc_old(j,inres)+(d_t_old(j,inres)+adt2)*d_time + d_t_new(j,inres)=d_t_old(j,inres)+adt2 + d_t(j,inres)=d_t_old(j,inres)+adt + enddo + endif + enddo +#ifdef DEBUG + write (iout,*) "VELVERLET1 END: DC" + do i=0,nres + write (iout,'(i3,3f10.5,5x,3f10.5)') i,(dc(j,i),j=1,3), + & (dc(j,i+nres),j=1,3) + enddo +#endif + return + end +c--------------------------------------------------------------------- + subroutine verlet2 +c Step 2 of the velocity Verlet algorithm: update velocities + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + do j=1,3 + d_t(j,0)=d_t_new(j,0)+0.5d0*d_a(j,0)*d_time + enddo + do i=nnt,nct-1 + do j=1,3 + d_t(j,i)=d_t_new(j,i)+0.5d0*d_a(j,i)*d_time + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + inres=i+nres + do j=1,3 + d_t(j,inres)=d_t_new(j,inres)+0.5d0*d_a(j,inres)*d_time + enddo + endif + enddo + return + end +c----------------------------------------------------------------- + subroutine sddir_precalc +c Applying velocity Verlet algorithm - step 1 to coordinates + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' +#ifndef LANG0 + include 'COMMON.LANGEVIN' +#else + include 'COMMON.LANGEVIN.lang0' +#endif + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.TIME1' + double precision stochforcvec(MAXRES6) + common /stochcalc/ stochforcvec +c +c Compute friction and stochastic forces +c +#ifdef MPI + time00=MPI_Wtime() +#else + time00=tcpu() +#endif + call friction_force +#ifdef MPI + time_fric=time_fric+MPI_Wtime()-time00 + time00=MPI_Wtime() +#else + time_fric=time_fric+tcpu()-time00 + time00=tcpu() +#endif + call stochastic_force(stochforcvec) +#ifdef MPI + time_stoch=time_stoch+MPI_Wtime()-time00 +#else + time_stoch=time_stoch+tcpu()-time00 +#endif +c +c Compute the acceleration due to friction forces (d_af_work) and stochastic +c forces (d_as_work) +c + call ginv_mult(fric_work, d_af_work) + call ginv_mult(stochforcvec, d_as_work) + return + end +c--------------------------------------------------------------------- + subroutine sddir_verlet1 +c Applying velocity Verlet algorithm - step 1 to velocities + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' +#ifndef LANG0 + include 'COMMON.LANGEVIN' +#else + include 'COMMON.LANGEVIN.lang0' +#endif + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' +c Revised 3/31/05 AL: correlation between random contributions to +c position and velocity increments included. + double precision sqrt13 /0.57735026918962576451d0/ ! 1/sqrt(3) + double precision adt,adt2 +c +c Add the contribution from BOTH friction and stochastic force to the +c coordinates, but ONLY the contribution from the friction forces to velocities +c + do j=1,3 + adt=(d_a_old(j,0)+d_af_work(j))*d_time + adt2=0.5d0*adt+sqrt13*d_as_work(j)*d_time + dc(j,0)=dc_old(j,0)+(d_t_old(j,0)+adt2)*d_time + d_t_new(j,0)=d_t_old(j,0)+0.5d0*adt + d_t(j,0)=d_t_old(j,0)+adt + enddo + ind=3 + do i=nnt,nct-1 + do j=1,3 + adt=(d_a_old(j,i)+d_af_work(ind+j))*d_time + adt2=0.5d0*adt+sqrt13*d_as_work(ind+j)*d_time + dc(j,i)=dc_old(j,i)+(d_t_old(j,i)+adt2)*d_time + d_t_new(j,i)=d_t_old(j,i)+0.5d0*adt + d_t(j,i)=d_t_old(j,i)+adt + enddo + ind=ind+3 + enddo + do i=nnt,nct + if (itype(i).ne.10) then + inres=i+nres + do j=1,3 + adt=(d_a_old(j,inres)+d_af_work(ind+j))*d_time + adt2=0.5d0*adt+sqrt13*d_as_work(ind+j)*d_time + dc(j,inres)=dc_old(j,inres)+(d_t_old(j,inres)+adt2)*d_time + d_t_new(j,inres)=d_t_old(j,inres)+0.5d0*adt + d_t(j,inres)=d_t_old(j,inres)+adt + enddo + ind=ind+3 + endif + enddo + return + end +c--------------------------------------------------------------------- + subroutine sddir_verlet2 +c Calculating the adjusted velocities for accelerations + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' +#ifndef LANG0 + include 'COMMON.LANGEVIN' +#else + include 'COMMON.LANGEVIN.lang0' +#endif + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + double precision stochforcvec(MAXRES6),d_as_work1(MAXRES6) + double precision cos60 /0.5d0/, sin60 /0.86602540378443864676d0/ +c Revised 3/31/05 AL: correlation between random contributions to +c position and velocity increments included. +c The correlation coefficients are calculated at low-friction limit. +c Also, friction forces are now not calculated with new velocities. + +c call friction_force + call stochastic_force(stochforcvec) +c +c Compute the acceleration due to friction forces (d_af_work) and stochastic +c forces (d_as_work) +c + call ginv_mult(stochforcvec, d_as_work1) + +c +c Update velocities +c + do j=1,3 + d_t(j,0)=d_t_new(j,0)+(0.5d0*(d_a(j,0)+d_af_work(j)) + & +sin60*d_as_work(j)+cos60*d_as_work1(j))*d_time + enddo + ind=3 + do i=nnt,nct-1 + do j=1,3 + d_t(j,i)=d_t_new(j,i)+(0.5d0*(d_a(j,i)+d_af_work(ind+j)) + & +sin60*d_as_work(ind+j)+cos60*d_as_work1(ind+j))*d_time + enddo + ind=ind+3 + enddo + do i=nnt,nct + if (itype(i).ne.10) then + inres=i+nres + do j=1,3 + d_t(j,inres)=d_t_new(j,inres)+(0.5d0*(d_a(j,inres) + & +d_af_work(ind+j))+sin60*d_as_work(ind+j) + & +cos60*d_as_work1(ind+j))*d_time + enddo + ind=ind+3 + endif + enddo + return + end +c--------------------------------------------------------------------- + subroutine max_accel +c +c Find the maximum difference in the accelerations of the the sites +c at the beginning and the end of the time step. +c + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + double precision aux(3),accel(3),accel_old(3),dacc + do j=1,3 +c aux(j)=d_a(j,0)-d_a_old(j,0) + accel_old(j)=d_a_old(j,0) + accel(j)=d_a(j,0) + enddo + amax=0.0d0 + do i=nnt,nct +c Backbone + if (i.lt.nct) then +c 7/3/08 changed to asymmetric difference + do j=1,3 +c accel(j)=aux(j)+0.5d0*(d_a(j,i)-d_a_old(j,i)) + accel_old(j)=accel_old(j)+0.5d0*d_a_old(j,i) + accel(j)=accel(j)+0.5d0*d_a(j,i) +c if (dabs(accel(j)).gt.amax) amax=dabs(accel(j)) + if (dabs(accel(j)).gt.dabs(accel_old(j))) then + dacc=dabs(accel(j)-accel_old(j)) + if (dacc.gt.amax) amax=dacc + endif + enddo + endif + enddo +c Side chains + do j=1,3 +c accel(j)=aux(j) + accel_old(j)=d_a_old(j,0) + accel(j)=d_a(j,0) + enddo + if (nnt.eq.2) then + do j=1,3 + accel_old(j)=accel_old(j)+d_a_old(j,1) + accel(j)=accel(j)+d_a(j,1) + enddo + endif + do i=nnt,nct + if (itype(i).ne.10) then + do j=1,3 +c accel(j)=accel(j)+d_a(j,i+nres)-d_a_old(j,i+nres) + accel_old(j)=accel_old(j)+d_a_old(j,i+nres) + accel(j)=accel(j)+d_a(j,i+nres) + enddo + endif + do j=1,3 +c if (dabs(accel(j)).gt.amax) amax=dabs(accel(j)) + if (dabs(accel(j)).gt.dabs(accel_old(j))) then + dacc=dabs(accel(j)-accel_old(j)) + if (dacc.gt.amax) amax=dacc + endif + enddo + do j=1,3 + accel_old(j)=accel_old(j)+d_a_old(j,i) + accel(j)=accel(j)+d_a(j,i) +c aux(j)=aux(j)+d_a(j,i)-d_a_old(j,i) + enddo + enddo + return + end +c--------------------------------------------------------------------- + subroutine predict_edrift(epdrift) +c +c Predict the drift of the potential energy +c + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.MUCA' + double precision epdrift,epdriftij +c Drift of the potential energy + epdrift=0.0d0 + do i=nnt,nct +c Backbone + if (i.lt.nct) then + do j=1,3 + epdriftij=dabs((d_a(j,i)-d_a_old(j,i))*gcart(j,i)) + if (lmuca) epdriftij=epdriftij*factor +c write (iout,*) "back",i,j,epdriftij + if (epdriftij.gt.epdrift) epdrift=epdriftij + enddo + endif +c Side chains + if (itype(i).ne.10) then + do j=1,3 + epdriftij= + & dabs((d_a(j,i+nres)-d_a_old(j,i+nres))*gxcart(j,i)) + if (lmuca) epdriftij=epdriftij*factor +c write (iout,*) "side",i,j,epdriftij + if (epdriftij.gt.epdrift) epdrift=epdriftij + enddo + endif + enddo + epdrift=0.5d0*epdrift*d_time*d_time +c write (iout,*) "epdrift",epdrift + return + end +c----------------------------------------------------------------------- + subroutine verlet_bath +c +c Coupling to the thermostat by using the Berendsen algorithm +c + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + double precision T_half,fact +c + T_half=2.0d0/(dimen3*Rb)*EK + fact=dsqrt(1.0d0+(d_time/tau_bath)*(t_bath/T_half-1.0d0)) +c write(iout,*) "T_half", T_half +c write(iout,*) "EK", EK +c write(iout,*) "fact", fact + do j=1,3 + d_t(j,0)=fact*d_t(j,0) + enddo + do i=nnt,nct-1 + do j=1,3 + d_t(j,i)=fact*d_t(j,i) + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + inres=i+nres + do j=1,3 + d_t(j,inres)=fact*d_t(j,inres) + enddo + endif + enddo + return + end +c--------------------------------------------------------- + subroutine init_MD +c Set up the initial conditions of a MD simulation + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MP + include 'mpif.h' + character*16 form + integer IERROR,ERRCODE +#endif + include 'COMMON.SETUP' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' +#ifndef LANG0 + include 'COMMON.LANGEVIN' +#else + include 'COMMON.LANGEVIN.lang0' +#endif + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.REMD' + real*8 energia_long(0:n_ene), + & energia_short(0:n_ene),vcm(3),incr(3),E_short + double precision cm(3),L(3),xv,sigv,lowb,highb + double precision varia(maxvar) + character*256 qstr + integer ilen + external ilen + character*50 tytul + logical file_exist + common /gucio/ cm + d_time0=d_time +c write(iout,*) "d_time", d_time +c Compute the standard deviations of stochastic forces for Langevin dynamics +c if the friction coefficients do not depend on surface area + if (lang.gt.0 .and. .not.surfarea) then + do i=nnt,nct-1 + stdforcp(i)=stdfp*dsqrt(gamp) + enddo + do i=nnt,nct + stdforcsc(i)=stdfsc(itype(i))*dsqrt(gamsc(itype(i))) + enddo + endif +c Open the pdb file for snapshotshots +#ifdef MPI + if(mdpdb) then + if (ilen(tmpdir).gt.0) + & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD"// + & liczba(:ilen(liczba))//".pdb") + open(ipdb, + & file=prefix(:ilen(prefix))//"_MD"//liczba(:ilen(liczba)) + & //".pdb") + else +#ifdef NOXDR + if (ilen(tmpdir).gt.0 .and. (me.eq.king .or. .not.traj1file)) + & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD"// + & liczba(:ilen(liczba))//".x") + cartname=prefix(:ilen(prefix))//"_MD"//liczba(:ilen(liczba)) + & //".x" +#else + if (ilen(tmpdir).gt.0 .and. (me.eq.king .or. .not.traj1file)) + & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD"// + & liczba(:ilen(liczba))//".cx") + cartname=prefix(:ilen(prefix))//"_MD"//liczba(:ilen(liczba)) + & //".cx" +#endif + endif +#else + if(mdpdb) then + if (ilen(tmpdir).gt.0) + & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD.pdb") + open(ipdb,file=prefix(:ilen(prefix))//"_MD.pdb") + else + if (ilen(tmpdir).gt.0) + & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_MD.cx") + cartname=prefix(:ilen(prefix))//"_MD.cx" + endif +#endif + if (usampl) then + write (qstr,'(256(1h ))') + ipos=1 + do i=1,nfrag + iq = qinfrag(i,iset)*10 + iw = wfrag(i,iset)/100 + if (iw.gt.0) then + if(me.eq.king.or..not.out1file) + & write (iout,*) "Frag",qinfrag(i,iset),wfrag(i,iset),iq,iw + write (qstr(ipos:ipos+6),'(2h_f,i1,1h_,i1,1h_,i1)') i,iq,iw + ipos=ipos+7 + endif + enddo + do i=1,npair + iq = qinpair(i,iset)*10 + iw = wpair(i,iset)/100 + if (iw.gt.0) then + if(me.eq.king.or..not.out1file) + & write (iout,*) "Pair",i,qinpair(i,iset),wpair(i,iset),iq,iw + write (qstr(ipos:ipos+6),'(2h_p,i1,1h_,i1,1h_,i1)') i,iq,iw + ipos=ipos+7 + endif + enddo +c pdbname=pdbname(:ilen(pdbname)-4)//qstr(:ipos-1)//'.pdb' +#ifdef NOXDR +c cartname=cartname(:ilen(cartname)-2)//qstr(:ipos-1)//'.x' +#else +c cartname=cartname(:ilen(cartname)-3)//qstr(:ipos-1)//'.cx' +#endif +c statname=statname(:ilen(statname)-5)//qstr(:ipos-1)//'.stat' + endif + icg=1 + if (rest) then + if (restart1file) then + if (me.eq.king) + & inquire(file=mremd_rst_name,exist=file_exist) + write (*,*) me," Before broadcast: file_exist",file_exist +#ifdef MPI + call MPI_Bcast(file_exist,1,MPI_LOGICAL,king,CG_COMM, + & IERR) + write (*,*) me," After broadcast: file_exist",file_exist +#endif +c inquire(file=mremd_rst_name,exist=file_exist) + if(me.eq.king.or..not.out1file) + & write(iout,*) "Initial state read by master and distributed" + else + if (ilen(tmpdir).gt.0) + & call copy_to_tmp(pref_orig(:ilen(pref_orig))//'_' + & //liczba(:ilen(liczba))//'.rst') + inquire(file=rest2name,exist=file_exist) + endif + if(file_exist) then + if(.not.restart1file) then + if(me.eq.king.or..not.out1file) + & write(iout,*) "Initial state will be read from file ", + & rest2name(:ilen(rest2name)) + call readrst + endif + call rescale_weights(t_bath) + else + if(me.eq.king.or..not.out1file)then + if (restart1file) then + write(iout,*) "File ",mremd_rst_name(:ilen(mremd_rst_name)), + & " does not exist" + else + write(iout,*) "File ",rest2name(:ilen(rest2name)), + & " does not exist" + endif + write(iout,*) "Initial velocities randomly generated" + endif + call random_vel + totT=0.0d0 + endif + else +c Generate initial velocities + if(me.eq.king.or..not.out1file) + & write(iout,*) "Initial velocities randomly generated" + call random_vel + totT=0.0d0 + endif +c rest2name = prefix(:ilen(prefix))//'.rst' + if(me.eq.king.or..not.out1file)then + write (iout,*) "Initial velocities" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), + & (d_t(j,i+nres),j=1,3) + enddo + call flush(iout) +c Zeroing the total angular momentum of the system + write(iout,*) "Calling the zero-angular + & momentum subroutine" + endif + call inertia_tensor +c Getting the potential energy and forces and velocities and accelerations + call vcm_vel(vcm) +c write (iout,*) "velocity of the center of the mass:" +c write (iout,*) (vcm(j),j=1,3) + do j=1,3 + d_t(j,0)=d_t(j,0)-vcm(j) + enddo +c Removing the velocity of the center of mass + call vcm_vel(vcm) + if(me.eq.king.or..not.out1file)then + write (iout,*) "vcm right after adjustment:" + write (iout,*) (vcm(j),j=1,3) + call flush(iout) + endif + if (.not.rest) then + call chainbuild + if(iranconf.ne.0) then + if (overlapsc) then + print *, 'Calling OVERLAP_SC' + call overlap_sc(fail) + endif + + if (searchsc) then + call sc_move(2,nres-1,10,1d10,nft_sc,etot) + print *,'SC_move',nft_sc,etot + if(me.eq.king.or..not.out1file) + & write(iout,*) 'SC_move',nft_sc,etot + endif + + if(dccart)then + print *, 'Calling MINIM_DC' + call minim_dc(etot,iretcode,nfun) + else + call geom_to_var(nvar,varia) + print *,'Calling MINIMIZE.' + call minimize(etot,varia,iretcode,nfun) + call var_to_geom(nvar,varia) + endif + if(me.eq.king.or..not.out1file) + & write(iout,*) 'SUMSL return code is',iretcode,' eval ',nfun + endif + endif + call chainbuild_cart + call kinetic(EK) + if (tbf) then + call verlet_bath + endif + kinetic_T=2.0d0/(dimen3*Rb)*EK + if(me.eq.king.or..not.out1file)then + call cartprint + call intout + endif +#ifdef MPI + tt0=MPI_Wtime() +#else + tt0=tcpu() +#endif + call zerograd + call etotal(potEcomp) +#ifdef TIMING_ENE +#ifdef MPI + t_etotal=t_etotal+MPI_Wtime()-tt0 +#else + t_etotal=t_etotal+tcpu()-tt0 +#endif +#endif + potE=potEcomp(0) + + if(tnp .or. tnp1) then + s_np=1.0 + pi_np=0.0 + HNose1=Hnose(EK,s_np,potE,pi_np,Q_np,t_bath,dimen3) + H0=Hnose1 + write(iout,*) 'H0= ',H0 + endif + + if(tnh) then + HNose1=Hnose_nh(EK,potE) + H0=HNose1 + write (iout,*) 'H0= ',H0 + endif + + if (hmc.gt.0) then + hmc_acc=0 + hmc_etot=potE+EK + if(me.eq.king.or..not.out1file) + & write(iout,*) 'HMC',hmc_etot,potE,EK + do i=1,2*nres + do j=1,3 + dc_hmc(j,i)=dc(j,i) + enddo + enddo + endif + + call cartgrad + call lagrangian + call max_accel + if (amax*d_time .gt. dvmax) then + d_time=d_time*dvmax/amax + if(me.eq.king.or..not.out1file) write (iout,*) + & "Time step reduced to",d_time, + & " because of too large initial acceleration." + endif + if(me.eq.king.or..not.out1file)then + write(iout,*) "Potential energy and its components" + call enerprint(potEcomp) +c write(iout,*) (potEcomp(i),i=0,n_ene) + endif + potE=potEcomp(0)-potEcomp(20) + totE=EK+potE + itime=0 + if (ntwe.ne.0) call statout(itime) + if(me.eq.king.or..not.out1file) + & write (iout,'(/a/3(a25,1pe14.5/))') "Initial:", + & " Kinetic energy",EK," potential energy",potE, + & " total energy",totE," maximum acceleration ", + & amax + if (large) then + write (iout,*) "Initial coordinates" + do i=1,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(c(j,i),j=1,3), + & (c(j,i+nres),j=1,3) + enddo + write (iout,*) "Initial dC" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(dc(j,i),j=1,3), + & (dc(j,i+nres),j=1,3) + enddo + write (iout,*) "Initial velocities" + write (iout,"(13x,' backbone ',23x,' side chain')") + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_t(j,i),j=1,3), + & (d_t(j,i+nres),j=1,3) + enddo + write (iout,*) "Initial accelerations" + do i=0,nres +c write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), + write (iout,'(i3,3f15.10,3x,3f15.10)') i,(d_a(j,i),j=1,3), + & (d_a(j,i+nres),j=1,3) + enddo + endif + do i=0,2*nres + do j=1,3 + dc_old(j,i)=dc(j,i) + d_t_old(j,i)=d_t(j,i) + d_a_old(j,i)=d_a(j,i) + enddo +c write (iout,*) "dc_old",i,(dc_old(j,i),j=1,3) + enddo + if (RESPA) then +#ifdef MPI + tt0 =MPI_Wtime() +#else + tt0 = tcpu() +#endif + call zerograd + call etotal_short(energia_short) +#ifdef TIMING_ENE +#ifdef MPI + t_eshort=t_eshort+MPI_Wtime()-tt0 +#else + t_eshort=t_eshort+tcpu()-tt0 +#endif +#endif + + if(tnp .or. tnp1) then + E_short=energia_short(0) + HNose1=Hnose(EK,s_np,E_short,pi_np,Q_np,t_bath,dimen3) + Csplit=Hnose1 +c Csplit =110 +c_new_var_csplit Csplit=H0-E_long +c Csplit = H0-energia_short(0) + write(iout,*) 'Csplit= ',Csplit + endif + + + call cartgrad + call lagrangian + if(.not.out1file .and. large) then + write (iout,*) "energia_long",energia_long(0), + & " energia_short",energia_short(0), + & " total",energia_long(0)+energia_short(0) + write (iout,*) "Initial fast-force accelerations" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), + & (d_a(j,i+nres),j=1,3) + enddo + endif +C 7/2/2009 Copy accelerations due to short-lange forces to an auxiliary array + do i=0,2*nres + do j=1,3 + d_a_short(j,i)=d_a(j,i) + enddo + enddo +#ifdef MPI + tt0=MPI_Wtime() +#else + tt0=tcpu() +#endif + call zerograd + call etotal_long(energia_long) +#ifdef TIMING_ENE +#ifdef MPI + t_elong=t_elong+MPI_Wtime()-tt0 +#else + t_elong=t_elong+tcpu()-tt0 +#endif +#endif + call cartgrad + call lagrangian + if(.not.out1file .and. large) then + write (iout,*) "energia_long",energia_long(0) + write (iout,*) "Initial slow-force accelerations" + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3), + & (d_a(j,i+nres),j=1,3) + enddo + endif +#ifdef MPI + t_enegrad=t_enegrad+MPI_Wtime()-tt0 +#else + t_enegrad=t_enegrad+tcpu()-tt0 +#endif + endif + + + + return + end +c----------------------------------------------------------- + subroutine random_vel + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' +#ifndef LANG0 + include 'COMMON.LANGEVIN' +#else + include 'COMMON.LANGEVIN.lang0' +#endif + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.TIME1' + double precision xv,sigv,lowb,highb +c Generate random velocities from Gaussian distribution of mean 0 and std of KT/m +c First generate velocities in the eigenspace of the G matrix +c write (iout,*) "Calling random_vel dimen dimen3",dimen,dimen3 +c call flush(iout) +c write (iout,*) "RANDOM_VEL dimen",dimen + xv=0.0d0 + ii=0 + do i=1,dimen + do k=1,3 + ii=ii+1 + sigv=dsqrt((Rb*t_bath)/geigen(i)) + lowb=-5*sigv + highb=5*sigv + d_t_work_new(ii)=anorm_distr(xv,sigv,lowb,highb) +c write (iout,*) "i",i," ii",ii," geigen",geigen(i), +c & " d_t_work_new",d_t_work_new(ii) + enddo + enddo + call flush(iout) +c diagnostics +c Ek1=0.0d0 +c ii=0 +c do i=1,dimen +c do k=1,3 +c ii=ii+1 +c Ek1=Ek1+0.5d0*geigen(i)*d_t_work_new(ii)**2 +c enddo +c enddo +c write (iout,*) "Ek from eigenvectors",Ek1 +c end diagnostics +c Transform velocities to UNRES coordinate space + do k=0,2 + do i=1,dimen + ind=(i-1)*3+k+1 + d_t_work(ind)=0.0d0 + do j=1,dimen + d_t_work(ind)=d_t_work(ind) + & +Gvec(i,j)*d_t_work_new((j-1)*3+k+1) + enddo +c write (iout,*) "i",i," ind",ind," d_t_work",d_t_work(ind) +c call flush(iout) + enddo + enddo +c Transfer to the d_t vector + do j=1,3 + d_t(j,0)=d_t_work(j) + enddo + ind=3 + do i=nnt,nct-1 + do j=1,3 + ind=ind+1 + d_t(j,i)=d_t_work(ind) + enddo + enddo +c do i=0,nres-1 +c write (iout,*) "d_t",i,(d_t(j,i),j=1,3) +c enddo +c call flush(iout) + do i=nnt,nct + if (itype(i).ne.10) then + do j=1,3 + ind=ind+1 + d_t(j,i+nres)=d_t_work(ind) + enddo + endif + enddo +c call kinetic(EK) +c write (iout,*) "Kinetic energy",Ek,EK1," kinetic temperature", +c & 2.0d0/(dimen3*Rb)*EK,2.0d0/(dimen3*Rb)*EK1 +c call flush(iout) + return + end +#ifndef LANG0 +c----------------------------------------------------------- + subroutine sd_verlet_p_setup +c Sets up the parameters of stochastic Verlet algorithm + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' +#ifndef LANG0 + include 'COMMON.LANGEVIN' +#else + include 'COMMON.LANGEVIN.lang0' +#endif + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.TIME1' + double precision emgdt(MAXRES6), + & pterm,vterm,rho,rhoc,vsig, + & pfric_vec(MAXRES6),vfric_vec(MAXRES6), + & afric_vec(MAXRES6),prand_vec(MAXRES6), + & vrand_vec1(MAXRES6),vrand_vec2(MAXRES6) + logical lprn /.false./ + double precision zero /1.0d-8/, gdt_radius /0.05d0/ + double precision ktm +#ifdef MPI + tt0 = MPI_Wtime() +#else + tt0 = tcpu() +#endif +c +c AL 8/17/04 Code adapted from tinker +c +c Get the frictional and random terms for stochastic dynamics in the +c eigenspace of mass-scaled UNRES friction matrix +c + do i = 1, dimen + gdt = fricgam(i) * d_time +c +c Stochastic dynamics reduces to simple MD for zero friction +c + if (gdt .le. zero) then + pfric_vec(i) = 1.0d0 + vfric_vec(i) = d_time + afric_vec(i) = 0.5d0 * d_time * d_time + prand_vec(i) = 0.0d0 + vrand_vec1(i) = 0.0d0 + vrand_vec2(i) = 0.0d0 +c +c Analytical expressions when friction coefficient is large +c + else + if (gdt .ge. gdt_radius) then + egdt = dexp(-gdt) + pfric_vec(i) = egdt + vfric_vec(i) = (1.0d0-egdt) / fricgam(i) + afric_vec(i) = (d_time-vfric_vec(i)) / fricgam(i) + pterm = 2.0d0*gdt - 3.0d0 + (4.0d0-egdt)*egdt + vterm = 1.0d0 - egdt**2 + rho = (1.0d0-egdt)**2 / sqrt(pterm*vterm) +c +c Use series expansions when friction coefficient is small +c + else + gdt2 = gdt * gdt + gdt3 = gdt * gdt2 + gdt4 = gdt2 * gdt2 + gdt5 = gdt2 * gdt3 + gdt6 = gdt3 * gdt3 + gdt7 = gdt3 * gdt4 + gdt8 = gdt4 * gdt4 + gdt9 = gdt4 * gdt5 + afric_vec(i) = (gdt2/2.0d0 - gdt3/6.0d0 + gdt4/24.0d0 + & - gdt5/120.0d0 + gdt6/720.0d0 + & - gdt7/5040.0d0 + gdt8/40320.0d0 + & - gdt9/362880.0d0) / fricgam(i)**2 + vfric_vec(i) = d_time - fricgam(i)*afric_vec(i) + pfric_vec(i) = 1.0d0 - fricgam(i)*vfric_vec(i) + pterm = 2.0d0*gdt3/3.0d0 - gdt4/2.0d0 + & + 7.0d0*gdt5/30.0d0 - gdt6/12.0d0 + & + 31.0d0*gdt7/1260.0d0 - gdt8/160.0d0 + & + 127.0d0*gdt9/90720.0d0 + vterm = 2.0d0*gdt - 2.0d0*gdt2 + 4.0d0*gdt3/3.0d0 + & - 2.0d0*gdt4/3.0d0 + 4.0d0*gdt5/15.0d0 + & - 4.0d0*gdt6/45.0d0 + 8.0d0*gdt7/315.0d0 + & - 2.0d0*gdt8/315.0d0 + 4.0d0*gdt9/2835.0d0 + rho = sqrt(3.0d0) * (0.5d0 - 3.0d0*gdt/16.0d0 + & - 17.0d0*gdt2/1280.0d0 + & + 17.0d0*gdt3/6144.0d0 + & + 40967.0d0*gdt4/34406400.0d0 + & - 57203.0d0*gdt5/275251200.0d0 + & - 1429487.0d0*gdt6/13212057600.0d0) + end if +c +c Compute the scaling factors of random terms for the nonzero friction case +c + ktm = 0.5d0*d_time/fricgam(i) + psig = dsqrt(ktm*pterm) / fricgam(i) + vsig = dsqrt(ktm*vterm) + rhoc = dsqrt(1.0d0 - rho*rho) + prand_vec(i) = psig + vrand_vec1(i) = vsig * rho + vrand_vec2(i) = vsig * rhoc + end if + end do + if (lprn) then + write (iout,*) + & "pfric_vec, vfric_vec, afric_vec, prand_vec, vrand_vec1,", + & " vrand_vec2" + do i=1,dimen + write (iout,'(i5,6e15.5)') i,pfric_vec(i),vfric_vec(i), + & afric_vec(i),prand_vec(i),vrand_vec1(i),vrand_vec2(i) + enddo + endif +c +c Transform from the eigenspace of mass-scaled friction matrix to UNRES variables +c +#ifndef LANG0 + call eigtransf(dimen,maxres2,mt3,mt2,pfric_vec,pfric_mat) + call eigtransf(dimen,maxres2,mt3,mt2,vfric_vec,vfric_mat) + call eigtransf(dimen,maxres2,mt3,mt2,afric_vec,afric_mat) + call eigtransf(dimen,maxres2,mt3,mt1,prand_vec,prand_mat) + call eigtransf(dimen,maxres2,mt3,mt1,vrand_vec1,vrand_mat1) + call eigtransf(dimen,maxres2,mt3,mt1,vrand_vec2,vrand_mat2) +#endif +#ifdef MPI + t_sdsetup=t_sdsetup+MPI_Wtime() +#else + t_sdsetup=t_sdsetup+tcpu()-tt0 +#endif + return + end +c------------------------------------------------------------- + subroutine eigtransf1(n,ndim,ab,d,c) + implicit none + integer n,ndim + double precision ab(ndim,ndim,n),c(ndim,n),d(ndim) + integer i,j,k + do i=1,n + do j=1,n + c(i,j)=0.0d0 + do k=1,n + c(i,j)=c(i,j)+ab(k,j,i)*d(k) + enddo + enddo + enddo + return + end +c------------------------------------------------------------- + subroutine eigtransf(n,ndim,a,b,d,c) + implicit none + integer n,ndim + double precision a(ndim,n),b(ndim,n),c(ndim,n),d(ndim) + integer i,j,k + do i=1,n + do j=1,n + c(i,j)=0.0d0 + do k=1,n + c(i,j)=c(i,j)+a(i,k)*b(k,j)*d(k) + enddo + enddo + enddo + return + end +c------------------------------------------------------------- + subroutine sd_verlet1 +c Applying stochastic velocity Verlet algorithm - step 1 to velocities + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' +#ifndef LANG0 + include 'COMMON.LANGEVIN' +#else + include 'COMMON.LANGEVIN.lang0' +#endif + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + double precision stochforcvec(MAXRES6) + common /stochcalc/ stochforcvec + logical lprn /.false./ + +c write (iout,*) "dc_old" +c do i=0,nres +c write (iout,'(i5,3f10.5,5x,3f10.5)') +c & i,(dc_old(j,i),j=1,3),(dc_old(j,i+nres),j=1,3) +c enddo + do j=1,3 + dc_work(j)=dc_old(j,0) + d_t_work(j)=d_t_old(j,0) + d_a_work(j)=d_a_old(j,0) + enddo + ind=3 + do i=nnt,nct-1 + do j=1,3 + dc_work(ind+j)=dc_old(j,i) + d_t_work(ind+j)=d_t_old(j,i) + d_a_work(ind+j)=d_a_old(j,i) + enddo + ind=ind+3 + enddo + do i=nnt,nct + if (itype(i).ne.10) then + do j=1,3 + dc_work(ind+j)=dc_old(j,i+nres) + d_t_work(ind+j)=d_t_old(j,i+nres) + d_a_work(ind+j)=d_a_old(j,i+nres) + enddo + ind=ind+3 + endif + enddo +#ifndef LANG0 + if (lprn) then + write (iout,*) + & "pfric_mat, vfric_mat, afric_mat, prand_mat, vrand_mat1,", + & " vrand_mat2" + do i=1,dimen + do j=1,dimen + write (iout,'(2i5,6e15.5)') i,j,pfric_mat(i,j), + & vfric_mat(i,j),afric_mat(i,j), + & prand_mat(i,j),vrand_mat1(i,j),vrand_mat2(i,j) + enddo + enddo + endif + do i=1,dimen + ddt1=0.0d0 + ddt2=0.0d0 + do j=1,dimen + dc_work(i)=dc_work(i)+vfric_mat(i,j)*d_t_work(j) + & +afric_mat(i,j)*d_a_work(j)+prand_mat(i,j)*stochforcvec(j) + ddt1=ddt1+pfric_mat(i,j)*d_t_work(j) + ddt2=ddt2+vfric_mat(i,j)*d_a_work(j) + enddo + d_t_work_new(i)=ddt1+0.5d0*ddt2 + d_t_work(i)=ddt1+ddt2 + enddo +#endif + do j=1,3 + dc(j,0)=dc_work(j) + d_t(j,0)=d_t_work(j) + enddo + ind=3 + do i=nnt,nct-1 + do j=1,3 + dc(j,i)=dc_work(ind+j) + d_t(j,i)=d_t_work(ind+j) + enddo + ind=ind+3 + enddo + do i=nnt,nct + if (itype(i).ne.10) then + inres=i+nres + do j=1,3 + dc(j,inres)=dc_work(ind+j) + d_t(j,inres)=d_t_work(ind+j) + enddo + ind=ind+3 + endif + enddo + return + end +c-------------------------------------------------------------------------- + subroutine sd_verlet2 +c Calculating the adjusted velocities for accelerations + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' +#ifndef LANG0 + include 'COMMON.LANGEVIN' +#else + include 'COMMON.LANGEVIN.lang0' +#endif + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + double precision stochforcvec(MAXRES6),stochforcvecV(MAXRES6) + common /stochcalc/ stochforcvec +c +c Compute the stochastic forces which contribute to velocity change +c + call stochastic_force(stochforcvecV) + +#ifndef LANG0 + do i=1,dimen + ddt1=0.0d0 + ddt2=0.0d0 + do j=1,dimen + ddt1=ddt1+vfric_mat(i,j)*d_a_work(j) + ddt2=ddt2+vrand_mat1(i,j)*stochforcvec(j)+ + & vrand_mat2(i,j)*stochforcvecV(j) + enddo + d_t_work(i)=d_t_work_new(i)+0.5d0*ddt1+ddt2 + enddo +#endif + do j=1,3 + d_t(j,0)=d_t_work(j) + enddo + ind=3 + do i=nnt,nct-1 + do j=1,3 + d_t(j,i)=d_t_work(ind+j) + enddo + ind=ind+3 + enddo + do i=nnt,nct + if (itype(i).ne.10) then + inres=i+nres + do j=1,3 + d_t(j,inres)=d_t_work(ind+j) + enddo + ind=ind+3 + endif + enddo + return + end +c----------------------------------------------------------- + subroutine sd_verlet_ciccotti_setup +c Sets up the parameters of stochastic velocity Verlet algorithmi; Ciccotti's +c version + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' +#ifndef LANG0 + include 'COMMON.LANGEVIN' +#else + include 'COMMON.LANGEVIN.lang0' +#endif + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.TIME1' + double precision emgdt(MAXRES6), + & pterm,vterm,rho,rhoc,vsig, + & pfric_vec(MAXRES6),vfric_vec(MAXRES6), + & afric_vec(MAXRES6),prand_vec(MAXRES6), + & vrand_vec1(MAXRES6),vrand_vec2(MAXRES6) + logical lprn /.false./ + double precision zero /1.0d-8/, gdt_radius /0.05d0/ + double precision ktm +#ifdef MPI + tt0 = MPI_Wtime() +#else + tt0 = tcpu() +#endif +c +c AL 8/17/04 Code adapted from tinker +c +c Get the frictional and random terms for stochastic dynamics in the +c eigenspace of mass-scaled UNRES friction matrix +c + do i = 1, dimen + write (iout,*) "i",i," fricgam",fricgam(i) + gdt = fricgam(i) * d_time +c +c Stochastic dynamics reduces to simple MD for zero friction +c + if (gdt .le. zero) then + pfric_vec(i) = 1.0d0 + vfric_vec(i) = d_time + afric_vec(i) = 0.5d0*d_time*d_time + prand_vec(i) = afric_vec(i) + vrand_vec2(i) = vfric_vec(i) +c +c Analytical expressions when friction coefficient is large +c + else + egdt = dexp(-gdt) + pfric_vec(i) = egdt + vfric_vec(i) = dexp(-0.5d0*gdt)*d_time + afric_vec(i) = 0.5d0*dexp(-0.25d0*gdt)*d_time*d_time + prand_vec(i) = afric_vec(i) + vrand_vec2(i) = vfric_vec(i) +c +c Compute the scaling factors of random terms for the nonzero friction case +c +c ktm = 0.5d0*d_time/fricgam(i) +c psig = dsqrt(ktm*pterm) / fricgam(i) +c vsig = dsqrt(ktm*vterm) +c prand_vec(i) = psig*afric_vec(i) +c vrand_vec2(i) = vsig*vfric_vec(i) + end if + end do + if (lprn) then + write (iout,*) + & "pfric_vec, vfric_vec, afric_vec, prand_vec, vrand_vec1,", + & " vrand_vec2" + do i=1,dimen + write (iout,'(i5,6e15.5)') i,pfric_vec(i),vfric_vec(i), + & afric_vec(i),prand_vec(i),vrand_vec1(i),vrand_vec2(i) + enddo + endif +c +c Transform from the eigenspace of mass-scaled friction matrix to UNRES variables +c + call eigtransf(dimen,maxres2,mt3,mt2,pfric_vec,pfric_mat) + call eigtransf(dimen,maxres2,mt3,mt2,vfric_vec,vfric_mat) + call eigtransf(dimen,maxres2,mt3,mt2,afric_vec,afric_mat) + call eigtransf(dimen,maxres2,mt3,mt1,prand_vec,prand_mat) + call eigtransf(dimen,maxres2,mt3,mt1,vrand_vec2,vrand_mat2) +#ifdef MPI + t_sdsetup=t_sdsetup+MPI_Wtime() +#else + t_sdsetup=t_sdsetup+tcpu()-tt0 +#endif + return + end +c------------------------------------------------------------- + subroutine sd_verlet1_ciccotti +c Applying stochastic velocity Verlet algorithm - step 1 to velocities + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' +#ifndef LANG0 + include 'COMMON.LANGEVIN' +#else + include 'COMMON.LANGEVIN.lang0' +#endif + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + double precision stochforcvec(MAXRES6) + common /stochcalc/ stochforcvec + logical lprn /.false./ + +c write (iout,*) "dc_old" +c do i=0,nres +c write (iout,'(i5,3f10.5,5x,3f10.5)') +c & i,(dc_old(j,i),j=1,3),(dc_old(j,i+nres),j=1,3) +c enddo + do j=1,3 + dc_work(j)=dc_old(j,0) + d_t_work(j)=d_t_old(j,0) + d_a_work(j)=d_a_old(j,0) + enddo + ind=3 + do i=nnt,nct-1 + do j=1,3 + dc_work(ind+j)=dc_old(j,i) + d_t_work(ind+j)=d_t_old(j,i) + d_a_work(ind+j)=d_a_old(j,i) + enddo + ind=ind+3 + enddo + do i=nnt,nct + if (itype(i).ne.10) then + do j=1,3 + dc_work(ind+j)=dc_old(j,i+nres) + d_t_work(ind+j)=d_t_old(j,i+nres) + d_a_work(ind+j)=d_a_old(j,i+nres) + enddo + ind=ind+3 + endif + enddo + +#ifndef LANG0 + if (lprn) then + write (iout,*) + & "pfric_mat, vfric_mat, afric_mat, prand_mat, vrand_mat1,", + & " vrand_mat2" + do i=1,dimen + do j=1,dimen + write (iout,'(2i5,6e15.5)') i,j,pfric_mat(i,j), + & vfric_mat(i,j),afric_mat(i,j), + & prand_mat(i,j),vrand_mat1(i,j),vrand_mat2(i,j) + enddo + enddo + endif + do i=1,dimen + ddt1=0.0d0 + ddt2=0.0d0 + do j=1,dimen + dc_work(i)=dc_work(i)+vfric_mat(i,j)*d_t_work(j) + & +afric_mat(i,j)*d_a_work(j)+prand_mat(i,j)*stochforcvec(j) + ddt1=ddt1+pfric_mat(i,j)*d_t_work(j) + ddt2=ddt2+vfric_mat(i,j)*d_a_work(j) + enddo + d_t_work_new(i)=ddt1+0.5d0*ddt2 + d_t_work(i)=ddt1+ddt2 + enddo +#endif + do j=1,3 + dc(j,0)=dc_work(j) + d_t(j,0)=d_t_work(j) + enddo + ind=3 + do i=nnt,nct-1 + do j=1,3 + dc(j,i)=dc_work(ind+j) + d_t(j,i)=d_t_work(ind+j) + enddo + ind=ind+3 + enddo + do i=nnt,nct + if (itype(i).ne.10) then + inres=i+nres + do j=1,3 + dc(j,inres)=dc_work(ind+j) + d_t(j,inres)=d_t_work(ind+j) + enddo + ind=ind+3 + endif + enddo + return + end +c-------------------------------------------------------------------------- + subroutine sd_verlet2_ciccotti +c Calculating the adjusted velocities for accelerations + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' +#ifndef LANG0 + include 'COMMON.LANGEVIN' +#else + include 'COMMON.LANGEVIN.lang0' +#endif + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + double precision stochforcvec(MAXRES6),stochforcvecV(MAXRES6) + common /stochcalc/ stochforcvec +c +c Compute the stochastic forces which contribute to velocity change +c + call stochastic_force(stochforcvecV) +#ifndef LANG0 + do i=1,dimen + ddt1=0.0d0 + ddt2=0.0d0 + do j=1,dimen + + ddt1=ddt1+vfric_mat(i,j)*d_a_work(j) +c ddt2=ddt2+vrand_mat2(i,j)*stochforcvecV(j) + ddt2=ddt2+vrand_mat2(i,j)*stochforcvec(j) + enddo + d_t_work(i)=d_t_work_new(i)+0.5d0*ddt1+ddt2 + enddo +#endif + do j=1,3 + d_t(j,0)=d_t_work(j) + enddo + ind=3 + do i=nnt,nct-1 + do j=1,3 + d_t(j,i)=d_t_work(ind+j) + enddo + ind=ind+3 + enddo + do i=nnt,nct + if (itype(i).ne.10) then + inres=i+nres + do j=1,3 + d_t(j,inres)=d_t_work(ind+j) + enddo + ind=ind+3 + endif + enddo + return + end +#endif +c------------------------------------------------------ + double precision function HNose(ek,s,e,pi,Q,t_bath,dimenl) + implicit none + double precision ek,s,e,pi,Q,t_bath,Rb + integer dimenl + Rb=0.001986d0 + HNose=ek+e+pi**2/(2*Q)+dimenl*Rb*t_bath*log(s) +c print '(6f15.5,i5,a2,2f15.5)',ek,s,e,pi,Q,t_bath,dimenl,"--", +c & pi**2/(2*Q),dimenl*Rb*t_bath*log(s) + return + end +c----------------------------------------------------------------- + double precision function HNose_nh(eki,e) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.MD' + HNose_nh=eki+e+dimen3*Rb*t_bath*xlogs(1)+qmass(1)*vlogs(1)**2/2 + do i=2,nnos + HNose_nh=HNose_nh+qmass(i)*vlogs(i)**2/2+Rb*t_bath*xlogs(i) + enddo +c write(4,'(5e15.5)') +c & vlogs(1),xlogs(1),HNose,eki,e + return + end +c----------------------------------------------------------------- + SUBROUTINE NHCINT(akin,scale,wdti,wdti2,wdti4,wdti8) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.MD' + double precision akin,gnkt,dt,aa,gkt,scale + double precision wdti(maxyosh),wdti2(maxyosh), + & wdti4(maxyosh),wdti8(maxyosh) + integer i,iresn,iyosh,inos,nnos1 + + dt=d_time + nnos1=nnos+1 + GKT = Rb*t_bath + GNKT = dimen3*GKT + akin=akin*2 + + +C THIS ROUTINE DOES THE NOSE-HOOVER PART OF THE +C INTEGRATION FROM t=0 TO t=DT/2 +C GET THE TOTAL KINETIC ENERGY + SCALE = 1.D0 +c CALL GETKINP(MASS,VX,VY,VZ,AKIN) +C UPDATE THE FORCES + GLOGS(1) = (AKIN - GNKT)/QMASS(1) +C START THE MULTIPLE TIME STEP PROCEDURE + DO IRESN = 1,NRESN + DO IYOSH = 1,NYOSH +C UPDATE THE THERMOSTAT VELOCITIES + VLOGS(NNOS) = VLOGS(NNOS) + GLOGS(NNOS)*WDTI4(IYOSH) + DO INOS = 1,NNOS-1 + AA = EXP(-WDTI8(IYOSH)*VLOGS(NNOS1-INOS) ) + VLOGS(NNOS-INOS) = VLOGS(NNOS-INOS)*AA*AA + & + WDTI4(IYOSH)*GLOGS(NNOS-INOS)*AA + ENDDO +C UPDATE THE PARTICLE VELOCITIES + AA = EXP(-WDTI2(IYOSH)*VLOGS(1) ) + SCALE = SCALE*AA +C UPDATE THE FORCES + GLOGS(1) = (SCALE*SCALE*AKIN - GNKT)/QMASS(1) +C UPDATE THE THERMOSTAT POSITIONS + DO INOS = 1,NNOS + XLOGS(INOS) = XLOGS(INOS) + VLOGS(INOS)*WDTI2(IYOSH) + ENDDO +C UPDATE THE THERMOSTAT VELOCITIES + DO INOS = 1,NNOS-1 + AA = EXP(-WDTI8(IYOSH)*VLOGS(INOS+1) ) + VLOGS(INOS) = VLOGS(INOS)*AA*AA + & + WDTI4(IYOSH)*GLOGS(INOS)*AA + GLOGS(INOS+1) = (QMASS(INOS)*VLOGS(INOS)*VLOGS(INOS) + & -GKT)/QMASS(INOS+1) + ENDDO + VLOGS(NNOS) = VLOGS(NNOS) + GLOGS(NNOS)*WDTI4(IYOSH) + ENDDO + ENDDO +C UPDATE THE PARTICLE VELOCITIES +c outside of this subroutine +c DO I = 1,N +c VX(I) = VX(I)*SCALE +c VY(I) = VY(I)*SCALE +c VZ(I) = VZ(I)*SCALE +c ENDDO + RETURN + END +c----------------------------------------------------------------- + subroutine tnp1_respa_i_step1 +c Applying Nose-Poincare algorithm - step 1 to coordinates +c JPSJ 70 75 (2001) S. Nose +c +c d_t is not updated here +c + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + double precision adt,adt2,tmp + + tmp=1+pi_np/(2*Q_np)*0.5*d_time + s12_np=s_np*tmp**2 + pistar=pi_np/tmp + s12_dt=d_time/s12_np + d_time_s12=d_time*0.5*s12_np + + do j=1,3 + d_t_new(j,0)=d_t_old(j,0)+d_a_old(j,0)*d_time_s12 + dc(j,0)=dc_old(j,0)+d_t_new(j,0)*s12_dt + enddo + do i=nnt,nct-1 + do j=1,3 + d_t_new(j,i)=d_t_old(j,i)+d_a_old(j,i)*d_time_s12 + dc(j,i)=dc_old(j,i)+d_t_new(j,i)*s12_dt + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + inres=i+nres + do j=1,3 + d_t_new(j,inres)=d_t_old(j,inres)+d_a_old(j,inres)*d_time_s12 + dc(j,inres)=dc_old(j,inres)+d_t_new(j,inres)*s12_dt + enddo + endif + enddo + return + end +c--------------------------------------------------------------------- + subroutine tnp1_respa_i_step2 +c Step 2 of the velocity Verlet algorithm: update velocities + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + + double precision d_time_s12 + + do i=0,2*nres + do j=1,3 + d_t(j,i)=d_t_new(j,i) + enddo + enddo + + call kinetic(EK) + EK=EK/s12_np**2 + + d_time_s12=0.5d0*s12_np*d_time + + do j=1,3 + d_t(j,0)=d_t_new(j,0)+d_a(j,0)*d_time_s12 + enddo + do i=nnt,nct-1 + do j=1,3 + d_t(j,i)=d_t_new(j,i)+d_a(j,i)*d_time_s12 + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + inres=i+nres + do j=1,3 + d_t(j,inres)=d_t_new(j,inres)+d_a(j,inres)*d_time_s12 + enddo + endif + enddo + + pistar=pistar+(EK-0.5*(E_old+potE) + & -dimen3*Rb*t_bath*log(s12_np)+Csplit-dimen3*Rb*t_bath)*d_time + tmp=1+pistar/(2*Q_np)*0.5*d_time + s_np=s12_np*tmp**2 + pi_np=pistar/tmp + + return + end +c------------------------------------------------------- + + subroutine tnp1_step1 +c Applying Nose-Poincare algorithm - step 1 to coordinates +c JPSJ 70 75 (2001) S. Nose +c +c d_t is not updated here +c + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + double precision adt,adt2,tmp + + tmp=1+pi_np/(2*Q_np)*0.5*d_time + s12_np=s_np*tmp**2 + pistar=pi_np/tmp + s12_dt=d_time/s12_np + d_time_s12=d_time*0.5*s12_np + + do j=1,3 + d_t_new(j,0)=d_t_old(j,0)+d_a_old(j,0)*d_time_s12 + dc(j,0)=dc_old(j,0)+d_t_new(j,0)*s12_dt + enddo + do i=nnt,nct-1 + do j=1,3 + d_t_new(j,i)=d_t_old(j,i)+d_a_old(j,i)*d_time_s12 + dc(j,i)=dc_old(j,i)+d_t_new(j,i)*s12_dt + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + inres=i+nres + do j=1,3 + d_t_new(j,inres)=d_t_old(j,inres)+d_a_old(j,inres)*d_time_s12 + dc(j,inres)=dc_old(j,inres)+d_t_new(j,inres)*s12_dt + enddo + endif + enddo + return + end +c--------------------------------------------------------------------- + subroutine tnp1_step2 +c Step 2 of the velocity Verlet algorithm: update velocities + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + + double precision d_time_s12 + + do i=0,2*nres + do j=1,3 + d_t(j,i)=d_t_new(j,i) + enddo + enddo + + call kinetic(EK) + EK=EK/s12_np**2 + + d_time_s12=0.5d0*s12_np*d_time + + do j=1,3 + d_t(j,0)=d_t_new(j,0)+d_a(j,0)*d_time_s12 + enddo + do i=nnt,nct-1 + do j=1,3 + d_t(j,i)=d_t_new(j,i)+d_a(j,i)*d_time_s12 + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + inres=i+nres + do j=1,3 + d_t(j,inres)=d_t_new(j,inres)+d_a(j,inres)*d_time_s12 + enddo + endif + enddo + +cd write(iout,*) 'pistar',pistar,EK,E_old,potE,s12_np + pistar=pistar+(EK-0.5*(E_old+potE) + & -dimen3*Rb*t_bath*log(s12_np)+H0-dimen3*Rb*t_bath)*d_time + tmp=1+pistar/(2*Q_np)*0.5*d_time + s_np=s12_np*tmp**2 + pi_np=pistar/tmp + + return + end + +c----------------------------------------------------------------- + subroutine tnp_respa_i_step1 +c Applying Nose-Poincare algorithm - step 1 to coordinates +c J.Comput.Phys. 151 114 (1999) S.D.Bond B.J.Leimkuhler B.B.Laird +c +c d_t is not updated here, it is destroyed +c + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + double precision C_np,d_time_s,tmp,d_time_ss + + d_time_s=d_time*0.5*s_np +ct2 d_time_s=d_time*0.5*s12_np + + do j=1,3 + d_t_new(j,0)=d_t_old(j,0)+d_a_old(j,0)*d_time_s + enddo + do i=nnt,nct-1 + do j=1,3 + d_t_new(j,i)=d_t_old(j,i)+d_a_old(j,i)*d_time_s + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + inres=i+nres + do j=1,3 + d_t_new(j,inres)=d_t_old(j,inres)+d_a_old(j,inres)*d_time_s + enddo + endif + enddo + + do i=0,2*nres + do j=1,3 + d_t(j,i)=d_t_new(j,i) + enddo + enddo + + call kinetic(EK) + EK=EK/s_np**2 + + C_np=0.5*d_time*(dimen3*Rb*t_bath*(1.0+log(s_np))-EK+potE-Csplit) + & -pi_np + + pistar=-2.0*C_np/(1.0+sqrt(1.0-C_np*d_time/Q_np)) + tmp=0.5*d_time*pistar/Q_np + s12_np=s_np*(1.0+tmp)/(1.0-tmp) + + d_time_ss=0.5*d_time*(1.0/s12_np+1.0/s_np) +ct2 d_time_ss=d_time/s12_np +c d_time_ss=0.5*d_time*(1.0/sold_np+1.0/s_np) + + do j=1,3 + dc(j,0)=dc_old(j,0)+d_t_new(j,0)*d_time_ss + enddo + do i=nnt,nct-1 + do j=1,3 + dc(j,i)=dc_old(j,i)+d_t_new(j,i)*d_time_ss + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + inres=i+nres + do j=1,3 + dc(j,inres)=dc_old(j,inres)+d_t_new(j,inres)*d_time_ss + enddo + endif + enddo + + return + end +c--------------------------------------------------------------------- + + subroutine tnp_respa_i_step2 +c Step 2 of the velocity Verlet algorithm: update velocities + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + + double precision d_time_s + + EK=EK*(s_np/s12_np)**2 + HNose1=Hnose(EK,s12_np,potE,pistar,Q_np,t_bath,dimen3) + pi_np=pistar+0.5*d_time*(2*EK-dimen3*Rb*t_bath + & -HNose1+Csplit) + +cr print '(a,5f)','i_step2',EK,potE,HNose1,pi_np,E_long + d_time_s=d_time*0.5*s12_np +c d_time_s=d_time*0.5*s_np + + do j=1,3 + d_t(j,0)=d_t_new(j,0)+d_a(j,0)*d_time_s + enddo + do i=nnt,nct-1 + do j=1,3 + d_t(j,i)=d_t_new(j,i)+d_a(j,i)*d_time_s + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + inres=i+nres + do j=1,3 + d_t(j,inres)=d_t_new(j,inres)+d_a(j,inres)*d_time_s + enddo + endif + enddo + + s_np=s12_np + + return + end +c----------------------------------------------------------------- + subroutine tnp_respa_step1 +c Applying Nose-Poincare algorithm - step 1 to vel for RESPA +c J.Comput.Phys. 151 114 (1999) S.D.Bond B.J.Leimkuhler B.B.Laird +c +c d_t is not updated here, it is destroyed +c + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + double precision C_np,d_time_s,tmp,d_time_ss + double precision energia(0:n_ene) + + d_time_s=d_time*0.5*s_np + + do j=1,3 + d_t_old(j,0)=d_t_old(j,0)+d_a(j,0)*d_time_s + enddo + do i=nnt,nct-1 + do j=1,3 + d_t_old(j,i)=d_t_old(j,i)+d_a(j,i)*d_time_s + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + inres=i+nres + do j=1,3 + d_t_old(j,inres)=d_t_old(j,inres)+d_a(j,inres)*d_time_s + enddo + endif + enddo + + +c C_np=0.5*d_time*(dimen3*Rb*t_bath*(1.0+log(s_np))-EK+potE-H0) +c & -pi_np +c +c pistar=-2.0*C_np/(1.0+sqrt(1.0-C_np*d_time/Q_np)) +c tmp=0.5*d_time*pistar/Q_np +c s12_np=s_np*(1.0+tmp)/(1.0-tmp) +c write(iout,*) 'tnp_respa_step1',s_np,s12_np,EK,potE,C_np,pistar,tmp + +ct1 pi_np=pistar +c sold_np=s_np +c s_np=s12_np + +c------------------------------------- +c test of reviewer's comment + pi_np=pi_np-0.5*d_time*(E_long+Csplit-H0) +cr print '(a,3f)','1 pi_np,s_np',pi_np,s_np,E_long +c------------------------------------- + + return + end +c--------------------------------------------------------------------- + subroutine tnp_respa_step2 +c Step 2 of the velocity Verlet algorithm: update velocities for RESPA + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + + double precision d_time_s + +ct1 s12_np=s_np +ct2 pistar=pi_np + +ct call kinetic(EK) +ct HNose1=Hnose(EK,s12_np,potE,pistar,Q_np,t_bath,dimen3) +ct pi_np=pistar+0.5*d_time*(2*EK-dimen3*Rb*t_bath) +ct & -0.5*d_time*(HNose1-H0) + +c------------------------------------- +c test of reviewer's comment + pi_np=pi_np-0.5*d_time*(E_long+Csplit-H0) +cr print '(a,3f)','2 pi_np,s_np',pi_np,s_np,E_long +c------------------------------------- + d_time_s=d_time*0.5*s_np + + do j=1,3 + d_t_old(j,0)=d_t_old(j,0)+d_a(j,0)*d_time_s + enddo + do i=nnt,nct-1 + do j=1,3 + d_t_old(j,i)=d_t_old(j,i)+d_a(j,i)*d_time_s + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + inres=i+nres + do j=1,3 + d_t_old(j,inres)=d_t_old(j,inres)+d_a(j,inres)*d_time_s + enddo + endif + enddo + +cd s_np=s12_np + + return + end +c--------------------------------------------------------------------- + subroutine tnp_step1 +c Applying Nose-Poincare algorithm - step 1 to coordinates +c J.Comput.Phys. 151 114 (1999) S.D.Bond B.J.Leimkuhler B.B.Laird +c +c d_t is not updated here, it is destroyed +c + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + double precision C_np,d_time_s,tmp,d_time_ss + + d_time_s=d_time*0.5*s_np + + do j=1,3 + d_t_new(j,0)=d_t_old(j,0)+d_a_old(j,0)*d_time_s + enddo + do i=nnt,nct-1 + do j=1,3 + d_t_new(j,i)=d_t_old(j,i)+d_a_old(j,i)*d_time_s + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + inres=i+nres + do j=1,3 + d_t_new(j,inres)=d_t_old(j,inres)+d_a_old(j,inres)*d_time_s + enddo + endif + enddo + + do i=0,2*nres + do j=1,3 + d_t(j,i)=d_t_new(j,i) + enddo + enddo + + call kinetic(EK) + EK=EK/s_np**2 + + C_np=0.5*d_time*(dimen3*Rb*t_bath*(1.0+log(s_np))-EK+potE-H0) + & -pi_np + + pistar=-2.0*C_np/(1.0+sqrt(1.0-C_np*d_time/Q_np)) + tmp=0.5*d_time*pistar/Q_np + s12_np=s_np*(1.0+tmp)/(1.0-tmp) +c write(iout,*) 'tnp_step1',s_np,s12_np,EK,potE,C_np,pistar,tmp + + d_time_ss=0.5*d_time*(1.0/s12_np+1.0/s_np) + + do j=1,3 + dc(j,0)=dc_old(j,0)+d_t_new(j,0)*d_time_ss + enddo + do i=nnt,nct-1 + do j=1,3 + dc(j,i)=dc_old(j,i)+d_t_new(j,i)*d_time_ss + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + inres=i+nres + do j=1,3 + dc(j,inres)=dc_old(j,inres)+d_t_new(j,inres)*d_time_ss + enddo + endif + enddo + + return + end +c----------------------------------------------------------------- + subroutine tnp_step2 +c Step 2 of the velocity Verlet algorithm: update velocities + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + + double precision d_time_s + + EK=EK*(s_np/s12_np)**2 + HNose1=Hnose(EK,s12_np,potE,pistar,Q_np,t_bath,dimen3) + pi_np=pistar+0.5*d_time*(2*EK-dimen3*Rb*t_bath) + & -0.5*d_time*(HNose1-H0) + +cd write(iout,'(a,4f)') 'mmm',EK,potE,HNose1,pi_np + d_time_s=d_time*0.5*s12_np + + do j=1,3 + d_t(j,0)=d_t_new(j,0)+d_a(j,0)*d_time_s + enddo + do i=nnt,nct-1 + do j=1,3 + d_t(j,i)=d_t_new(j,i)+d_a(j,i)*d_time_s + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + inres=i+nres + do j=1,3 + d_t(j,inres)=d_t_new(j,inres)+d_a(j,inres)*d_time_s + enddo + endif + enddo + + s_np=s12_np + + return + end + + subroutine hmc_test(itime) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.MD' + include 'COMMON.CHAIN' + + hmc_acc=hmc_acc+1 + delta=-(potE+EK-hmc_etot)/(Rb*t_bath) + if (delta .lt. -50.0d0) then + delta=0.0d0 + else + delta=dexp(delta) + endif + xxx=ran_number(0.0d0,1.0d0) + + if (me.eq.king .or. .not. out1file) + & write(iout,'(a8,i5,6f10.4)') + & 'HMC',itime,potE+EK,potE,EK,hmc_etot,delta,xxx + + if (delta .le. xxx) then + do i=1,2*nres + do j=1,3 + dc(j,i)=dc_hmc(j,i) + enddo + enddo + itime=itime-hmc + totT=totThmc + else + if (me.eq.king .or. .not. out1file) + & write(iout,*) 'HMC accepting new' + totThmc=totT + do i=1,2*nres + do j=1,3 + dc_hmc(j,i)=dc(j,i) + enddo + enddo + endif + + call chainbuild_cart + call random_vel + do i=0,2*nres + do j=1,3 + d_t_old(j,i)=d_t(j,i) + enddo + enddo + call kinetic(EK) + kinetic_T=2.0d0/(dimen3*Rb)*EK + call etotal(potEcomp) + potE=potEcomp(0) + hmc_etot=potE+EK + if (me.eq.king .or. .not. out1file) + & write(iout,'(a8,i5,3f10.4)')'HMC new',itime,potE+EK,potE,EK + + + return + end diff --git a/source/unres/src_MD-DFA-restraints/MP.F b/source/unres/src_MD-DFA-restraints/MP.F new file mode 100644 index 0000000..b08897c --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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' + include 'COMMON.REMD' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TIME1' + include 'COMMON.MD' + integer ilen + external ilen +c + call MPI_Barrier(CG_COMM,ierr) + if (nfgtasks.gt.1) + & call MPI_Bcast(-1,1,MPI_INTEGER,king,FG_COMM,IERROR) + time1=MPI_WTIME() + if (me.eq.king .or. .not. out1file) then + write (iout,'(a,i4,a)') 'CG processor',me,' is finishing work.' + write (iout,*) 'Total wall clock time',time1-walltime,' sec' + if (nfgtasks.gt.1) then + write (iout,'(80(1h=)/a/(80(1h=)))') + & "Details of FG communication time" + write (iout,'(7(a40,1pe15.5/),40(1h-)/a40,1pe15.5/80(1h=))') + & "BROADCAST:",time_bcast,"REDUCE:",time_reduce, + & "GATHER:",time_gather, + & "SCATTER:",time_scatter,"SENDRECV:",time_sendrecv, + & "BARRIER ene",time_barrier_e, + & "BARRIER grad",time_barrier_g,"TOTAL:", + & time_bcast+time_reduce+time_gather+time_scatter+time_sendrecv + & +time_barrier_e+time_barrier_g + write (*,*) 'Total wall clock time',time1-walltime,' sec' + write (*,*) "Processor",me," BROADCAST time",time_bcast, + & " REDUCE time", + & time_reduce," GATHER time",time_gather," SCATTER time", + & time_scatter," SENDRECV",time_sendrecv, + & " BARRIER ene",time_barrier_e," BARRIER grad",time_barrier_g + endif + endif + write (*,'(a,i4,a)') 'CG processor',me,' is finishing work.' + if (ilen(tmpdir).gt.0) then + write (*,*) "Processor",me, + & ": moving output files to the parent directory..." + close(inp) + close(istat,status='keep') + if (ntwe.gt.0) call move_from_tmp(statname) + close(irest2,status='keep') + if (modecalc.eq.12.or. + & (modecalc.eq.14 .and. .not.restart1file)) then + call move_from_tmp(rest2name) + else if (modecalc.eq.14.and. me.eq.king) then + call move_from_tmp(mremd_rst_name) + endif + if (mdpdb) then + close(ipdb,status='keep') + call move_from_tmp(pdbname) + else if (me.eq.king .or. .not.traj1file) then + close(icart,status='keep') + call move_from_tmp(cartname) + endif + if (me.eq.king .or. .not. out1file) then + close (iout,status='keep') + call move_from_tmp(outname) + endif + endif + return + end +c------------------------------------------------------------------------- + subroutine pattern_receive + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'mpif.h' + include 'COMMON.SETUP' + include 'COMMON.THREAD' + include 'COMMON.IOUNITS' + integer tag,status(MPI_STATUS_SIZE) + integer source,ThreadType + logical flag + ThreadType=45 + source=mpi_any_source + call mpi_iprobe(source,ThreadType, + & CG_COMM,flag,status,ierr) + do while (flag) + write (iout,*) 'Processor ',Me,' is receiving threading', + & ' pattern from processor',status(mpi_source) + write (*,*) 'Processor ',Me,' is receiving threading', + & ' pattern from processor',status(mpi_source) + nexcl=nexcl+1 + call mpi_irecv(iexam(1,nexcl),2,mpi_integer,status(mpi_source), + & ThreadType, CG_COMM,ireq,ierr) + write (iout,*) 'Received pattern:',nexcl,iexam(1,nexcl), + & iexam(2,nexcl) + source=mpi_any_source + call mpi_iprobe(source,ThreadType, + & CG_COMM,flag,status,ierr) + enddo + return + end +c---------------------------------------------------------------------------- + subroutine pattern_send + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'mpif.h' + include 'COMMON.INFO' + include 'COMMON.THREAD' + include 'COMMON.IOUNITS' + integer source,ThreadType,ireq + ThreadType=45 + do iproc=0,nprocs-1 + if (iproc.ne.me .and. .not.Koniec(iproc) ) then + call mpi_isend(iexam(1,nexcl),2,mpi_integer,iproc, + & ThreadType, CG_COMM, ireq, ierr) + write (iout,*) 'CG processor ',me,' has sent pattern ', + & 'to processor',iproc + write (*,*) 'CG processor ',me,' has sent pattern ', + & 'to processor',iproc + write (iout,*) 'Pattern:',nexcl,iexam(1,nexcl),iexam(2,nexcl) + endif + enddo + return + end +c----------------------------------------------------------------------------- + subroutine send_stop_sig(Kwita) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'mpif.h' + include 'COMMON.INFO' + include 'COMMON.IOUNITS' + integer StopType,StopId,iproc,Kwita,NBytes + StopType=66 +c Kwita=-1 +C print *,'CG processor',me,' StopType=',StopType + Koniec(me)=.true. + if (me.eq.king) then +C Master sends the STOP signal to everybody. + write (iout,'(a,a)') + & 'Master is sending STOP signal to other processors.' + do iproc=1,nprocs-1 + print *,'Koniec(',iproc,')=',Koniec(iproc) + if (.not. Koniec(iproc)) then + call mpi_send(Kwita,1,mpi_integer,iproc,StopType, + & mpi_comm_world,ierr) + write (iout,*) 'Iproc=',iproc,' StopID=',StopID + write (*,*) 'Iproc=',iproc,' StopID=',StopID + endif + enddo + else +C Else send the STOP signal to Master. + call mpi_send(Kwita,1,mpi_integer,MasterID,StopType, + & mpi_comm_world,ierr) + write (iout,*) 'CG processor=',me,' StopID=',StopID + write (*,*) 'CG processor=',me,' StopID=',StopID + endif + return + end +c----------------------------------------------------------------------------- + subroutine recv_stop_sig(Kwita) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'mpif.h' + include 'COMMON.INFO' + include 'COMMON.IOUNITS' + integer source,StopType,StopId,iproc,Kwita + logical flag + StopType=66 + Kwita=0 + source=mpi_any_source +c print *,'CG processor:',me,' StopType=',StopType + call mpi_iprobe(source,StopType, + & mpi_comm_world,flag,status,ierr) + do while (flag) + Koniec(status(mpi_source))=.true. + write (iout,*) 'CG processor ',me,' is receiving STOP signal', + & ' from processor',status(mpi_source) + write (*,*) 'CG processor ',me,' is receiving STOP signal', + & ' from processor',status(mpi_source) + call mpi_irecv(Kwita,1,mpi_integer,status(mpi_source),StopType, + & mpi_comm_world,ireq,ierr) + call mpi_iprobe(source,StopType, + & mpi_comm_world,flag,status,ierr) + enddo + return + end +c----------------------------------------------------------------------------- + subroutine send_MCM_info(ione) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'mpif.h' + include 'COMMON.SETUP' + include 'COMMON.MCM' + include 'COMMON.IOUNITS' + integer tag,status(MPI_STATUS_SIZE) + integer MCM_info_Type,MCM_info_ID,iproc,one,NBytes + common /aaaa/ isend,irecv + integer nsend + save nsend + nsend=nsend+1 + MCM_info_Type=77 +cd write (iout,'(a,i4,a)') 'CG Processor',me, +cd & ' is sending MCM info to Master.' + write (*,'(a,i4,a,i8)') 'CG processor',me, + & ' is sending MCM info to Master, MCM_info_ID=',MCM_info_ID + call mpi_isend(ione,1,mpi_integer,MasterID, + & MCM_info_Type,mpi_comm_world, MCM_info_ID, ierr) +cd write (iout,*) 'CG processor',me,' has sent info to the master;', +cd & ' MCM_info_ID=',MCM_info_ID + write (*,*) 'CG processor',me,' has sent info to the master;', + & ' MCM_info_ID=',MCM_info_ID,' ierr ',ierr + isend=0 + irecv=0 + return + end +c---------------------------------------------------------------------------- + subroutine receive_MCM_info + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'mpif.h' + include 'COMMON.SETUP' + include 'COMMON.MCM' + include 'COMMON.IOUNITS' + integer tag,status(MPI_STATUS_SIZE) + integer source,MCM_info_Type,MCM_info_ID,iproc,ione + logical flag + MCM_info_Type=77 + source=mpi_any_source +c print *,'source=',source,' dontcare=',dontcare + call mpi_iprobe(source,MCM_info_Type, + & mpi_comm_world,flag,status,ierr) + do while (flag) + source=status(mpi_source) + itask=source/fgProcs+1 +cd write (iout,*) 'Master is receiving MCM info from processor ', +cd & source,' itask',itask + write (*,*) 'Master is receiving MCM info from processor ', + & source,' itask',itask + call mpi_irecv(ione,1,mpi_integer,source,MCM_info_type, + & mpi_comm_world,MCM_info_ID,ierr) +cd write (iout,*) 'Received from processor',source,' IONE=',ione + write (*,*) 'Received from processor',source,' IONE=',ione + nacc_tot=nacc_tot+1 + if (ione.eq.2) nsave_part(itask)=nsave_part(itask)+1 +cd print *,'nsave_part(',itask,')=',nsave_part(itask) +cd write (iout,*) 'Nacc_tot=',Nacc_tot +cd write (*,*) 'Nacc_tot=',Nacc_tot + source=mpi_any_source + call mpi_iprobe(source,MCM_info_Type, + & mpi_comm_world,flag,status,ierr) + enddo + return + end +c--------------------------------------------------------------------------- + subroutine send_thread_results + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'mpif.h' + include 'COMMON.SETUP' + include 'COMMON.THREAD' + include 'COMMON.IOUNITS' + integer tag,status(MPI_STATUS_SIZE) + integer ibuffer(2*maxthread+2),ThreadType,ThreadID,EnerType, + & EnerID,msglen,nbytes + double precision buffer(20*maxthread+2) + ThreadType=444 + EnerType=555 + ipatt(1,nthread+1)=nthread + ipatt(2,nthread+1)=nexcl + do i=1,nthread + do j=1,n_ene + ener(j,i+nthread)=ener0(j,i) + enddo + enddo + ener(1,2*nthread+1)=max_time_for_thread + ener(2,2*nthread+1)=ave_time_for_thread +C Send the IPATT array + write (iout,*) 'CG processor',me, + & ' is sending IPATT array to master: NTHREAD=',nthread + write (*,*) 'CG processor',me, + & ' is sending IPATT array to master: NTHREAD=',nthread + msglen=2*nthread+2 + call mpi_send(ipatt(1,1),msglen,MPI_INTEGER,MasterID, + & ThreadType,mpi_comm_world,ierror) + write (iout,*) 'CG processor',me, + & ' has sent IPATT array to master MSGLEN',msglen + write (*,*) 'CG processor',me, + & ' has sent IPATT array to master MSGLEN',msglen +C Send the energies. + msglen=n_ene2*nthread+2 + write (iout,*) 'CG processor',me,' is sending energies to master.' + write (*,*) 'CG processor',me,' is sending energies to master.' + call mpi_send(ener(1,1),msglen,MPI_DOUBLE_PRECISION,MasterID, + & EnerType,mpi_comm_world,ierror) + write (iout,*) 'CG processor',me,' has sent energies to master.' + write (*,*) 'CG processor',me,' has sent energies to master.' + return + end +c---------------------------------------------------------------------------- + subroutine receive_thread_results(iproc) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'mpif.h' + include 'COMMON.INFO' + include 'COMMON.THREAD' + include 'COMMON.IOUNITS' + integer ibuffer(2*maxthread+2),ThreadType,ThreadID,EnerType, + & EnerID,ReadyType,ReadyID,Ready,msglen,nbytes,nthread_temp + double precision buffer(20*maxthread+2),max_time_for_thread_t, + & ave_time_for_thread_t + logical flag + ThreadType=444 + EnerType=555 +C Receive the IPATT array + call mpi_probe(iproc,ThreadType, + & mpi_comm_world,status,ierr) + call MPI_GET_COUNT(STATUS, MPI_INTEGER, MSGLEN, IERROR) + write (iout,*) 'Master is receiving IPATT array from processor:', + & iproc,' MSGLEN',msglen + write (*,*) 'Master is receiving IPATT array from processor:', + & iproc,' MSGLEN',msglen + call mpi_recv(ipatt(1,nthread+1),msglen,mpi_integer,iproc, + & ThreadType, + & mpi_comm_world,status,ierror) + write (iout,*) 'Master has received IPATT array from processor:', + & iproc,' MSGLEN=',msglen + write (*,*) 'Master has received IPATT array from processor:', + & iproc,' MSGLEN=',msglen + nthread_temp=ipatt(1,nthread+msglen/2) + nexcl_temp=ipatt(2,nthread+msglen/2) +C Receive the energies. + call mpi_probe(iproc,EnerType, + & mpi_comm_world,status,ierr) + call MPI_GET_COUNT(STATUS, MPI_DOUBLE_PRECISION, MSGLEN, IERROR) + write (iout,*) 'Master is receiving energies from processor:', + & iproc,' MSGLEN=',MSGLEN + write (*,*) 'Master is receiving energies from processor:', + & iproc,' MSGLEN=',MSGLEN + call mpi_recv(ener(1,nthread+1),msglen, + & MPI_DOUBLE_PRECISION,iproc, + & EnerType,MPI_COMM_WORLD,status,ierror) + write (iout,*) 'Msglen=',Msglen + write (*,*) 'Msglen=',Msglen + write (iout,*) 'Master has received energies from processor',iproc + write (*,*) 'Master has received energies from processor',iproc + write (iout,*) 'NTHREAD_TEMP=',nthread_temp,' NEXCL=',nexcl_temp + write (*,*) 'NTHREAD_TEMP=',nthread_temp,' NEXCL=',nexcl_temp + do i=1,nthread_temp + do j=1,n_ene + ener0(j,nthread+i)=ener(j,nthread+nthread_temp+i) + enddo + enddo + max_time_for_thread_t=ener(1,nthread+2*nthread_temp+1) + ave_time_for_thread_t=ener(2,nthread+2*nthread_temp+1) + write (iout,*) 'MAX_TIME_FOR_THREAD:',max_time_for_thread_t + write (iout,*) 'AVE_TIME_FOR_THREAD:',ave_time_for_thread_t + write (*,*) 'MAX_TIME_FOR_THREAD:',max_time_for_thread_t + write (*,*) 'AVE_TIME_FOR_THREAD:',ave_time_for_thread_t + if (max_time_for_thread_t.gt.max_time_for_thread) + & max_time_for_thread=max_time_for_thread_t + ave_time_for_thread=(nthread*ave_time_for_thread+ + & nthread_temp*ave_time_for_thread_t)/(nthread+nthread_temp) + nthread=nthread+nthread_temp + return + end +#else + subroutine init_task + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.SETUP' + me=0 + myrank=0 + fg_rank=0 + fg_size=1 + nodes=1 + nprocs=1 + call initialize + call openunits + write (iout,'(80(1h*)/a/80(1h*))') + & 'United-residue force field calculation - serial job.' + return + end +#endif diff --git a/source/unres/src_MD-DFA-restraints/MREMD.F b/source/unres/src_MD-DFA-restraints/MREMD.F new file mode 100644 index 0000000..8023039 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/MREMD.F @@ -0,0 +1,2112 @@ +#ifdef MPI + subroutine MREMD + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'mpif.h' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' +#ifndef LANG0 + include 'COMMON.LANGEVIN' +#else + include 'COMMON.LANGEVIN.lang0' +#endif + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.TIME1' + include 'COMMON.REMD' + include 'COMMON.SETUP' + include 'COMMON.MUCA' + integer ERRCODE + double precision cm(3),L(3),vcm(3) + double precision energia(0:n_ene) + double precision remd_t_bath(maxprocs) + integer iremd_iset(maxprocs) + integer*2 i_index + & (maxprocs/4,maxprocs/20,maxprocs/200,maxprocs/200) + double precision remd_ene(0:n_ene+4,maxprocs),t_bath_old + integer iremd_acc(maxprocs),iremd_tot(maxprocs) + integer iremd_acc_usa(maxprocs),iremd_tot_usa(maxprocs) + integer ilen,rstcount + external ilen + character*50 tytul + common /gucio/ cm + integer itime +cold integer nup(0:maxprocs),ndown(0:maxprocs) + integer rep2i(0:maxprocs),ireqi(maxprocs) + integer icache_all(maxprocs) + integer status(MPI_STATUS_SIZE),statusi(MPI_STATUS_SIZE,maxprocs) + logical synflag,end_of_run,file_exist /.false./,ovrtim + real ene_tol /1.0e-5/ + +cdeb imin_itime_old=0 + ntwx_cache=0 + time00=MPI_WTIME() + time01=time00 + if(me.eq.king.or..not.out1file) then + write (iout,*) 'MREMD',nodes,'time before',time00-walltime + write (iout,*) "NREP=",nrep + endif + + synflag=.false. + if (ilen(tmpdir).gt.0 .and. (me.eq.king)) then + call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_mremd.rst") + endif + mremd_rst_name=prefix(:ilen(prefix))//"_mremd.rst" + +cd print *,'MREMD',nodes +cd print *,'mmm',me,remd_mlist,(remd_m(i),i=1,nrep) +cde write (iout,*) "Start MREMD: me",me," t_bath",t_bath + + if(hremd.gt.0) then + nset=hremd + do i=1,nset + mset(i)=1 + enddo + endif + + k=0 + rep2i(k)=-1 + do il=1,max0(nset,1) + do il1=1,max0(mset(il),1) + do i=1,nrep + iremd_acc(i)=0 + iremd_acc_usa(i)=0 + iremd_tot(i)=0 + do j=1,remd_m(i) + i2rep(k)=i + i2set(k)=il + rep2i(i)=k + k=k+1 + i_index(i,j,il,il1)=k + enddo + enddo + enddo + enddo + + if(me.eq.king.or..not.out1file) then + write(iout,*) "i2rep",(i2rep(i),i=0,nodes-1) + write(iout,*) "i2set",(i2set(i),i=0,nodes-1) + write(iout,*) "i,j,il,il1,i_index(i,j,il,il1)" + do il=1,nset + do il1=1,mset(il) + do i=1,nrep + do j=1,remd_m(i) + write(iout,*) i,j,il,il1,i_index(i,j,il,il1) + enddo + enddo + enddo + enddo + endif + +c print *,'i2rep',me,i2rep(me) +c print *,'rep2i',(rep2i(i),i=0,nrep) + +cold if (i2rep(me).eq.nrep) then +cold nup(0)=0 +cold else +cold nup(0)=remd_m(i2rep(me)+1) +cold k=rep2i(int(i2rep(me)))+1 +cold do i=1,nup(0) +cold nup(i)=k +cold k=k+1 +cold enddo +cold endif + +cd print '(i4,a4,100i4)',me,' nup',(nup(i),i=0,nup(0)) + +cold if (i2rep(me).eq.1) then +cold ndown(0)=0 +cold else +cold ndown(0)=remd_m(i2rep(me)-1) +cold k=rep2i(i2rep(me)-2)+1 +cold do i=1,ndown(0) +cold ndown(i)=k +cold k=k+1 +cold enddo +cold endif + +cd print '(i4,a6,100i4)',me,' ndown',(ndown(i),i=0,ndown(0)) + + + write (*,*) "Processor",me," rest",rest," + & restart1fie",restart1file + if(rest.and.restart1file) then + if (me.eq.king) + & inquire(file=mremd_rst_name,exist=file_exist) +cd write (*,*) me," Before broadcast: file_exist",file_exist + call MPI_Bcast(file_exist,1,MPI_LOGICAL,king,CG_COMM, + & IERR) +cd write (*,*) me," After broadcast: file_exist",file_exist + if(file_exist) then + if(me.eq.king.or..not.out1file) + & write (iout,*) 'Master is reading restart1file' + call read1restart(i_index) + else + if(me.eq.king.or..not.out1file) + & write (iout,*) 'WARNING : no restart1file' + endif + + if(me.eq.king.or..not.out1file) then + write(iout,*) "i2set",(i2set(i),i=0,nodes-1) + write(iout,*) "i_index" + do il=1,nset + do il1=1,mset(il) + do i=1,nrep + do j=1,remd_m(i) + write(iout,*) i,j,il,il1,i_index(i,j,il,il1) + enddo + enddo + enddo + enddo + endif + endif + + if(me.eq.king) then + if (rest.and..not.restart1file) + & inquire(file=mremd_rst_name,exist=file_exist) + if(.not.file_exist.and.rest.and..not.restart1file) + & write(iout,*) 'WARNING : no restart file',mremd_rst_name + IF (rest.and.file_exist.and..not.restart1file) THEN + write (iout,*) 'Master is reading restart file', + & mremd_rst_name + open(irest2,file=mremd_rst_name,status='unknown') + read (irest2,*) + read (irest2,*) (i2rep(i),i=0,nodes-1) + read (irest2,*) + read (irest2,*) (ifirst(i),i=1,remd_m(1)) + do il=1,nodes + read (irest2,*) + read (irest2,*) nupa(0,il),(nupa(i,il),i=1,nupa(0,il)) + read (irest2,*) + read (irest2,*) ndowna(0,il), + & (ndowna(i,il),i=1,ndowna(0,il)) + enddo + if(usampl.or.hremd.gt.0) then + read (irest2,*) + read (irest2,*) nset + read (irest2,*) + read (irest2,*) (mset(i),i=1,nset) + read (irest2,*) + read (irest2,*) (i2set(i),i=0,nodes-1) + read (irest2,*) + do il=1,nset + do il1=1,mset(il) + do i=1,nrep + read(irest2,*) (i_index(i,j,il,il1),j=1,remd_m(i)) + enddo + enddo + enddo + + write(iout,*) "i2set",(i2set(i),i=0,nodes-1) + write(iout,*) "i_index" + do il=1,nset + do il1=1,mset(il) + do i=1,nrep + do j=1,remd_m(i) + write(iout,*) i,j,il,il1,i_index(i,j,il,il1) + enddo + enddo + enddo + enddo + endif + + close(irest2) + + write (iout,'(a6,1000i5)') "i2rep",(i2rep(i),i=0,nodes-1) + write (iout,'(a6,1000i5)') "ifirst", + & (ifirst(i),i=1,remd_m(1)) + do il=1,nodes + write (iout,'(a6,i4,a1,100i4)') "nupa",il,":", + & (nupa(i,il),i=1,nupa(0,il)) + write (iout,'(a6,i4,a1,100i4)') "ndowna",il,":", + & (ndowna(i,il),i=1,ndowna(0,il)) + enddo + ELSE IF (.not.(rest.and.file_exist)) THEN + do il=1,remd_m(1) + ifirst(il)=il + enddo + + do il=1,nodes + if (i2rep(il-1).eq.nrep) then + nupa(0,il)=0 + else + nupa(0,il)=remd_m(i2rep(il-1)+1) + k=rep2i(int(i2rep(il-1)))+1 + do i=1,nupa(0,il) + nupa(i,il)=k+1 + k=k+1 + enddo + endif + if (i2rep(il-1).eq.1) then + ndowna(0,il)=0 + else + ndowna(0,il)=remd_m(i2rep(il-1)-1) + k=rep2i(i2rep(il-1)-2)+1 + do i=1,ndowna(0,il) + ndowna(i,il)=k+1 + k=k+1 + enddo + endif + enddo + + write (iout,'(a6,100i4)') "ifirst", + & (ifirst(i),i=1,remd_m(1)) + do il=1,nodes + write (iout,'(a6,i4,a1,100i4)') "nupa",il,":", + & (nupa(i,il),i=1,nupa(0,il)) + write (iout,'(a6,i4,a1,100i4)') "ndowna",il,":", + & (ndowna(i,il),i=1,ndowna(0,il)) + enddo + + ENDIF + endif +c +c t_bath=retmin+(retmax-retmin)*me/(nodes-1) + if(.not.(rest.and.file_exist.and.restart1file)) then + if (me .eq. king) then + t_bath=retmin + else + t_bath=retmin+(retmax-retmin)*exp(float(i2rep(me)-nrep)) + endif +cd print *,'ttt',me,remd_tlist,(remd_t(i),i=1,nrep) + if (remd_tlist) t_bath=remd_t(int(i2rep(me))) + + endif + if(usampl.or.hremd.gt.0) then + iset=i2set(me) + if (hremd.gt.0) call set_hweights(iset) + if(me.eq.king.or..not.out1file) + & write(iout,*) me,"iset=",iset,"t_bath=",t_bath + endif +c + stdfp=dsqrt(2*Rb*t_bath/d_time) + do i=1,ntyp + stdfsc(i)=dsqrt(2*Rb*t_bath/d_time) + enddo + +c print *,'irep',me,t_bath + if (.not.rest) then + if (me.eq.king .or. .not. out1file) + & write (iout,'(a60,f10.5)') "REMD Temperature:",t_bath + call rescale_weights(t_bath) + endif + + +c------copy MD-------------- +c The driver for molecular dynamics subroutines +c------------------------------------------------ + t_MDsetup=0.0d0 + t_langsetup=0.0d0 + t_MD=0.0d0 + t_enegrad=0.0d0 + t_sdsetup=0.0d0 + if(me.eq.king.or..not.out1file) + & write (iout,'(20(1h=),a20,20(1h=))') "MD calculation started" +#ifdef MPI + tt0 = MPI_Wtime() +#else + tt0 = tcpu() +#endif +c Determine the inverse of the inertia matrix. + call setup_MD_matrices +c Initialize MD + call init_MD + if (rest) then + if (me.eq.king .or. .not. out1file) + & write (iout,'(a60,f10.5)') "REMD restart Temperature:",t_bath + stdfp=dsqrt(2*Rb*t_bath/d_time) + do i=1,ntyp + stdfsc(i)=dsqrt(2*Rb*t_bath/d_time) + enddo + if (lang.gt.0 .and. .not.surfarea) then + do i=nnt,nct-1 + stdforcp(i)=stdfp*dsqrt(gamp) + enddo + do i=nnt,nct + stdforcsc(i)=stdfsc(itype(i))*dsqrt(gamsc(itype(i))) + enddo + elseif (lang.gt.0 .and. surfarea ) then + call setup_fricmat + endif + call rescale_weights(t_bath) + endif + +#ifdef MPI + t_MDsetup = MPI_Wtime()-tt0 +#else + t_MDsetup = tcpu()-tt0 +#endif + rstcount=0 +c Entering the MD loop +#ifdef MPI + tt0 = MPI_Wtime() +#else + tt0 = tcpu() +#endif + if (lang.eq.2 .or. lang.eq.3) then +#ifndef LANG0 + call setup_fricmat + if (lang.eq.2) then + call sd_verlet_p_setup + else + call sd_verlet_ciccotti_setup + endif + do i=1,dimen + do j=1,dimen + pfric0_mat(i,j,0)=pfric_mat(i,j) + afric0_mat(i,j,0)=afric_mat(i,j) + vfric0_mat(i,j,0)=vfric_mat(i,j) + prand0_mat(i,j,0)=prand_mat(i,j) + vrand0_mat1(i,j,0)=vrand_mat1(i,j) + vrand0_mat2(i,j,0)=vrand_mat2(i,j) + enddo + enddo + flag_stoch(0)=.true. + do i=1,maxflag_stoch + flag_stoch(i)=.false. + enddo +#else + write (iout,*) + & "LANG=2 or 3 NOT SUPPORTED. Recompile without -DLANG0" +#ifdef MPI + call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) +#endif + stop +#endif + else if (lang.eq.1 .or. lang.eq.4) then + call setup_fricmat + endif + time00=MPI_WTIME() + if (me.eq.king .or. .not. out1file) + & write(iout,*) 'Setup time',time00-walltime +ctime call flush(iout) +#ifdef MPI + t_langsetup=MPI_Wtime()-tt0 + tt0=MPI_Wtime() +#else + t_langsetup=tcpu()-tt0 + tt0=tcpu() +#endif + itime=0 + end_of_run=.false. + do while(.not.end_of_run) + itime=itime+1 + if(itime.eq.n_timestep.and.me.eq.king) end_of_run=.true. + if(mremdsync.and.itime.eq.n_timestep) end_of_run=.true. + rstcount=rstcount+1 + if (lang.gt.0 .and. surfarea .and. + & mod(itime,reset_fricmat).eq.0) then + if (lang.eq.2 .or. lang.eq.3) then +#ifndef LANG0 + call setup_fricmat + if (lang.eq.2) then + call sd_verlet_p_setup + else + call sd_verlet_ciccotti_setup + endif + do i=1,dimen + do j=1,dimen + pfric0_mat(i,j,0)=pfric_mat(i,j) + afric0_mat(i,j,0)=afric_mat(i,j) + vfric0_mat(i,j,0)=vfric_mat(i,j) + prand0_mat(i,j,0)=prand_mat(i,j) + vrand0_mat1(i,j,0)=vrand_mat1(i,j) + vrand0_mat2(i,j,0)=vrand_mat2(i,j) + enddo + enddo + flag_stoch(0)=.true. + do i=1,maxflag_stoch + flag_stoch(i)=.false. + enddo +#endif + else if (lang.eq.1 .or. lang.eq.4) then + call setup_fricmat + endif + write (iout,'(a,i10)') + & "Friction matrix reset based on surface area, itime",itime + endif + if (reset_vel .and. tbf .and. lang.eq.0 + & .and. mod(itime,count_reset_vel).eq.0) then + call random_vel + if (me.eq.king .or. .not. out1file) + & write(iout,'(a,f20.2)') + & "Velocities reset to random values, time",totT + do i=0,2*nres + do j=1,3 + d_t_old(j,i)=d_t(j,i) + enddo + enddo + endif + if (reset_moment .and. mod(itime,count_reset_moment).eq.0) then + call inertia_tensor + call vcm_vel(vcm) + do j=1,3 + d_t(j,0)=d_t(j,0)-vcm(j) + enddo + call kinetic(EK) + kinetic_T=2.0d0/(dimen3*Rb)*EK + scalfac=dsqrt(T_bath/kinetic_T) +cd write(iout,'(a,f20.2)') "Momenta zeroed out, time",totT + do i=0,2*nres + do j=1,3 + d_t_old(j,i)=scalfac*d_t(j,i) + enddo + enddo + endif + if (lang.ne.4) then + if (RESPA) then +c Time-reversible RESPA algorithm +c (Tuckerman et al., J. Chem. Phys., 97, 1990, 1992) + call RESPA_step(itime) + else +c Variable time step algorithm. + call velverlet_step(itime) + endif + else +#ifdef BROWN + call brown_step(itime) +#else + print *,"Brown dynamics not here!" +#ifdef MPI + call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) +#endif + stop +#endif + endif + if(hmc.gt.0 .and. mod(itime,hmc).eq.0) then + call statout(itime) + call hmc_test(itime) + endif + if(ntwe.ne.0) then + if (mod(itime,ntwe).eq.0) call statout(itime) + endif + if (mod(itime,ntwx).eq.0.and..not.traj1file) then + write (tytul,'("time",f8.2," temp",f8.1)') totT,t_bath + if(mdpdb) then + call pdbout(potE,tytul,ipdb) + else + call cartout(totT) + endif + endif + if (mod(itime,ntwx).eq.0.and.traj1file) then + if(ntwx_cache.lt.max_cache_traj_use) then + ntwx_cache=ntwx_cache+1 + else + if (max_cache_traj_use.ne.1) + & print *,itime,"processor ",me," over cache ",ntwx_cache + do i=1,ntwx_cache-1 + + totT_cache(i)=totT_cache(i+1) + EK_cache(i)=EK_cache(i+1) + potE_cache(i)=potE_cache(i+1) + t_bath_cache(i)=t_bath_cache(i+1) + Uconst_cache(i)=Uconst_cache(i+1) + iset_cache(i)=iset_cache(i+1) + + do ii=1,nfrag + qfrag_cache(ii,i)=qfrag_cache(ii,i+1) + enddo + do ii=1,npair + qpair_cache(ii,i)=qpair_cache(ii,i+1) + enddo + do ii=1,nfrag_back + utheta_cache(ii,i)=utheta_cache(ii,i+1) + ugamma_cache(ii,i)=ugamma_cache(ii,i+1) + uscdiff_cache(ii,i)=uscdiff_cache(ii,i+1) + enddo + + + do ii=1,nres*2 + do j=1,3 + c_cache(j,ii,i)=c_cache(j,ii,i+1) + enddo + enddo + enddo + endif + + totT_cache(ntwx_cache)=totT + EK_cache(ntwx_cache)=EK + potE_cache(ntwx_cache)=potE + t_bath_cache(ntwx_cache)=t_bath + Uconst_cache(ntwx_cache)=Uconst + iset_cache(ntwx_cache)=iset + + do i=1,nfrag + qfrag_cache(i,ntwx_cache)=qfrag(i) + enddo + do i=1,npair + qpair_cache(i,ntwx_cache)=qpair(i) + enddo + do i=1,nfrag_back + utheta_cache(i,ntwx_cache)=utheta(i) + ugamma_cache(i,ntwx_cache)=ugamma(i) + uscdiff_cache(i,ntwx_cache)=uscdiff(i) + enddo + + do i=1,nres*2 + do j=1,3 + c_cache(j,i,ntwx_cache)=c(j,i) + enddo + enddo + + endif + if ((rstcount.eq.1000.or.itime.eq.n_timestep) + & .and..not.restart1file) then + + if(me.eq.king) then + open(irest1,file=mremd_rst_name,status='unknown') + write (irest1,*) "i2rep" + write (irest1,*) (i2rep(i),i=0,nodes-1) + write (irest1,*) "ifirst" + write (irest1,*) (ifirst(i),i=1,remd_m(1)) + do il=1,nodes + write (irest1,*) "nupa",il + write (irest1,*) nupa(0,il),(nupa(i,il),i=1,nupa(0,il)) + write (irest1,*) "ndowna",il + write (irest1,*) ndowna(0,il), + & (ndowna(i,il),i=1,ndowna(0,il)) + enddo + if(usampl.or.hremd.gt.0) then + write (irest1,*) "nset" + write (irest1,*) nset + write (irest1,*) "mset" + write (irest1,*) (mset(i),i=1,nset) + write (irest1,*) "i2set" + write (irest1,*) (i2set(i),i=0,nodes-1) + write (irest1,*) "i_index" + do il=1,nset + do il1=1,mset(il) + do i=1,nrep + write(irest1,*) (i_index(i,j,il,il1),j=1,remd_m(i)) + enddo + enddo + enddo + + endif + close(irest1) + endif + open(irest2,file=rest2name,status='unknown') + write(irest2,*) totT,EK,potE,totE,t_bath + do i=1,2*nres + write (irest2,'(3e15.5)') (d_t(j,i),j=1,3) + enddo + do i=1,2*nres + write (irest2,'(3e15.5)') (dc(j,i),j=1,3) + enddo + if(usampl.or.hremd.gt.0) then + write (irest2,*) iset + endif + close(irest2) + rstcount=0 + endif + +c REMD - exchange +c forced synchronization + if (mod(itime,i_sync_step).eq.0 .and. me.ne.king + & .and. .not. mremdsync) then + synflag=.false. + call mpi_iprobe(0,101,CG_COMM,synflag,status,ierr) + if (synflag) then + call mpi_recv(itime_master, 1, MPI_INTEGER, + & 0,101,CG_COMM, status, ierr) + call mpi_barrier(CG_COMM, ierr) +cdeb if (out1file.or.traj1file) then +cdeb call mpi_gather(itime,1,mpi_integer, +cdeb & icache_all,1,mpi_integer,king, +cdeb & CG_COMM,ierr) + if(traj1file) + & call mpi_gather(ntwx_cache,1,mpi_integer, + & icache_all,1,mpi_integer,king, + & CG_COMM,ierr) + if (.not.out1file) + & write(iout,*) 'REMD synchro at',itime_master,itime + if (itime_master.ge.n_timestep .or. ovrtim()) + & end_of_run=.true. +ctime call flush(iout) + endif + endif + +c REMD - exchange + if ((mod(itime,nstex).eq.0.and.me.eq.king + & .or.end_of_run.and.me.eq.king ) + & .and. .not. mremdsync ) then + synflag=.true. + time01_=MPI_WTIME() + do i=1,nodes-1 + call mpi_isend(itime,1,MPI_INTEGER,i,101, + & CG_COMM, ireqi(i), ierr) +cd write(iout,*) 'REMD synchro with',i +cd call flush(iout) + enddo + call mpi_waitall(nodes-1,ireqi,statusi,ierr) + call mpi_barrier(CG_COMM, ierr) + time01=MPI_WTIME() + write(iout,*) 'REMD synchro at',itime,'time=',time01-time01_ + if (out1file.or.traj1file) then +cdeb call mpi_gather(itime,1,mpi_integer, +cdeb & itime_all,1,mpi_integer,king, +cdeb & CG_COMM,ierr) +cdeb write(iout,'(a19,8000i8)') ' REMD synchro itime', +cdeb & (itime_all(i),i=1,nodes) + if(traj1file) then +cdeb imin_itime=itime_all(1) +cdeb do i=2,nodes +cdeb if(itime_all(i).lt.imin_itime) imin_itime=itime_all(i) +cdeb enddo +cdeb ii_write=(imin_itime-imin_itime_old)/ntwx +cdeb imin_itime_old=int(imin_itime/ntwx)*ntwx +cdeb write(iout,*) imin_itime,imin_itime_old,ii_write + call mpi_gather(ntwx_cache,1,mpi_integer, + & icache_all,1,mpi_integer,king, + & CG_COMM,ierr) +c write(iout,'(a19,8000i8)') ' ntwx_cache', +c & (icache_all(i),i=1,nodes) + ii_write=icache_all(1) + do i=2,nodes + if(icache_all(i).lt.ii_write) ii_write=icache_all(i) + enddo +c write(iout,*) "MIN ii_write=",ii_write + endif + endif +ctime call flush(iout) + endif + if(mremdsync .and. mod(itime,nstex).eq.0) then + synflag=.true. + if (me.eq.king .or. .not. out1file) + & write(iout,*) 'REMD synchro at',itime + + if(traj1file) then + call mpi_gather(ntwx_cache,1,mpi_integer, + & icache_all,1,mpi_integer,king, + & CG_COMM,ierr) + if (me.eq.king) then + write(iout,'(a19,8000i8)') ' ntwx_cache', + & (icache_all(i),i=1,nodes) + ii_write=icache_all(1) + do i=2,nodes + if(icache_all(i).lt.ii_write) ii_write=icache_all(i) + enddo + write(iout,*) "MIN ii_write=",ii_write + endif + endif +ctest call flush(iout) + endif + if (synflag) then +c Update the time safety limiy + if (time001-time00.gt.safety) then + safety=time001-time00+600 + if (me.eq.king .or. .not. out1file) + & write (iout,*) "****** SAFETY increased to",safety," s" + endif + if (ovrtim()) end_of_run=.true. + endif + if(synflag.and..not.end_of_run) then + time02=MPI_WTIME() + synflag=.false. + +c write(iout,*) 'REMD before',me,t_bath + +c call mpi_gather(t_bath,1,mpi_double_precision, +c & remd_t_bath,1,mpi_double_precision,king, +c & CG_COMM,ierr) + potEcomp(n_ene+1)=t_bath + t_bath_old=t_bath + if (usampl) then + potEcomp(n_ene+2)=iset + if (iset.lt.nset) then + i_set_temp=iset + iset=iset+1 + call EconstrQ + potEcomp(n_ene+3)=Uconst + iset=i_set_temp + endif + if (iset.gt.1) then + i_set_temp=iset + iset=iset-1 + call EconstrQ + potEcomp(n_ene+4)=Uconst + iset=i_set_temp + endif + endif + if(hremd.gt.0) potEcomp(n_ene+2)=iset + call mpi_gather(potEcomp(0),n_ene+5,mpi_double_precision, + & remd_ene(0,1),n_ene+5,mpi_double_precision,king, + & CG_COMM,ierr) + if(lmuca) then + call mpi_gather(elow,1,mpi_double_precision, + & elowi,1,mpi_double_precision,king, + & CG_COMM,ierr) + call mpi_gather(ehigh,1,mpi_double_precision, + & ehighi,1,mpi_double_precision,king, + & CG_COMM,ierr) + endif + + time03=MPI_WTIME() + if (me.eq.king .or. .not. out1file) then + write(iout,*) 'REMD gather times=',time03-time01 + & ,time03-time02 + endif + + if (restart1file) call write1rst(i_index) + + time04=MPI_WTIME() + if (me.eq.king .or. .not. out1file) then + write(iout,*) 'REMD writing rst time=',time04-time03 + endif + + if (traj1file) call write1traj +cd debugging +cdeb call mpi_gather(ntwx_cache,1,mpi_integer, +cdeb & icache_all,1,mpi_integer,king, +cdeb & CG_COMM,ierr) +cdeb write(iout,'(a19,8000i8)') ' ntwx_cache after traj1file', +cdeb & (icache_all(i),i=1,nodes) +cd end + + + time05=MPI_WTIME() + if (me.eq.king .or. .not. out1file) then + write(iout,*) 'REMD writing traj time=',time05-time04 +ctime call flush(iout) + endif + + + if (me.eq.king) then + do i=1,nodes + remd_t_bath(i)=remd_ene(n_ene+1,i) + iremd_iset(i)=remd_ene(n_ene+2,i) + enddo +#ifdef DEBUG + if(lmuca) then +co write(iout,*) 'REMD exchange temp,ene,elow,ehigh' + do i=1,nodes + write(iout,'(i4,4f12.5)') i,remd_t_bath(i),remd_ene(0,i), + & elowi(i),ehighi(i) + enddo + else + write(iout,*) 'REMD exchange temp,ene' + do i=1,nodes + write(iout,'(i4,2f12.5)') i,remd_t_bath(i),remd_ene(0,i) + write(iout,'(6f12.5)') (remd_ene(j,i),j=1,n_ene) + enddo + endif +#endif +c------------------------------------- + IF(.not.usampl.and.hremd.eq.0) THEN +#ifdef DEBUG + write (iout,*) "Enter exchnge, remd_m",remd_m(1), + & " nodes",nodes +ctime call flush(iout) + write (iout,*) "remd_m(1)",remd_m(1) +#endif + do irr=1,remd_m(1) + i=ifirst(iran_num(1,remd_m(1))) +#ifdef DEBUG + write (iout,*) "i",i +#endif +ctime call flush(iout) + + do ii=1,nodes-1 + +#ifdef DEBUG + write (iout,*) "i",i," nupa(0,i)",int(nupa(0,i)) +#endif + if(i.gt.0.and.nupa(0,i).gt.0) then + iex=i +c if (i.eq.1 .and. int(nupa(0,i)).eq.1) then +c write (iout,*) +c & "CHUJ ABSOLUTNY!!! No way to sample a distinct replica in MREMD" +c call flush(iout) +c call MPI_Abort(MPI_COMM_WORLD,ERRCODE,ierr) +c endif +c do while (iex.eq.i) +c write (iout,*) "upper",nupa(int(nupa(0,i)),i) + iex=nupa(iran_num(1,int(nupa(0,i))),i) +c enddo +c write (iout,*) "nupa(0,i)",nupa(0,i)," iex",iex + if (lmuca) then + call muca_delta(remd_t_bath,remd_ene,i,iex,delta) + else +c Swap temperatures between conformations i and iex with recalculating the free energies +c following temperature changes. + ene_iex_iex=remd_ene(0,iex) + ene_i_i=remd_ene(0,i) +c write (iout,*) "i",i," ene_i_i",ene_i_i, +c & " iex",iex," ene_iex_iex",ene_iex_iex +c write (iout,*) "rescaling weights with temperature", +c & remd_t_bath(i) +c call flush(iout) + call rescale_weights(remd_t_bath(i)) + +c write (iout,*) "0,iex",remd_t_bath(i) +c call enerprint(remd_ene(0,iex)) + + call sum_energy(remd_ene(0,iex),.false.) + ene_iex_i=remd_ene(0,iex) +c write (iout,*) "ene_iex_i",remd_ene(0,iex) + +c write (iout,*) "0,i",remd_t_bath(i) +c call enerprint(remd_ene(0,i)) + + call sum_energy(remd_ene(0,i),.false.) +c write (iout,*) "ene_i_i",remd_ene(0,i) +c call flush(iout) +c write (iout,*) "rescaling weights with temperature", +c & remd_t_bath(iex) + if (abs(ene_i_i-remd_ene(0,i)).gt.ene_tol) then + write (iout,*) "ERROR: inconsistent energies:",i, + & ene_i_i,remd_ene(0,i) + endif + call rescale_weights(remd_t_bath(iex)) + +c write (iout,*) "0,i",remd_t_bath(iex) +c call enerprint(remd_ene(0,i)) + + call sum_energy(remd_ene(0,i),.false.) +c write (iout,*) "ene_i_iex",remd_ene(0,i) +c call flush(iout) + ene_i_iex=remd_ene(0,i) + +c write (iout,*) "0,iex",remd_t_bath(iex) +c call enerprint(remd_ene(0,iex)) + + call sum_energy(remd_ene(0,iex),.false.) + if (abs(ene_iex_iex-remd_ene(0,iex)).gt.ene_tol) then + write (iout,*) "ERROR: inconsistent energies:",iex, + & ene_iex_iex,remd_ene(0,iex) + endif +c write (iout,*) "ene_iex_iex",remd_ene(0,iex) +c write (iout,*) "i",i," iex",iex +c write (iout,'(4(a,e15.5))') "ene_i_i",ene_i_i, +c & " ene_i_iex",ene_i_iex, +c & " ene_iex_i",ene_iex_i," ene_iex_iex",ene_iex_iex +c call flush(iout) + delta=(ene_iex_iex-ene_i_iex)/(Rb*remd_t_bath(iex))- + & (ene_iex_i-ene_i_i)/(Rb*remd_t_bath(i)) + delta=-delta +c write(iout,*) 'delta',delta +c delta=(remd_t_bath(i)-remd_t_bath(iex))* +c & (remd_ene(i)-remd_ene(iex))/Rb/ +c & (remd_t_bath(i)*remd_t_bath(iex)) + endif + if (delta .gt. 50.0d0) then + delta=0.0d0 + else +#ifdef OSF + if(isnan(delta))then + delta=0.0d0 + else if (delta.lt.-50.0d0) then + delta=dexp(50.0d0) + else + delta=dexp(-delta) + endif +#else + delta=dexp(-delta) +#endif + endif + iremd_tot(int(i2rep(i-1)))=iremd_tot(int(i2rep(i-1)))+1 + xxx=ran_number(0.0d0,1.0d0) +c write(iout,'(2i4,a6,2f12.5)') i,iex,' delta',delta,xxx +c call flush(iout) + if (delta .gt. xxx) then + tmp=remd_t_bath(i) + remd_t_bath(i)=remd_t_bath(iex) + remd_t_bath(iex)=tmp + remd_ene(0,i)=ene_i_iex + remd_ene(0,iex)=ene_iex_i + if(lmuca) then + tmp=elowi(i) + elowi(i)=elowi(iex) + elowi(iex)=tmp + tmp=ehighi(i) + ehighi(i)=ehighi(iex) + ehighi(iex)=tmp + endif + + + do k=0,nodes + itmp=nupa(k,i) + nupa(k,i)=nupa(k,iex) + nupa(k,iex)=itmp + itmp=ndowna(k,i) + ndowna(k,i)=ndowna(k,iex) + ndowna(k,iex)=itmp + enddo + do il=1,nodes + if (ifirst(il).eq.i) ifirst(il)=iex + do k=1,nupa(0,il) + if (nupa(k,il).eq.i) then + nupa(k,il)=iex + elseif (nupa(k,il).eq.iex) then + nupa(k,il)=i + endif + enddo + do k=1,ndowna(0,il) + if (ndowna(k,il).eq.i) then + ndowna(k,il)=iex + elseif (ndowna(k,il).eq.iex) then + ndowna(k,il)=i + endif + enddo + enddo + + iremd_acc(int(i2rep(i-1)))=iremd_acc(int(i2rep(i-1)))+1 + itmp=i2rep(i-1) + i2rep(i-1)=i2rep(iex-1) + i2rep(iex-1)=itmp + +c write(iout,*) 'exchange',i,iex +c write (iout,'(a8,100i4)') "@ ifirst", +c & (ifirst(k),k=1,remd_m(1)) +c do il=1,nodes +c write (iout,'(a8,i4,a1,100i4)') "@ nupa",il,":", +c & (nupa(k,il),k=1,nupa(0,il)) +c write (iout,'(a8,i4,a1,100i4)') "@ ndowna",il,":", +c & (ndowna(k,il),k=1,ndowna(0,il)) +c enddo +c call flush(iout) + + else + remd_ene(0,iex)=ene_iex_iex + remd_ene(0,i)=ene_i_i + i=iex + endif + endif + enddo + enddo +cd write (iout,*) "exchange completed" +cd call flush(iout) + ELSEIF (usampl) THEN + do ii=1,nodes +cd write(iout,*) "########",ii + + i_temp=iran_num(1,nrep) + i_mult=iran_num(1,remd_m(i_temp)) + i_iset=iran_num(1,nset) + i_mset=iran_num(1,mset(i_iset)) + i=i_index(i_temp,i_mult,i_iset,i_mset) + +cd write(iout,*) "i=",i,i_temp,i_mult,i_iset,i_mset + + if(t_exchange_only)then + i_dir=1 + else + i_dir=iran_num(1,3) + endif +cd write(iout,*) "i_dir=",i_dir + + if(i_dir.eq.1 .and. remd_m(i_temp+1).gt.0 )then + + i_temp1=i_temp+1 + i_mult1=iran_num(1,remd_m(i_temp1)) + i_iset1=i_iset + i_mset1=iran_num(1,mset(i_iset1)) + iex=i_index(i_temp1,i_mult1,i_iset1,i_mset1) + + elseif(i_dir.eq.2 .and. mset(i_iset+1).gt.0)then + + i_temp1=i_temp + i_mult1=iran_num(1,remd_m(i_temp1)) + i_iset1=i_iset+1 + i_mset1=iran_num(1,mset(i_iset1)) + iex=i_index(i_temp1,i_mult1,i_iset1,i_mset1) + econstr_temp_i=remd_ene(20,i) + econstr_temp_iex=remd_ene(20,iex) + remd_ene(20,i)=remd_ene(n_ene+3,i) + remd_ene(20,iex)=remd_ene(n_ene+4,iex) + + elseif(remd_m(i_temp+1).gt.0.and.mset(i_iset+1).gt.0)then + + i_temp1=i_temp+1 + i_mult1=iran_num(1,remd_m(i_temp1)) + i_iset1=i_iset+1 + i_mset1=iran_num(1,mset(i_iset1)) + iex=i_index(i_temp1,i_mult1,i_iset1,i_mset1) + econstr_temp_i=remd_ene(20,i) + econstr_temp_iex=remd_ene(20,iex) + remd_ene(20,i)=remd_ene(n_ene+3,i) + remd_ene(20,iex)=remd_ene(n_ene+4,iex) + + else + goto 444 + endif + +cd write(iout,*) "iex=",iex,i_temp1,i_mult1,i_iset1,i_mset1 +ctime call flush(iout) + +c Swap temperatures between conformations i and iex with recalculating the free energies +c following temperature changes. + ene_iex_iex=remd_ene(0,iex) + ene_i_i=remd_ene(0,i) +co write (iout,*) "rescaling weights with temperature", +co & remd_t_bath(i) + call rescale_weights(remd_t_bath(i)) + + call sum_energy(remd_ene(0,iex),.false.) + ene_iex_i=remd_ene(0,iex) +cd write (iout,*) "ene_iex_i",remd_ene(0,iex) +c call sum_energy(remd_ene(0,i),.false.) +cd write (iout,*) "ene_i_i",remd_ene(0,i) +c write (iout,*) "rescaling weights with temperature", +c & remd_t_bath(iex) +c if (real(ene_i_i).ne.real(remd_ene(0,i))) then +c write (iout,*) "ERROR: inconsistent energies:",i, +c & ene_i_i,remd_ene(0,i) +c endif + call rescale_weights(remd_t_bath(iex)) + call sum_energy(remd_ene(0,i),.false.) +cd write (iout,*) "ene_i_iex",remd_ene(0,i) + ene_i_iex=remd_ene(0,i) +c call sum_energy(remd_ene(0,iex),.false.) +c if (real(ene_iex_iex).ne.real(remd_ene(0,iex))) then +c write (iout,*) "ERROR: inconsistent energies:",iex, +c & ene_iex_iex,remd_ene(0,iex) +c endif +cd write (iout,*) "ene_iex_iex",remd_ene(0,iex) +c write (iout,*) "i",i," iex",iex +cd write (iout,'(4(a,e15.5))') "ene_i_i",ene_i_i, +cd & " ene_i_iex",ene_i_iex, +cd & " ene_iex_i",ene_iex_i," ene_iex_iex",ene_iex_iex + delta=(ene_iex_iex-ene_i_iex)/(Rb*remd_t_bath(iex))- + & (ene_iex_i-ene_i_i)/(Rb*remd_t_bath(i)) + delta=-delta +cd write(iout,*) 'delta',delta +c delta=(remd_t_bath(i)-remd_t_bath(iex))* +c & (remd_ene(i)-remd_ene(iex))/Rb/ +c & (remd_t_bath(i)*remd_t_bath(iex)) + if (delta .gt. 50.0d0) then + delta=0.0d0 + else + delta=dexp(-delta) + endif + if (i_dir.eq.1.or.i_dir.eq.3) + & iremd_tot(int(i2rep(i-1)))=iremd_tot(int(i2rep(i-1)))+1 + if (i_dir.eq.2.or.i_dir.eq.3) + & iremd_tot_usa(int(i2set(i-1)))= + & iremd_tot_usa(int(i2set(i-1)))+1 + xxx=ran_number(0.0d0,1.0d0) +cd write(iout,'(2i4,a6,2f12.5)') i,iex,' delta',delta,xxx + if (delta .gt. xxx) then + tmp=remd_t_bath(i) + remd_t_bath(i)=remd_t_bath(iex) + remd_t_bath(iex)=tmp + + itmp=iremd_iset(i) + iremd_iset(i)=iremd_iset(iex) + iremd_iset(iex)=itmp + + remd_ene(0,i)=ene_i_iex + remd_ene(0,iex)=ene_iex_i + + if (i_dir.eq.1.or.i_dir.eq.3) + & iremd_acc(int(i2rep(i-1)))=iremd_acc(int(i2rep(i-1)))+1 + + itmp=i2rep(i-1) + i2rep(i-1)=i2rep(iex-1) + i2rep(iex-1)=itmp + + if (i_dir.eq.2.or.i_dir.eq.3) + & iremd_acc_usa(int(i2set(i-1)))= + & iremd_acc_usa(int(i2set(i-1)))+1 + + itmp=i2set(i-1) + i2set(i-1)=i2set(iex-1) + i2set(iex-1)=itmp + + itmp=i_index(i_temp,i_mult,i_iset,i_mset) + i_index(i_temp,i_mult,i_iset,i_mset)= + & i_index(i_temp1,i_mult1,i_iset1,i_mset1) + i_index(i_temp1,i_mult1,i_iset1,i_mset1)=itmp + + else + remd_ene(0,iex)=ene_iex_iex + remd_ene(0,i)=ene_i_i + remd_ene(20,iex)=econstr_temp_iex + remd_ene(20,i)=econstr_temp_i + endif + +cd do il=1,nset +cd do il1=1,mset(il) +cd do i=1,nrep +cd do j=1,remd_m(i) +cd write(iout,*) i,j,il,il1,i_index(i,j,il,il1) +cd enddo +cd enddo +cd enddo +cd enddo + + 444 continue + + enddo + + ELSEIF (hremd.gt.0) THEN + do ii=1,nodes +cd write(iout,*) "########",ii + + i_temp=iran_num(1,nrep) + i_mult=iran_num(1,remd_m(i_temp)) + i_iset=iran_num(1,nset) + i_mset=1 + i=i_index(i_temp,i_mult,i_iset,i_mset) + +cd write(iout,*) "i=",i,i_temp,i_mult,i_iset,i_mset + + if(t_exchange_only)then + i_dir=1 + else + i_dir=iran_num(1,3) + endif + +cd write(iout,*) "i_dir=",i_dir + + if(i_dir.eq.1 .and. remd_m(i_temp+1).gt.0 )then + + i_temp1=i_temp+1 + i_mult1=iran_num(1,remd_m(i_temp1)) + i_iset1=i_iset + i_mset1=1 + iex=i_index(i_temp1,i_mult1,i_iset1,i_mset1) + + elseif(i_dir.eq.2)then + + i_temp1=i_temp + i_mult1=iran_num(1,remd_m(i_temp1)) + i_iset1=iran_num(1,hremd) + do while(i_iset1.eq.i_iset) + i_iset1=iran_num(1,hremd) + enddo + i_mset1=1 + iex=i_index(i_temp1,i_mult1,i_iset1,i_mset1) + + elseif(remd_m(i_temp+1).gt.0)then + + i_temp1=i_temp+1 + i_mult1=iran_num(1,remd_m(i_temp1)) + i_iset1=iran_num(1,hremd) + do while(i_iset1.eq.i_iset) + i_iset1=iran_num(1,hremd) + enddo + i_mset1=1 + iex=i_index(i_temp1,i_mult1,i_iset1,i_mset1) + + else + goto 445 + endif + +cd write(iout,*) "iex=",iex,i_temp1,i_mult1,i_iset1,i_mset1 +ctime call flush(iout) + +c Swap temperatures between conformations i and iex with recalculating the free energies +c following temperature changes. + ene_iex_iex=remd_ene(0,iex) + ene_i_i=remd_ene(0,i) + + call set_hweights(i_iset) + call rescale_weights(remd_t_bath(i)) + call sum_energy(remd_ene(0,iex),.false.) + ene_iex_i=remd_ene(0,iex) + + call set_hweights(i_iset1) + call rescale_weights(remd_t_bath(iex)) + call sum_energy(remd_ene(0,i),.false.) + ene_i_iex=remd_ene(0,i) + +cd write(iout,*) ene_iex_iex,ene_i_i,ene_iex_i,ene_i_iex + + delta=(ene_iex_iex-ene_i_iex)/(Rb*remd_t_bath(iex))- + & (ene_iex_i-ene_i_i)/(Rb*remd_t_bath(i)) + delta=-delta + + if (delta .gt. 50.0d0) then + delta=0.0d0 + else + delta=dexp(-delta) + endif + + if (i_dir.eq.1.or.i_dir.eq.3) + & iremd_tot(int(i2rep(i-1)))=iremd_tot(int(i2rep(i-1)))+1 + if (i_dir.eq.2.or.i_dir.eq.3) + & iremd_tot_usa(int(i2set(i-1)))= + & iremd_tot_usa(int(i2set(i-1)))+1 + xxx=ran_number(0.0d0,1.0d0) +cd write(iout,'(2i4,a6,2f12.5)') i,iex,' delta',delta,xxx + if (delta .gt. xxx) then + +cd write (iout,*) "exchange" + tmp=remd_t_bath(i) + remd_t_bath(i)=remd_t_bath(iex) + remd_t_bath(iex)=tmp + + itmp=iremd_iset(i) + iremd_iset(i)=iremd_iset(iex) + iremd_iset(iex)=itmp + + remd_ene(0,i)=ene_i_iex + remd_ene(0,iex)=ene_iex_i + + if (i_dir.eq.1.or.i_dir.eq.3) + & iremd_acc(int(i2rep(i-1)))=iremd_acc(int(i2rep(i-1)))+1 + + itmp=i2rep(i-1) + i2rep(i-1)=i2rep(iex-1) + i2rep(iex-1)=itmp + + if (i_dir.eq.2.or.i_dir.eq.3) + & iremd_acc_usa(int(i2set(i-1)))= + & iremd_acc_usa(int(i2set(i-1)))+1 + + itmp=i2set(i-1) + i2set(i-1)=i2set(iex-1) + i2set(iex-1)=itmp + + itmp=i_index(i_temp,i_mult,i_iset,i_mset) + i_index(i_temp,i_mult,i_iset,i_mset)= + & i_index(i_temp1,i_mult1,i_iset1,i_mset1) + i_index(i_temp1,i_mult1,i_iset1,i_mset1)=itmp + +cd do il=1,nset +cd do il1=1,mset(il) +cd do i=1,nrep +cd do j=1,remd_m(i) +cd write(iout,*) i,j,il,il1,i_index(i,j,il,il1) +cd enddo +cd enddo +cd enddo +cd enddo + + else + remd_ene(0,iex)=ene_iex_iex + remd_ene(0,i)=ene_i_i + endif + + + + 445 continue + + enddo + + ENDIF + +c------------------------------------- + write (iout,*) "NREP",nrep + do i=1,nrep + if(iremd_tot(i).ne.0) + & write(iout,'(a3,i4,2f12.5,i5)') 'ACC',i,remd_t(i) + & ,iremd_acc(i)/(1.0*iremd_tot(i)),iremd_tot(i) + enddo + + if(usampl) then + do i=1,nset + if(iremd_tot_usa(i).ne.0) + & write(iout,'(a10,i4,f12.5,i8)') 'ACC_usampl',i, + & iremd_acc_usa(i)/(1.0*iremd_tot_usa(i)),iremd_tot_usa(i) + enddo + endif + + if(hremd.gt.0) then + do i=1,nset + if(iremd_tot_usa(i).ne.0) + & write(iout,'(a10,i4,f12.5,i8)') 'ACC_hremd',i, + & iremd_acc_usa(i)/(1.0*iremd_tot_usa(i)),iremd_tot_usa(i) + enddo + endif + + +ctime call flush(iout) + +cd write (iout,'(a6,100i4)') "ifirst", +cd & (ifirst(i),i=1,remd_m(1)) +cd do il=1,nodes +cd write (iout,'(a5,i4,a1,100i4)') "nup",il,":", +cd & (nupa(i,il),i=1,nupa(0,il)) +cd write (iout,'(a5,i4,a1,100i4)') "ndown",il,":", +cd & (ndowna(i,il),i=1,ndowna(0,il)) +cd enddo + endif + + time06=MPI_WTIME() +cd write (iout,*) "Before scatter" +cd call flush(iout) + call mpi_scatter(remd_t_bath,1,mpi_double_precision, + & t_bath,1,mpi_double_precision,king, + & CG_COMM,ierr) +cd write (iout,*) "After scatter" +cd call flush(iout) + if(usampl.or.hremd.gt.0) + & call mpi_scatter(iremd_iset,1,mpi_integer, + & iset,1,mpi_integer,king, + & CG_COMM,ierr) + + time07=MPI_WTIME() + if (me.eq.king .or. .not. out1file) then + write(iout,*) 'REMD scatter time=',time07-time06 + endif + + if(lmuca) then + call mpi_scatter(elowi,1,mpi_double_precision, + & elow,1,mpi_double_precision,king, + & CG_COMM,ierr) + call mpi_scatter(ehighi,1,mpi_double_precision, + & ehigh,1,mpi_double_precision,king, + & CG_COMM,ierr) + endif + + if(hremd.gt.0) call set_hweights(iset) + call rescale_weights(t_bath) +co write (iout,*) "Processor",me, +co & " rescaling weights with temperature",t_bath + + stdfp=dsqrt(2*Rb*t_bath/d_time) + do i=1,ntyp + stdfsc(i)=dsqrt(2*Rb*t_bath/d_time) + enddo + if (lang.gt.0) then + do i=nnt,nct-1 + stdforcp(i)=stdforcp(i)*sqrt(t_bath/t_bath_old) + enddo + do i=nnt,nct + stdforcsc(i)=stdforcsc(i)*sqrt(t_bath/t_bath_old) + enddo + endif +cde write(iout,*) 'REMD after',me,t_bath + time08=MPI_WTIME() + if (me.eq.king .or. .not. out1file) then + write(iout,*) 'REMD exchange time=',time08-time02 +ctime call flush(iout) + endif + endif + enddo + + if (restart1file) then + if (me.eq.king .or. .not. out1file) + & write(iout,*) 'writing restart at the end of run' + call write1rst(i_index) + endif + + if (traj1file) call write1traj +cd debugging +cdeb call mpi_gather(ntwx_cache,1,mpi_integer, +cdeb & icache_all,1,mpi_integer,king, +cdeb & CG_COMM,ierr) +cdeb write(iout,'(a40,8000i8)') +cdeb & ' ntwx_cache after traj1file at the end', +cdeb & (icache_all(i),i=1,nodes) +cd end + + +#ifdef MPI + t_MD=MPI_Wtime()-tt0 +#else + t_MD=tcpu()-tt0 +#endif + if (me.eq.king .or. .not. out1file) then + write (iout,'(//35(1h=),a10,35(1h=)/10(/a40,1pe15.5))') + & ' Timing ', + & 'MD calculations setup:',t_MDsetup, + & 'Energy & gradient evaluation:',t_enegrad, + & 'Stochastic MD setup:',t_langsetup, + & 'Stochastic MD step setup:',t_sdsetup, + & 'MD steps:',t_MD + write (iout,'(/28(1h=),a25,27(1h=))') + & ' End of MD calculation ' + if(hmc.gt.0) write (iout,*) 'HMC acceptance ratio', + & n_timestep*1.0d0/hmc/hmc_acc + endif + return + end + +c----------------------------------------------------------------------- + subroutine write1rst(i_index) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'mpif.h' + include 'COMMON.MD' + include 'COMMON.IOUNITS' + include 'COMMON.REMD' + include 'COMMON.SETUP' + include 'COMMON.CHAIN' + include 'COMMON.SBRIDGE' + include 'COMMON.INTERACT' + + real d_restart1(3,2*maxres*maxprocs),r_d(3,2*maxres), + & d_restart2(3,2*maxres*maxprocs) + real t5_restart1(5) + integer iret,itmp + integer*2 i_index + & (maxprocs/4,maxprocs/20,maxprocs/200,maxprocs/200) + common /przechowalnia/ d_restart1,d_restart2 + + t5_restart1(1)=totT + t5_restart1(2)=EK + t5_restart1(3)=potE + t5_restart1(4)=t_bath + t5_restart1(5)=Uconst + + call mpi_gather(t5_restart1,5,mpi_real, + & t_restart1,5,mpi_real,king,CG_COMM,ierr) + + + do i=1,2*nres + do j=1,3 + r_d(j,i)=d_t(j,i) + enddo + enddo + call mpi_gather(r_d,3*2*nres,mpi_real, + & d_restart1,3*2*nres,mpi_real,king, + & CG_COMM,ierr) + + + do i=1,2*nres + do j=1,3 + r_d(j,i)=dc(j,i) + enddo + enddo + call mpi_gather(r_d,3*2*nres,mpi_real, + & d_restart2,3*2*nres,mpi_real,king, + & CG_COMM,ierr) + + if(me.eq.king) then +#ifdef AIX + call xdrfopen_(ixdrf,mremd_rst_name, "w", iret) + do i=0,nodes-1 + call xdrfint_(ixdrf, i2rep(i), iret) + enddo + do i=1,remd_m(1) + call xdrfint_(ixdrf, ifirst(i), iret) + enddo + do il=1,nodes + do i=0,nupa(0,il) + call xdrfint_(ixdrf, nupa(i,il), iret) + enddo + + do i=0,ndowna(0,il) + call xdrfint_(ixdrf, ndowna(i,il), iret) + enddo + enddo + + do il=1,nodes + do j=1,4 + call xdrffloat_(ixdrf, t_restart1(j,il), iret) + enddo + enddo + + do il=0,nodes-1 + do i=1,2*nres + do j=1,3 + call xdrffloat_(ixdrf, d_restart1(j,i+2*nres*il), iret) + enddo + enddo + enddo + do il=0,nodes-1 + do i=1,2*nres + do j=1,3 + call xdrffloat_(ixdrf, d_restart2(j,i+2*nres*il), iret) + enddo + enddo + enddo + + if(usampl) then + call xdrfint_(ixdrf, nset, iret) + do i=1,nset + call xdrfint_(ixdrf,mset(i), iret) + enddo + do i=0,nodes-1 + call xdrfint_(ixdrf,i2set(i), iret) + enddo + do il=1,nset + do il1=1,mset(il) + do i=1,nrep + do j=1,remd_m(i) + itmp=i_index(i,j,il,il1) + call xdrfint_(ixdrf,itmp, iret) + enddo + enddo + enddo + enddo + + endif + call xdrfclose_(ixdrf, iret) +#else + call xdrfopen(ixdrf,mremd_rst_name, "w", iret) + do i=0,nodes-1 + call xdrfint(ixdrf, i2rep(i), iret) + enddo + do i=1,remd_m(1) + call xdrfint(ixdrf, ifirst(i), iret) + enddo + do il=1,nodes + do i=0,nupa(0,il) + call xdrfint(ixdrf, nupa(i,il), iret) + enddo + + do i=0,ndowna(0,il) + call xdrfint(ixdrf, ndowna(i,il), iret) + enddo + enddo + + do il=1,nodes + do j=1,4 + call xdrffloat(ixdrf, t_restart1(j,il), iret) + enddo + enddo + + do il=0,nodes-1 + do i=1,2*nres + do j=1,3 + call xdrffloat(ixdrf, d_restart1(j,i+2*nres*il), iret) + enddo + enddo + enddo + do il=0,nodes-1 + do i=1,2*nres + do j=1,3 + call xdrffloat(ixdrf, d_restart2(j,i+2*nres*il), iret) + enddo + enddo + enddo + + + if(usampl) then + call xdrfint(ixdrf, nset, iret) + do i=1,nset + call xdrfint(ixdrf,mset(i), iret) + enddo + do i=0,nodes-1 + call xdrfint(ixdrf,i2set(i), iret) + enddo + do il=1,nset + do il1=1,mset(il) + do i=1,nrep + do j=1,remd_m(i) + itmp=i_index(i,j,il,il1) + call xdrfint(ixdrf,itmp, iret) + enddo + enddo + enddo + enddo + + endif + call xdrfclose(ixdrf, iret) +#endif + endif + return + end + + + subroutine write1traj + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'mpif.h' + include 'COMMON.MD' + include 'COMMON.IOUNITS' + include 'COMMON.REMD' + include 'COMMON.SETUP' + include 'COMMON.CHAIN' + include 'COMMON.SBRIDGE' + include 'COMMON.INTERACT' + + real t5_restart1(5) + integer iret,itmp + real xcoord(3,maxres2+2),prec + real r_qfrag(50),r_qpair(100) + real r_utheta(50),r_ugamma(100),r_uscdiff(100) + real p_qfrag(50*maxprocs),p_qpair(100*maxprocs) + real p_utheta(50*maxprocs),p_ugamma(100*maxprocs), + & p_uscdiff(100*maxprocs) + real p_c(3,(maxres2+2)*maxprocs),r_c(3,maxres2+2) + common /przechowalnia/ p_c + + call mpi_bcast(ii_write,1,mpi_integer, + & king,CG_COMM,ierr) + +c debugging + print *,'traj1file',me,ii_write,ntwx_cache +c end debugging + +#ifdef AIX + if(me.eq.king) call xdrfopen_(ixdrf,cartname, "a", iret) +#else + if(me.eq.king) call xdrfopen(ixdrf,cartname, "a", iret) +#endif + do ii=1,ii_write + t5_restart1(1)=totT_cache(ii) + t5_restart1(2)=EK_cache(ii) + t5_restart1(3)=potE_cache(ii) + t5_restart1(4)=t_bath_cache(ii) + t5_restart1(5)=Uconst_cache(ii) + call mpi_gather(t5_restart1,5,mpi_real, + & t_restart1,5,mpi_real,king,CG_COMM,ierr) + + call mpi_gather(iset_cache(ii),1,mpi_integer, + & iset_restart1,1,mpi_integer,king,CG_COMM,ierr) + + do i=1,nfrag + r_qfrag(i)=qfrag_cache(i,ii) + enddo + do i=1,npair + r_qpair(i)=qpair_cache(i,ii) + enddo + do i=1,nfrag_back + r_utheta(i)=utheta_cache(i,ii) + r_ugamma(i)=ugamma_cache(i,ii) + r_uscdiff(i)=uscdiff_cache(i,ii) + enddo + + call mpi_gather(r_qfrag,nfrag,mpi_real, + & p_qfrag,nfrag,mpi_real,king, + & CG_COMM,ierr) + call mpi_gather(r_qpair,npair,mpi_real, + & p_qpair,npair,mpi_real,king, + & CG_COMM,ierr) + call mpi_gather(r_utheta,nfrag_back,mpi_real, + & p_utheta,nfrag_back,mpi_real,king, + & CG_COMM,ierr) + call mpi_gather(r_ugamma,nfrag_back,mpi_real, + & p_ugamma,nfrag_back,mpi_real,king, + & CG_COMM,ierr) + call mpi_gather(r_uscdiff,nfrag_back,mpi_real, + & p_uscdiff,nfrag_back,mpi_real,king, + & CG_COMM,ierr) + +#ifdef DEBUG + write (iout,*) "p_qfrag" + do i=1,nodes + write (iout,*) i,(p_qfrag((i-1)*nfrag+j),j=1,nfrag) + enddo + write (iout,*) "p_qpair" + do i=1,nodes + write (iout,*) i,(p_qpair((i-1)*npair+j),j=1,npair) + enddo +ctime call flush(iout) +#endif + do i=1,nres*2 + do j=1,3 + r_c(j,i)=c_cache(j,i,ii) + enddo + enddo + + call mpi_gather(r_c,3*2*nres,mpi_real, + & p_c,3*2*nres,mpi_real,king, + & CG_COMM,ierr) + + if(me.eq.king) then +#ifdef AIX + do il=1,nodes + call xdrffloat_(ixdrf, real(t_restart1(1,il)), iret) + call xdrffloat_(ixdrf, real(t_restart1(3,il)), iret) + call xdrffloat_(ixdrf, real(t_restart1(5,il)), iret) + call xdrffloat_(ixdrf, real(t_restart1(4,il)), iret) + call xdrfint_(ixdrf, nss, iret) + do j=1,nss + if (dyn_ss) then + call xdrfint_(ixdrf, idssb(j)+nres, iret) + call xdrfint_(ixdrf, jdssb(j)+nres, iret) + else + call xdrfint_(ixdrf, ihpb(j), iret) + call xdrfint_(ixdrf, jhpb(j), iret) + endif + enddo + call xdrfint_(ixdrf, nfrag+npair+3*nfrag_back, iret) + call xdrfint_(ixdrf, iset_restart1(il), iret) + do i=1,nfrag + call xdrffloat_(ixdrf, p_qfrag(i+(il-1)*nfrag), iret) + enddo + do i=1,npair + call xdrffloat_(ixdrf, p_qpair(i+(il-1)*npair), iret) + enddo + do i=1,nfrag_back + call xdrffloat_(ixdrf, p_utheta(i+(il-1)*nfrag_back), iret) + call xdrffloat_(ixdrf, p_ugamma(i+(il-1)*nfrag_back), iret) + call xdrffloat_(ixdrf, p_uscdiff(i+(il-1)*nfrag_back), iret) + enddo + prec=10000.0 + do i=1,nres + do j=1,3 + xcoord(j,i)=p_c(j,i+(il-1)*nres*2) + enddo + enddo + do i=nnt,nct + do j=1,3 + xcoord(j,nres+i-nnt+1)=p_c(j,i+nres+(il-1)*nres*2) + enddo + enddo + itmp=nres+nct-nnt+1 + call xdrf3dfcoord_(ixdrf, xcoord, itmp, prec, iret) + enddo +#else + do il=1,nodes + call xdrffloat(ixdrf, real(t_restart1(1,il)), iret) + call xdrffloat(ixdrf, real(t_restart1(3,il)), iret) + call xdrffloat(ixdrf, real(t_restart1(5,il)), iret) + call xdrffloat(ixdrf, real(t_restart1(4,il)), iret) + call xdrfint(ixdrf, nss, iret) + do j=1,nss + if (dyn_ss) then + call xdrfint(ixdrf, idssb(j)+nres, iret) + call xdrfint(ixdrf, jdssb(j)+nres, iret) + else + call xdrfint(ixdrf, ihpb(j), iret) + call xdrfint(ixdrf, jhpb(j), iret) + endif + enddo + call xdrfint(ixdrf, nfrag+npair+3*nfrag_back, iret) + call xdrfint(ixdrf, iset_restart1(il), iret) + do i=1,nfrag + call xdrffloat(ixdrf, p_qfrag(i+(il-1)*nfrag), iret) + enddo + do i=1,npair + call xdrffloat(ixdrf, p_qpair(i+(il-1)*npair), iret) + enddo + do i=1,nfrag_back + call xdrffloat(ixdrf, p_utheta(i+(il-1)*nfrag_back), iret) + call xdrffloat(ixdrf, p_ugamma(i+(il-1)*nfrag_back), iret) + call xdrffloat(ixdrf, p_uscdiff(i+(il-1)*nfrag_back), iret) + enddo + prec=10000.0 + do i=1,nres + do j=1,3 + xcoord(j,i)=p_c(j,i+(il-1)*nres*2) + enddo + enddo + do i=nnt,nct + do j=1,3 + xcoord(j,nres+i-nnt+1)=p_c(j,i+nres+(il-1)*nres*2) + enddo + enddo + itmp=nres+nct-nnt+1 + call xdrf3dfcoord(ixdrf, xcoord, itmp, prec, iret) + enddo +#endif + endif + enddo +#ifdef AIX + if(me.eq.king) call xdrfclose_(ixdrf, iret) +#else + if(me.eq.king) call xdrfclose(ixdrf, iret) +#endif + do i=1,ntwx_cache-ii_write + + totT_cache(i)=totT_cache(ii_write+i) + EK_cache(i)=EK_cache(ii_write+i) + potE_cache(i)=potE_cache(ii_write+i) + t_bath_cache(i)=t_bath_cache(ii_write+i) + Uconst_cache(i)=Uconst_cache(ii_write+i) + iset_cache(i)=iset_cache(ii_write+i) + + do ii=1,nfrag + qfrag_cache(ii,i)=qfrag_cache(ii,ii_write+i) + enddo + do ii=1,npair + qpair_cache(ii,i)=qpair_cache(ii,ii_write+i) + enddo + do ii=1,nfrag_back + utheta_cache(ii,i)=utheta_cache(ii,ii_write+i) + ugamma_cache(ii,i)=ugamma_cache(ii,ii_write+i) + uscdiff_cache(ii,i)=uscdiff_cache(ii,ii_write+i) + enddo + + do ii=1,nres*2 + do j=1,3 + c_cache(j,ii,i)=c_cache(j,ii,ii_write+i) + enddo + enddo + enddo + ntwx_cache=ntwx_cache-ii_write + return + end + + + subroutine read1restart(i_index) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'mpif.h' + include 'COMMON.MD' + include 'COMMON.IOUNITS' + include 'COMMON.REMD' + include 'COMMON.SETUP' + include 'COMMON.CHAIN' + include 'COMMON.SBRIDGE' + include 'COMMON.INTERACT' + real d_restart1(3,2*maxres*maxprocs),r_d(3,2*maxres), + & t5_restart1(5) + integer*2 i_index + & (maxprocs/4,maxprocs/20,maxprocs/200,maxprocs/200) + common /przechowalnia/ d_restart1 + write (*,*) "Processor",me," called read1restart" + + if(me.eq.king)then + open(irest2,file=mremd_rst_name,status='unknown') + read(irest2,*,err=334) i + write(iout,*) "Reading old rst in ASCI format" + close(irest2) + call read1restart_old + return + 334 continue +#ifdef AIX + call xdrfopen_(ixdrf,mremd_rst_name, "r", iret) + + do i=0,nodes-1 + call xdrfint_(ixdrf, i2rep(i), iret) + enddo + do i=1,remd_m(1) + call xdrfint_(ixdrf, ifirst(i), iret) + enddo + do il=1,nodes + call xdrfint_(ixdrf, nupa(0,il), iret) + do i=1,nupa(0,il) + call xdrfint_(ixdrf, nupa(i,il), iret) + enddo + + call xdrfint_(ixdrf, ndowna(0,il), iret) + do i=1,ndowna(0,il) + call xdrfint_(ixdrf, ndowna(i,il), iret) + enddo + enddo + do il=1,nodes + do j=1,4 + call xdrffloat_(ixdrf, t_restart1(j,il), iret) + enddo + enddo +#else + call xdrfopen(ixdrf,mremd_rst_name, "r", iret) + + do i=0,nodes-1 + call xdrfint(ixdrf, i2rep(i), iret) + enddo + do i=1,remd_m(1) + call xdrfint(ixdrf, ifirst(i), iret) + enddo + do il=1,nodes + call xdrfint(ixdrf, nupa(0,il), iret) + do i=1,nupa(0,il) + call xdrfint(ixdrf, nupa(i,il), iret) + enddo + + call xdrfint(ixdrf, ndowna(0,il), iret) + do i=1,ndowna(0,il) + call xdrfint(ixdrf, ndowna(i,il), iret) + enddo + enddo + do il=1,nodes + do j=1,4 + call xdrffloat(ixdrf, t_restart1(j,il), iret) + enddo + enddo +#endif + endif + call mpi_scatter(t_restart1,5,mpi_real, + & t5_restart1,5,mpi_real,king,CG_COMM,ierr) + totT=t5_restart1(1) + EK=t5_restart1(2) + potE=t5_restart1(3) + t_bath=t5_restart1(4) + + if(me.eq.king)then + do il=0,nodes-1 + do i=1,2*nres +c read(irest2,'(3e15.5)') +c & (d_restart1(j,i+2*nres*il),j=1,3) + do j=1,3 +#ifdef AIX + call xdrffloat_(ixdrf, d_restart1(j,i+2*nres*il), iret) +#else + call xdrffloat(ixdrf, d_restart1(j,i+2*nres*il), iret) +#endif + enddo + enddo + enddo + endif + call mpi_scatter(d_restart1,3*2*nres,mpi_real, + & r_d,3*2*nres,mpi_real,king,CG_COMM,ierr) + + do i=1,2*nres + do j=1,3 + d_t(j,i)=r_d(j,i) + enddo + enddo + if(me.eq.king)then + do il=0,nodes-1 + do i=1,2*nres +c read(irest2,'(3e15.5)') +c & (d_restart1(j,i+2*nres*il),j=1,3) + do j=1,3 +#ifdef AIX + call xdrffloat_(ixdrf, d_restart1(j,i+2*nres*il), iret) +#else + call xdrffloat(ixdrf, d_restart1(j,i+2*nres*il), iret) +#endif + enddo + enddo + enddo + endif + call mpi_scatter(d_restart1,3*2*nres,mpi_real, + & r_d,3*2*nres,mpi_real,king,CG_COMM,ierr) + do i=1,2*nres + do j=1,3 + dc(j,i)=r_d(j,i) + enddo + enddo + + + if(usampl) then +#ifdef AIX + if(me.eq.king)then + call xdrfint_(ixdrf, nset, iret) + do i=1,nset + call xdrfint_(ixdrf,mset(i), iret) + enddo + do i=0,nodes-1 + call xdrfint_(ixdrf,i2set(i), iret) + enddo + do il=1,nset + do il1=1,mset(il) + do i=1,nrep + do j=1,remd_m(i) + call xdrfint_(ixdrf,itmp, iret) + i_index(i,j,il,il1)=itmp + enddo + enddo + enddo + enddo + endif +#else + if(me.eq.king)then + call xdrfint(ixdrf, nset, iret) + do i=1,nset + call xdrfint(ixdrf,mset(i), iret) + enddo + do i=0,nodes-1 + call xdrfint(ixdrf,i2set(i), iret) + enddo + do il=1,nset + do il1=1,mset(il) + do i=1,nrep + do j=1,remd_m(i) + call xdrfint(ixdrf,itmp, iret) + i_index(i,j,il,il1)=itmp + enddo + enddo + enddo + enddo + endif +#endif + call mpi_scatter(i2set,1,mpi_integer, + & iset,1,mpi_integer,king, + & CG_COMM,ierr) + + endif + + + if(me.eq.king) close(irest2) + return + end + + subroutine read1restart_old + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'mpif.h' + include 'COMMON.MD' + include 'COMMON.IOUNITS' + include 'COMMON.REMD' + include 'COMMON.SETUP' + include 'COMMON.CHAIN' + include 'COMMON.SBRIDGE' + include 'COMMON.INTERACT' + real d_restart1(3,2*maxres*maxprocs),r_d(3,2*maxres), + & t5_restart1(5) + common /przechowalnia/ d_restart1 + if(me.eq.king)then + open(irest2,file=mremd_rst_name,status='unknown') + read (irest2,*) (i2rep(i),i=0,nodes-1) + read (irest2,*) (ifirst(i),i=1,remd_m(1)) + do il=1,nodes + read (irest2,*) nupa(0,il),(nupa(i,il),i=1,nupa(0,il)) + read (irest2,*) ndowna(0,il), + & (ndowna(i,il),i=1,ndowna(0,il)) + enddo + do il=1,nodes + read(irest2,*) (t_restart1(j,il),j=1,4) + enddo + endif + call mpi_scatter(t_restart1,5,mpi_real, + & t5_restart1,5,mpi_real,king,CG_COMM,ierr) + totT=t5_restart1(1) + EK=t5_restart1(2) + potE=t5_restart1(3) + t_bath=t5_restart1(4) + + if(me.eq.king)then + do il=0,nodes-1 + do i=1,2*nres + read(irest2,'(3e15.5)') + & (d_restart1(j,i+2*nres*il),j=1,3) + enddo + enddo + endif + call mpi_scatter(d_restart1,3*2*nres,mpi_real, + & r_d,3*2*nres,mpi_real,king,CG_COMM,ierr) + + do i=1,2*nres + do j=1,3 + d_t(j,i)=r_d(j,i) + enddo + enddo + if(me.eq.king)then + do il=0,nodes-1 + do i=1,2*nres + read(irest2,'(3e15.5)') + & (d_restart1(j,i+2*nres*il),j=1,3) + enddo + enddo + endif + call mpi_scatter(d_restart1,3*2*nres,mpi_real, + & r_d,3*2*nres,mpi_real,king,CG_COMM,ierr) + do i=1,2*nres + do j=1,3 + dc(j,i)=r_d(j,i) + enddo + enddo + if(me.eq.king) close(irest2) + return + end +c------------------------------------------------------------------- + subroutine set_hweights(iiset) + implicit real*8 (a-h,o-z) + integer i + include 'DIMENSIONS' + include 'COMMON.FFIELD' + include 'COMMON.REMD' + + do i=1,n_ene + weights(i)=hweights(iiset,i) + enddo + + wsc =weights(1) + wscp =weights(2) + welec =weights(3) + wcorr =weights(4) + wcorr5 =weights(5) + wcorr6 =weights(6) + wel_loc=weights(7) + wturn3 =weights(8) + wturn4 =weights(9) + wturn6 =weights(10) + wang =weights(11) + wscloc =weights(12) + wtor =weights(13) + wtor_d =weights(14) + wstrain=weights(15) + wvdwpp =weights(16) + wbond =weights(17) + scal14 =weights(18) + wsccor =weights(21) + + return + end +#endif diff --git a/source/unres/src_MD-DFA-restraints/Makefile b/source/unres/src_MD-DFA-restraints/Makefile new file mode 100644 index 0000000..d4615a5 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/Makefile @@ -0,0 +1,133 @@ +################################################################### +INSTALL_DIR = /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh + +FC = ifort +FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include +FFLAGS1 = -c -w -g -d2 -CA -CB -I$(INSTALL_DIR)/include +FFLAGS2 = -c -w -g -O0 -I$(INSTALL_DIR)/include +FFLAGS3 = -c -w -O3 -mp +FFLAGSE = -c -w -O3 -ipo -ipo_obj -opt_report -I$(INSTALL_DIR)/include + +CC = cc + +CFLAGS = -DLINUX -DPGI -c + +OPT = -O3 -ip -w + +# -Mvect <---slows down +# -Minline=name:matmat2 <---false convergence + +LIBS = -L$(INSTALL_DIR)/lib -lmpich xdrf/libxdrf.a +#-DCO_BIAS +#-DCRYST_TOR +#-DDEBUG + +ARCH = LINUX +PP = /lib/cpp -P + +all: + @echo "Specify force field: GAB or E0LL2Y" + +.SUFFIXES: .F +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + +object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ + matmult.o readrtns.o parmread.o gen_rand_conf.o printmat.o map.o \ + pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ + cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ + energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \ + cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ + mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ + eigen.o blas.o add.o entmcm.o minim_mcmf.o \ + MP.o compare_s1.o prng.o \ + banach.o rmsd.o elecont.o dihed_cons.o \ + sc_move.o local_move.o \ + intcartderiv.o lagrangian_lesyng.o\ + stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ + surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ + q_measure.o gnmr1.o test.o dfa.o ssMD.o + +GAB: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DUNRES -DISNAN -DMP -DMPI \ + -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC +GAB: BIN = ../bin/unres_ifort_MPICH-restr-DFA_GAB.exe +GAB: ${object} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + +E0LL2Y: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DUNRES -DISNAN -DMP -DMPI \ + -DSPLITELE -DLANG0 +E0LL2Y: BIN = ../../../bin/unres/MD/unres_ifort_MPICH-restr-DFA_E0LL2Y.exe +E0LL2Y: ${object} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + +xdrf/libxdrf.a: + cd xdrf && make + +clean: + /bin/rm -f *.o && /bin/rm -f compinfo && cd xdrf && make clean + +test.o: test.F + ${FC} ${FFLAGS} ${CPPFLAGS} test.F + +chainbuild.o: chainbuild.F + ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F + +matmult.o: matmult.f + ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f + +parmread.o : parmread.F + ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F + +intcor.o : intcor.f + ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f + +cartder.o : cartder.F + ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F + +readpdb.o : readpdb.F + ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.F + +sumsld.o : sumsld.f + ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f + +cored.o : cored.f + ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f + +rmdd.o : rmdd.f + ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f + +energy_p_new_barrier.o : energy_p_new_barrier.F + ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new_barrier.F + +gradient_p.o : gradient_p.F + ${FC} ${FFLAGSE} ${CPPFLAGS} gradient_p.F + +energy_p_new-sep_barrier.o : energy_p_new-sep_barrier.F + ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep_barrier.F + +lagrangian_lesyng.o : lagrangian_lesyng.F + ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F + +MD_A-MTS.o : MD_A-MTS.F + ${FC} ${FFLAGSE} ${CPPFLAGS} MD_A-MTS.F + +blas.o : blas.f + ${FC} ${FFLAGS1} blas.f + +add.o : add.f + ${FC} ${FFLAGS1} add.f + +eigen.o : eigen.f + ${FC} ${FFLAGS2} eigen.f + +dfa.o : dfa.F + ${FC} -mp ${FFLAGS3} ${CPPFLAGS} dfa.F + +proc_proc.o: proc_proc.c + ${CC} ${CFLAGS} proc_proc.c diff --git a/source/unres/src_MD-DFA-restraints/Makefile-intrepid-with-tau b/source/unres/src_MD-DFA-restraints/Makefile-intrepid-with-tau new file mode 100644 index 0000000..eae1cc5 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/Makefile-intrepid-with-tau @@ -0,0 +1,154 @@ +# +FC1=/bgsys/drivers/ppcfloor/comm/bin/mpixlf77 +FC=tau_f90.sh +OPT = -O3 -qarch=450 -qtune=450 -qfixed +#OPT = -O3 -qarch=450 -qtune=450 -qdebug=function_trace -qfixed +#OPT = -O -qarch=450 -qtune=450 -qfixed +#-Minline=name:scalar2,scalar,transpose2,matvec2,prodmat3 \ +#-Mprefetch=distance:8,nta + +#OPT = -O0 -C -g -qarch=450 -qtune=450 -qfixed +OPT1 = -O0 -g -qarch=450 -qtune=450 -qfixed +OPT2 = -O2 -qarch=450 -qtune=450 -qfixed +#OPT2 = -O2 -qarch=450 -qtune=450 -qdebug=function_trace -qfixed +#OPT2 = ${OPT} +OPTE = -O4 -qarch=450 -qtune=450 -qfixed +#OPTE = -O4 -qarch=450 -qtune=450 -qdebug=function_trace -qfixed +#OPTE=${OPT} + +FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include +FFLAGS1 = -c ${OPT1} -I$(INSTALL_DIR)/include +FFLAGS2 = -c ${OPT2} -I$(INSTALL_DIR)/include +FFLAGSE = -c ${OPTE} -I$(INSTALL_DIR)/include + +BIN = ../bin/unres_MD_Tc_procor-newparm-gnivpar-O4-test.exe +#LIBS = xdrf/libxdrf.a /home/liwo/UNRES/LIB/libmemmon.a +LIBS = xdrf/libxdrf.a + +CPPFLAGS = -WF,-DAIX -WF,-DISNAN -WF,-DUNRES -WF,-DMP -WF,-DMPI -WF,-DPGI \ + -WF,-DSPLITELE -WF,-DPROCOR -WF,-DAMD64 -WF,-DLANG0 + +ARCH = LINUX +PP = /lib/cpp -P + + +all: unres + +.SUFFIXES: .F +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + + +object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ + matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ + pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ + cartder.o checkder_p.o econstr_local.o energy_p_new.o \ + energy_p_new-sep.o gradient_p.o minimize_p.o sumsld.o \ + cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ + mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ + eigen.o blas.o add.o entmcm.o minim_mcmf.o \ + together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ + indexx.o MP.o compare_s1.o prng.o \ + test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ + sc_move.o local_move.o \ + intcartderiv.o lagrangian_lesyng.o\ + stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ + surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ + q_measure.o gnmr1.o + +unres: ${object} + ${CC} -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + ${FC} ${OPT} --print-map ${object} cinfo.o ${LIBS} -o ${BIN} + + +clean: + /bin/rm *.o; /bin/rm *.pp.* + +newconf.o: newconf.f + ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f + +bank.o: bank.F + ${FC} ${FFLAGS} ${CPPFLAGS} bank.F + +diff12.o: diff12.f + ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f + +csa.o: csa.f + ${FC} ${FFLAGS} ${CPPFLAGS} csa.f + +shift.o: shift.F + ${FC} ${FFLAGS} ${CPPFLAGS} shift.F + +ran.o: ran.f + ${FC} ${FFLAGS} ${CPPFLAGS} ran.f + +together.o: together.F + ${FC} ${FFLAGS} ${CPPFLAGS} together.F + +test.o: test.F + ${FC} ${FFLAGS} ${CPPFLAGS} test.F + +chainbuild.o: chainbuild.F + ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F + +matmult.o: matmult.f + ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f + +parmread.o : parmread.F + ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F + +intcor.o : intcor.f + ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f + +cartder.o : cartder.F + ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F + +readpdb.o : readpdb.f + ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.f + +sumsld.o : sumsld.f + ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f + +cored.o : cored.f + ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f + +rmdd.o : rmdd.f + ${FC} ${FFLAGS1} ${CPPFLAGS} rmdd.f + +eigen.o : eigen.f + ${FC} ${FFLAGS1} ${CPPFLAGS} eigen.f + +blas.o : blas.f + ${FC} ${FFLAGS1} ${CPPFLAGS} blas.f + +add.o : add.f + ${FC} ${FFLAGS1} ${CPPFLAGS} add.f + +energy_p_new.o : energy_p_new.F + ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F + +energy_p_new-sep.o : energy_p_new-sep.F + ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep.F + +lagrangian_lesyng.o : lagrangian_lesyng.F + ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F + +compinfo: compinfo.o + ${CC} ${CFLAGS} compfinfo.c + +proc_proc.o: proc_proc.c + ${CC} ${CFLAGS} proc_proc.c + +prng_32.o: prng_32.F + ${FC} -qfixed -O0 prng_32.F + +prng.o: prng.f + ${FC1} ${FFLAGS} prng.f + +readrtns_CSA.o: readrtns_CSA.F + ${FC1} ${FFLAGS} ${CPPFLAGS} readrtns_CSA.F + +gen_rand_conf.o: gen_rand_conf.F + ${FC1} ${FFLAGS} ${CPPFLAGS} gen_rand_conf.F diff --git a/source/unres/src_MD-DFA-restraints/Makefile.tau-mpi-f77-pdt b/source/unres/src_MD-DFA-restraints/Makefile.tau-mpi-f77-pdt new file mode 100644 index 0000000..c8dc5fe --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/Makefile.tau-mpi-f77-pdt @@ -0,0 +1,860 @@ +#**************************************************************************** +#* TAU Portable Profiling Package ** +#* http://www.cs.uoregon.edu/research/tau ** +#**************************************************************************** +#* Copyright 1997-2002 ** +#* Department of Computer and Information Science, University of Oregon ** +#* Advanced Computing Laboratory, Los Alamos National Laboratory ** +#**************************************************************************** +####################################################################### +## pC++/Sage++ Copyright (C) 1993,1995 ## +## Indiana University University of Oregon University of Rennes ## +####################################################################### + +####################################################################### +# This is a sample Makefile that contains the Profiling and Tracing +# options. Makefiles of other applications and libraries (not included +# in this distribution) should include this Makefile. +# It defines the following variables that should be added to CFLAGS +# TAU_INCLUDE - Include path for tau headers +# TAU_DEFS - Defines that are needed for tracing and profiling only. +# And for linking add to LIBS +# TAU_LIBS - TAU Tracing and Profiling library libprof.a +# +# When the user needs to turn off tracing and profiling and run the +# application without any runtime overhead of instrumentation, simply +# remove TAUDEFS and TAULIBS from CFLAGS and LIBS respectively but keep +# TAUINC. +####################################################################### + +########### Automatically modified by the configure script ############ +CONFIG_ARCH=bgp +TAU_ARCH=bgp +CONFIG_CC=bgxlc_r +CONFIG_CXX=bgxlC_r +TAU_CC_FE=$(CONFIG_CC) +TAU_CXX_FE=$(CONFIG_CXX) + +# Front end C/C++ Compilers +#BGL#TAU_CC_FE=xlc #ENDIF# +#BGL#TAU_CXX_FE=xlC #ENDIF# +TAU_CC_FE=xlc #ENDIF##BGP# +TAU_CXX_FE=xlC #ENDIF##BGP# +#CATAMOUNT#TAU_CC_FE=gcc #ENDIF# +#CATAMOUNT#TAU_CXX_FE=g++ #ENDIF# +#SC_GFORTRAN#TAU_CC_FE=gcc #ENDIF# +#SC_GFORTRAN#TAU_CXX_FE=g++ #ENDIF# +#SC_PATHSCALE#TAU_CC_FE=gcc #ENDIF# +#SC_PATHSCALE#TAU_CXX_FE=g++ #ENDIF# + +PCXX_OPT=-g +USER_OPT= +EXTRADIR=/opt/ibmcmp/xlf/bg/11.1/bin/.. +EXTRADIRCXX=/opt/ibmcmp/vacpp/bg/9.0/bin/.. +TAUROOT=/soft/apps/tau/tau_latest +TULIPDIR= +TAUEXTRASHLIBOPTS= +TAUGCCLIBOPTS= +TAUGCCLIBDIR= +TAUGFORTRANLIBDIR= +PCLDIR= +PAPIDIR= +PAPISUBDIR= +CHARMDIR= +PDTDIR=/soft/apps/tau/pdtoolkit-3.12 +PDTCOMPDIR= +DYNINSTDIR= +JDKDIR= +SLOG2DIR= +OPARIDIR= +TAU_OPARI_TOOL= +EPILOGDIR= +EPILOGBINDIR= +EPILOGINCDIR= +EPILOGLIBDIR= +EPILOGEXTRALINKCMD= +VAMPIRTRACEDIR= +KTAU_INCDIR= +KTAU_INCUSERDIR= +KTAU_LIB= +KTAU_KALLSYMS_PATH= +PYTHON_INCDIR= +PYTHON_LIBDIR= +PERFINCDIR= +PERFLIBDIR= +PERFLIBRARY= +TAU_SHMEM_INC= +TAU_SHMEM_LIB= +TAU_CONFIG=-mpi-pdt +TAU_MPI_INC=-I/bgsys/drivers/ppcfloor/comm/include +TAU_MPI_LIB=-L/soft/apps/tau/tau_latest/bgp/lib -lTauMpi$(TAU_CONFIG) -L/bgsys/drivers/ppcfloor/comm/lib +TAU_MPI_FLIB=-lfmpich.cnk -L/soft/apps/tau/tau_latest/bgp/lib -lTauMpi$(TAU_CONFIG) -L/bgsys/drivers/ppcfloor/comm/lib +TAU_MPILIB_DIR=/bgsys/drivers/ppcfloor/comm/lib +TAU_MPI_NOWRAP_LIB= -L/bgsys/drivers/ppcfloor/comm/lib +TAU_MPI_NOWRAP_FLIB=-lfmpich.cnk -L/bgsys/drivers/ppcfloor/comm/lib +FULL_CXX=mpixlcxx_r +FULL_CC=mpixlc_r +TAU_PREFIX_INSTALL_DIR=/soft/apps/tau/tau_latest + +TAU_BIN_DIR=$(TAU_PREFIX_INSTALL_DIR)/$(CONFIG_ARCH)/bin +TAU_INC_DIR=$(TAU_PREFIX_INSTALL_DIR)/include +TAU_LIB_DIR=$(TAU_PREFIX_INSTALL_DIR)/$(CONFIG_ARCH)/lib + +####################################################################### + +#OPARI#TAU_OPARI_TOOL=$(TAU_BIN_DIR)/opari #ENDIF# +#ENABLE64BIT#ABI = -64 #ENDIF# +#ENABLEN32BIT#ABI = -n32 #ENDIF# +#ENABLE32BIT#ABI = -32 #ENDIF# + +####################################################################### +#SP1#IBM_XLC_ABI = -q32 #ENDIF# +#SP1#IBM_GNU_ABI = -maix32 #ENDIF# +#IBM64#IBM_XLC_ABI = -q64 #ENDIF# +#IBM64#IBM_GNU_ABI = -maix64 #ENDIF# +#IBM64LINUX#IBM_XLC_ABI = -q64 #ENDIF# +#IBM64LINUX#IBM_GNU_ABI = -m64 #ENDIF# +#SUNX86_64#SUN_GNU_ABI = -m64 #ENDIF# +#SUNX86_64#SUN_CC_ABI = -xarch=amd64 #ENDIF# +#MIPS32LINUX#SC_GNU_ABI = -mabi=n32 #ENDIF# +#MIPS32LINUX#SC_PATH_ABI = -n32 #ENDIF# +#MIPS64LINUX#SC_GNU_ABI = -mabi=64 #ENDIF# +#MIPS64LINUX#SC_PATH_ABI = -64 #ENDIF# +#GNU#SC_ABI = $(SC_GNU_ABI) #ENDIF# +#USE_PATHCC#SC_ABI = $(SC_PATH_ABI) #ENDIF# +#MIPS32#ABI = $(SC_ABI) #ENDIF# +#MIPS64#ABI = $(SC_ABI) #ENDIF# + +IBM_ABI = $(IBM_XLC_ABI) #ENDIF##USE_IBMXLC# +#GNU#IBM_ABI = $(IBM_GNU_ABI) #ENDIF# +#SP1# ABI = $(IBM_ABI) #ENDIF# +#PPC64# ABI = $(IBM_ABI) #ENDIF# +#SOLARIS64#SUN_GNU_ABI = -mcpu=v9 -m64 #ENDIF# +#SOLARIS64#SUN_CC_ABI = -xarch=v9 -xcode=pic32 #ENDIF# +#SOL2CC#SUN_ABI = $(SUN_CC_ABI) #ENDIF# +#GNU#SUN_ABI = $(SUN_GNU_ABI) #ENDIF# +#SOL2#ABI = $(SUN_ABI) #ENDIF# +#SUNX86_64#ABI = $(SUN_ABI) #ENDIF# +#FORCEIA32#ABI = -m32#ENDIF# +####################################################################### +F90_ABI = $(ABI) +#IBM64_FORTRAN#F90_ABI = -q64 #ENDIF# +####################################################################### + +############# Standard Defines ############## +TAU_CC = $(CONFIG_CC) $(ABI) $(ISA) +TAU_CXX = $(CONFIG_CXX) $(ABI) $(ISA) $(USER_OPT) +TAU_RUN_CC = $(FULL_CC) $(ABI) $(ISA) +TAU_RUN_CXX = $(FULL_CXX) $(ABI) $(ISA) +TAU_INSTALL = /bin/cp +TAU_SHELL = /bin/sh +LSX = .a +############################################# +# JAVA DEFAULT ARCH +############################################# +JDKARCH = linux +#COMPAQ_ALPHA#JDKARCH = alpha #ENDIF# +#SOL2#JDKARCH = solaris #ENDIF# +#SGIMP#JDKARCH = irix #ENDIF# +#SP1#JDKARCH = aix #ENDIF# +#T3E#JDKARCH = cray #ENDIF# +############################################# +# JAVA OBJECTS +############################################# +#JAVA#TAU_JAVA_O = TauJava.o TauJAPI.o #ENDIF# +#JAVA#TAUJAPI = Profile.class #ENDIF# + + +############################################# +# OpenMP OBJECTS +############################################# +#OPENMP#OPENMP_O = OpenMPLayer.o #ENDIF# + +############################################# +# Opari OBJECTS +############################################# +#OPARI#OPARI_O = TauOpari.o #ENDIF# +#KOJAKOPARI#OPARI_O = TauKojakOpari.o #ENDIF# +#EPILOG#OPARI_O = #ENDIF# +#VAMPIRTRACE#OPARI_O = #ENDIF# +#GNU#OPARI_O = #ENDIF# + +############################################# +# CallPath OBJECTS +############################################# +#PROFILECALLPATH#CALLPATH_O = TauCallPath.o #ENDIF# +#PROFILEPARAM#PARAM_O = ProfileParam.o #ENDIF# + +############################################# +# Python Binding OBJECTS +############################################# +#PYTHON#PYTHON_O = PyGroups.o PyExceptions.o PyDatabase.o PyBindings.o PyTimer.o PyTau.o #ENDIF# + +############################################# +# DYNINST DEFAULT ARCH +############################################# +DYNINST_PLATFORM = $(PLATFORM) + + +#PCL##include $(TAU_INC_DIR)/makefiles/PCLMakefile.stub #ENDIF# + +############# OpenMP Fortran Option ######## +#OPENMP#TAU_F90_OPT = -mp #ENDIF# +#SOL2CC_OPENMP#TAU_F90_OPT = -xopenmp #ENDIF# +#SUNCC_OPENMP#TAU_F90_OPT = -xopenmp=parallel #ENDIF# +#COMPAQCXX_OPENMP#TAU_F90_OPT = -omp #ENDIF# +#IBMXLC_OPENMP#TAU_F90_OPT = -qsmp=omp #ENDIF# +#GUIDE#TAU_F90_OPT = #ENDIF# +#PGIOPENMP#TAU_F90_OPT = -mp #ENDIF# +#INTELOPENMP#TAU_F90_OPT = -openmp #ENDIF# +#HITACHI_OPENMP#TAU_F90_OPT = #ENDIF# + +TAU_R =_r #ENDIF##THREADSAFE_COMPILERS# + +############# Fortran Compiler ############# +#GNU_FORTRAN#TAU_F90 = g77 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# +#GNU_GFORTRAN#TAU_F90 = gfortran $(F90_ABI) $(TAU_F90_OPT) #ENDIF# +#G95_FORTRAN#TAU_F90 = g95 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# +#SC_GFORTRAN#TAU_F90 = scgfortran $(F90_ABI) $(TAU_F90_OPT) #ENDIF# +#SGI_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# +TAU_F90 = xlf77$(TAU_R) $(F90_ABI) $(TAU_F90_OPT) #ENDIF##IBM_FORTRAN# +TAU_F90 = mpixlf77$(TAU_R) $(F90_ABI) $(TAU_F90_OPT) #ENDIF##BGP# +#BGL#TAU_F90 = blrts_xlf90$(TAU_R) $(F90_ABI) $(TAU_F90_OPT) #ENDIF# +#IBM64_FORTRAN#TAU_F90 = xlf90$(TAU_R) $(F90_ABI) $(TAU_F90_OPT) #ENDIF# +#IBMXLFAPPLE#TAU_F90 = xlf90$(TAU_R) $(F90_ABI) $(TAU_F90_OPT) #ENDIF# +#CRAY_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# +#CRAY_X1_FORTRAN#TAU_F90 = ftn $(F90_ABI) $(TAU_F90_OPT) #ENDIF# +#PGI_FORTRAN#TAU_F90 = pgf90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# +#CRAYCNL#TAU_F90 = ftn $(F90_ABI) $(TAU_F90_OPT) #ENDIF# +#PGI_CATAMOUNT#TAU_F90 = qk-pgf90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# +#ABSOFT_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# +#LAHEY_FORTRAN#TAU_F90 = lf95 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# +#LAHEY64_FORTRAN#TAU_F90 = lf95 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# +#NAGWARE_FORTRAN#TAU_F90 = f95 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# +#FUJITSU_FORTRAN#TAU_F90 = F90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# +#FUJITSU_SOLARIS#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# +#SUN_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# +#COMPAQ_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# +#KAI_FORTRAN#TAU_F90 = guidef90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# +#HP_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# +#HITACHI_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# +#INTEL_FORTRAN#TAU_F90 = efc $(F90_ABI) $(TAU_F90_OPT) #ENDIF# +#INTEL32_FORTRAN#TAU_F90 = ifc $(F90_ABI) $(TAU_F90_OPT) #ENDIF# +#INTELIFORT#TAU_F90 = ifort $(F90_ABI) $(TAU_F90_OPT) #ENDIF# +#PATHSCALE_FORTRAN#TAU_F90 = pathf90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# +#SC_PATHSCALE#TAU_F90 = scpathf95 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# +#OPEN64ORC_FORTRAN#TAU_F90 = orf90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# +#NEC_FORTRAN#TAU_F90 = f90 $(F90_ABI) $(TAU_F90_OPT) #ENDIF# + + +############# Portable F90 Options ############# +#IBM64_FORTRAN#TAU_F90_FIXED = -qfixed #ENDIF# +TAU_F90_FIXED = -qfixed #ENDIF##IBM_FORTRAN# +TAU_F90_SUFFIX = -qsuffix=f=f90 #ENDIF##IBM_FORTRAN# +#IBMXLFAPPLE#TAU_F90_FIXED = -qfixed #ENDIF# +#IBMXLFAPPLE#TAU_F90_SUFFIX = -qsuffix=f=f90 #ENDIF# +#IBM64_FORTRAN#TAU_F90_SUFFIX = -qsuffix=f=f90 #ENDIF# + +############# Profiling Options ############# +PROFILEOPT1 = -DPROFILING_ON #ENDIF##PROFILE# +#PCL#PROFILEOPT3 = -DTAU_PCL -I$(PCLDIR)/include #ENDIF# +#PAPI#PROFILEOPT3 = -DTAU_PAPI -I$(PAPIDIR)/src -I$(PAPIDIR)/include #ENDIF# +#PCL#PCL_O = PclLayer.o #ENDIF# +#PAPI#PAPI_O = PapiLayer.o #ENDIF# +#MULTIPLECOUNTERS#MULT_O = MultipleCounters.o #ENDIF# +#PROFILECALLS#PROFILEOPT4 = -DPROFILE_CALLS #ENDIF# +#PROFILESTATS#PROFILEOPT5 = -DPROFILE_STATS #ENDIF# +#DEBUGPROF#PROFILEOPT6 = -DDEBUG_PROF #ENDIF# +PROFILEOPT7 = -DTAU_STDCXXLIB #ENDIF##STDCXXLIB# +#CRAYX1CC#PROFILEOPT7 = #ENDIF# +#CRAYCC#PROFILEOPT7 = #ENDIF# +#INTELTFLOP#PROFILEOPT8 = -DPOOMA_TFLOP #ENDIF# +#NORTTI#PROFILEOPT9 = -DNO_RTTI #ENDIF# +#RTTI#PROFILEOPT9 = -DRTTI #ENDIF# +#GNU#PROFILEOPT10 = -DTAU_GNU -DTAU_DOT_H_LESS_HEADERS -fPIC #ENDIF# +#APPLECXX#PROFILEOPT10 = -DTAU_GNU -DTAU_DOT_H_LESS_HEADERS -fPIC #ENDIF# +#SOL2CC#PROFILEOPT10 = -DTAU_SOL2CC -DTAU_DOT_H_LESS_HEADERS #ENDIF# +#SUNCC#PROFILEOPT10 = -DTAU_SOL2CC -DTAU_DOT_H_LESS_HEADERS #ENDIF# +#USE_PATHCC#PROFILEOPT10 = -DTAU_DOT_H_LESS_HEADERS -fPIC -DTAU_PATHSCALE #ENDIF# +#OPEN64ORC#PROFILEOPT10 = -DTAU_DOT_H_LESS_HEADERS -DTAU_OPEN64ORC -fpic #ENDIF# +#CALLSTACK#PROFILEOPT11 = -DPROFILE_CALLSTACK #ENDIF# +#PGI1.7#PROFILEOPT12 = -DPGI #ENDIF# +#CRAYKAI#PROFILEOPT12 = -DCRAYKAI #ENDIF# +#HP_FORTRAN#PROFILEOPT12 = -DHP_FORTRAN #ENDIF# +#CRAYCC#PROFILEOPT13 = -h instantiate=used -DCRAYCC -DTAU_DOT_H_LESS_HEADERS #ENDIF# +#CRAYX1CC#PROFILEOPT13 = -DTAU_DOT_H_LESS_HEADERS #ENDIF# +#SGICC#TAU_CXX = $(CONFIG_CXX) $(ABI) $(ISA) $(USER_OPT) -LANG:std #ENDIF# +#INTELCXXLIBICC#TAU_CXX = $(CONFIG_CXX) $(ABI) $(ISA) $(USER_OPT) -cxxlib-icc #ENDIF# +#PTHREAD_AVAILABLE#PROFILEOPT15 = -DPTHREADS #ENDIF# +#COMPAQCXX_PTHREAD#PROFILEOPT15 = -DPTHREADS -pthread #ENDIF# +#TAU_SPROC#PROFILEOPT15 = -DTAU_SPROC #ENDIF# +#TAU_PAPI_THREADS#PROFILEOPT15 = -DTAU_PAPI_THREADS #ENDIF# +#TULIPTHREADS#PROFILEOPT16 = -DTULIPTHREADS #ENDIF# +#TRACE#TRACEOPT = -DTRACING_ON #ENDIF# +#TRACE#EVENTS_O = Tracer.o #ENDIF# +#KTAU#KTAU_O = TauKtau.o KtauProfiler.o KtauSymbols.o #ENDIF# +#KTAU_MERGE#KTAU_MERGE_O = KtauFuncInfo.o KtauMergeInfo.o ktau_syscall.o #ENDIF# +#KTAU_SHCTR#KTAU_SHCTR_O = KtauCounters.o #ENDIF# +#MPITRACE#TRACEOPT = -DTAU_MPITRACE -DTRACING_ON #ENDIF# +#MPITRACE#EVENTS_O = Tracer.o #ENDIF# +#MUSE#MUSE_O = TauMuse.o TauMuseFilters.o TauMuseHandlers.o TauMusePackages.o #ENDIF# +#MUSE_EVENT#MUSE_O = TauMuse.o TauMuseFilters.o TauMuseHandlers.o TauMusePackages.o #ENDIF# +#MUSE_MULTIPLE#MUSE_O = TauMuse.o TauMuseFilters.o TauMuseHandlers.o TauMusePackages.o #ENDIF# +#COMPENSATE#COMPENSATE_O = TauCompensate.o #ENDIF# +#PTHREAD_AVAILABLE#THR_O = PthreadLayer.o #ENDIF# +#TAU_PAPI_THREADS#THR_O = PapiThreadLayer.o #ENDIF# +#TAU_SPROC#THR_O = SprocLayer.o #ENDIF# +#JAVA#THR_O = JavaThreadLayer.o #ENDIF# +#TULIPTHREADS#THR_O = TulipThreadLayer.o #ENDIF# +#LINUXTIMERS#PLATFORM_O = TauLinuxTimers.o #ENDIF# +#TULIPTHREADS#PROFILEOPT17 = -I$(TULIPDIR)/include -I$(TULIPDIR)/Tuliplib #ENDIF# +#SMARTS#PROFILEOPT17 = -I$(TULIPDIR)/include -I$(TULIPDIR)/lib -I$(TULIPDIR)/machine-specific/$(HOSTTYPE) #ENDIF# +#SMARTS#PROFILEOPT18 = -DSMARTS #ENDIF# +#KAI#PROFILEOPT19 = -DKAI -DTAU_DOT_H_LESS_HEADERS #ENDIF# +#USE_DECCXX#PROFILEOPT19 = -DTAU_DOT_H_LESS_HEADERS #ENDIF# +#SGICC#PROFILEOPT19 = -DTAU_DOT_H_LESS_HEADERS #ENDIF# +#USE_INTELCXX#PROFILEOPT19 = -DTAU_DOT_H_LESS_HEADERS -fPIC #ENDIF# +#USE_NECCXX#PROFILEOPT19 = -DTAU_DOT_H_LESS_HEADERS #ENDIF# +#PGI#PROFILEOPT19 = -DTAU_DOT_H_LESS_HEADERS -fPIC #ENDIF# +#ACC#PROFILEOPT19 = -AA +z -DTAU_DOT_H_LESS_HEADERS -DTAU_HPUX #ENDIF# +#FUJITSU#PROFILEOPT19 = -DFUJITSU -DTAU_DOT_H_LESS_HEADERS #ENDIF# +#KAINOEX#PROFILEOPT20 = --no_exceptions #ENDIF# +#SGICCNOEX#PROFILEOPT20 = -LANG:exceptions=off #ENDIF# +#HPGNU#PROFILEOPT21 = -fPIC #ENDIF# +#HITACHI#PROFILEOPT21 = -DTAU_HITACHI #ENDIF# +#SP1#PROFILEOPT21 = -D_POSIX_SOURCE -DTAU_AIX #ENDIF# +#PPC64#TAU_PIC_PROFILEOPT21 = -qpic=large #ENDIF# +#BGL#TAU_PIC_PROFILEOPT21 = #ENDIF# +PROFILEOPT21 = -DTAU_DOT_H_LESS_HEADERS -DTAU_XLC $(TAU_PIC_PROFILEOPT21) #ENDIF##USE_IBMXLC# +#IBMXLCAPPLE#PROFILEOPT21 = -DTAU_DOT_H_LESS_HEADERS -DTAU_XLC -DTAU_APPLE_XLC #ENDIF# +#PCLPTHREAD#PROFILEOPT22 = -DPCL_MUTEX_LOCK #ENDIF# +#JAVA#PROFILEOPT23 = -DJAVA #ENDIF# +#MONITOR#PROFILEOPT24 = -DMONITORING_ON #ENDIF# +#JAVA#PROFILEOPT25 = -I$(JDKDIR)/include -I$(JDKDIR)/include/$(JDKARCH) #ENDIF# +PROFILEOPT26 = -DTAU_MPI #ENDIF##MPI# +PROFILEOPT26 = -DTAU_MPI -DTAU_MPI_THREADED #ENDIF##MPI_THREADED# +#OPENMP#PROFILEOPT27 = -mp -DTAU_OPENMP#ENDIF# +#GNU#PROFILEOPT27 = #ENDIF# +#SOL2CC_OPENMP#PROFILEOPT27 = -xopenmp -DTAU_OPENMP#ENDIF# +#SUNCC_OPENMP#PROFILEOPT27 = -xopenmp=parallel -DTAU_OPENMP#ENDIF# +#SUNCC_OPENMP#PROFILEOPT27 = -xopenmp=parallel -DTAU_OPENMP#ENDIF# +#HITACHI_OPENMP#PROFILEOPT27 = -DTAU_OPENMP#ENDIF# +#COMPAQCXX_OPENMP#PROFILEOPT27 = -omp -DTAU_OPENMP#ENDIF# +#IBMXLC_OPENMP#PROFILEOPT27 = -qsmp=omp -DTAU_OPENMP #ENDIF# +#OPEN64_OPENMP#PROFILEOPT27 = -mp -DTAU_OPENMP #ENDIF# +#GUIDE#PROFILEOPT27 = -DTAU_OPENMP #ENDIF# +#PGIOPENMP#PROFILEOPT27 = -mp -D_OPENMP -DTAU_OPENMP -U_RWSTD_MULTI_THREAD -U_REENTRANT #ENDIF# +#INTELOPENMP#PROFILEOPT27 = -openmp -DTAU_OPENMP #ENDIF# +#GNUOPENMP#PROFILEOPT27 = -fopenmp -DTAU_OPENMP #ENDIF# +#OPARI#PROFILEOPT28 = -I$(OPARIDIR)/lib -I$(OPARIDIR)/include #ENDIF# +#OPARI_REGION#PROFILEOPT28 = -DTAU_OPARI_REGION -I$(OPARIDIR)/lib -I$(OPARIDIR)/include #ENDIF# +#OPARI_CONSTRUCT#PROFILEOPT28 = -DTAU_OPARI_CONSTRUCT -I$(OPARIDIR)/lib -I$(OPARIDIR)/include #ENDIF# +#MULTIPLECOUNTERS#PROFILEOPT29 = -DTAU_MULTIPLE_COUNTERS #ENDIF# +#SGITIMERS#PROFILEOPT30 = -DSGI_TIMERS #ENDIF# +#BGLTIMERS#PROFILEOPT30 = -DBGL_TIMERS -I/bgl/BlueLight/ppcfloor/bglsys/include #ENDIF# +#BGPTIMERS#PROFILEOPT30 = -DBGP_TIMERS -I/bgsys/drivers/ppcfloor/arch/include/common -I/bgsys/drivers/ppcfloor/arch/include -I/bgsys/drivers/ppcfloor/arch/include/spi #ENDIF# +#CRAYTIMERS#PROFILEOPT30 = -DCRAY_TIMERS #ENDIF# +#LINUXTIMERS#PROFILEOPT31 = -DTAU_LINUX_TIMERS #ENDIF# +#ALPHATIMERS#PROFILEOPT31 = -DTAU_ALPHA_TIMERS #ENDIF# +#CPUTIME#PROFILEOPT32 = -DCPU_TIME #ENDIF# +#PAPIWALLCLOCK#PROFILEOPT33 = -DTAU_PAPI_WALLCLOCKTIME #ENDIF# +#PAPIVIRTUAL#PROFILEOPT34 = -DTAU_PAPI_VIRTUAL #ENDIF# +#SGICOUNTERS#PROFILEOPT35 = -DSGI_HW_COUNTERS #ENDIF# +#EPILOG#PROFILEOPT36 = -DTAU_EPILOG -I$(EPILOGINCDIR) #ENDIF# +#SCALASCA#PROFILEOPT36 = -DTAU_SCALASCA -DTAU_EPILOG -I$(EPILOGINCDIR) #ENDIF# +#VAMPIRTRACEINTS#TAU_VAMPIRTRACEOPTS = -DTAU_64BITTYPES_NEEDED -DHAVE_INTTYPES_H #ENDIF# +#VAMPIRTRACE#PROFILEOPT36 = -DTAU_VAMPIRTRACE -I$(VAMPIRTRACEDIR)/vtlib -I$(VAMPIRTRACEDIR)/include $(TAU_VAMPIRTRACEOPTS)#ENDIF# +#PROFILECALLPATH#PROFILEOPT36 = -DTAU_CALLPATH #ENDIF# +#PROFILEPHASE#PROFILEOPT36 = -DTAU_CALLPATH -DTAU_PROFILEPHASE#ENDIF# +#PYTHON#PROFILEOPT37 = -I$(PYTHON_INCDIR) #ENDIF# +#NOCOMM#PROFILEOPT38 = -DTAU_NOCOMM #ENDIF# +#MUSE#PROFILEOPT39 = -DTAU_MUSE #ENDIF# +#SETNODE0#PROFILEOPT40 = -DTAU_SETNODE0 #ENDIF# +#COMPENSATE#PROFILEOPT41 = -DTAU_COMPENSATE #ENDIF# +#MUSE_EVENT#PROFILEOPT42 = -DTAU_MUSE_EVENT #ENDIF# +#MUSE_MULTIPLE#PROFILEOPT43 = -DTAU_MUSE_MULTIPLE #ENDIF# +#DYNINST41##PROFILEOPT44 = -DTAU_DYNINST41BUGFIX #ENDIF# +# DyninstAPI v4.2.1 fixes the bug, so we don't need OPT44 anymore +#PROFILEMEMORY#PROFILEOPT45 = -DTAU_PROFILEMEMORY #ENDIF# +PROFILEOPT46 = -DTAU_MPIGREQUEST #ENDIF##MPIGREQUEST# +#MPIOREQUEST#PROFILEOPT47 = -DTAU_MPIOREQUEST #ENDIF# +PROFILEOPT48 = -DTAU_MPIDATAREP #ENDIF##MPIDATAREP# +PROFILEOPT49 = -DTAU_MPIERRHANDLER #ENDIF##MPIERRHANDLER# +#CATAMOUNT#PROFILEOPT50 = -DTAU_CATAMOUNT #ENDIF# +#MPICONSTCHAR#PROFILEOPT51 = -DTAU_MPICONSTCHAR #ENDIF# +PROFILEOPT52 = -DTAU_MPIATTRFUNCTION #ENDIF##MPIATTR# +PROFILEOPT53 = -DTAU_MPITYPEEX #ENDIF##MPITYPEEX# +PROFILEOPT54 = -DTAU_MPIADDERROR #ENDIF##MPIADDERROR# +#MPINEEDSTATUSCONV#PROFILEOPT55 = -DTAU_MPI_NEEDS_STATUS #ENDIF# + +#DEPTHLIMIT#PROFILEOPT56 = -DTAU_DEPTH_LIMIT #ENDIF# +#TAU_CHARM#PROFILEOPT57 = -DTAU_CHARM -I$(CHARMDIR)/include #ENDIF# +#PROFILEHEADROOM#PROFILEOPT58 = -DTAU_PROFILEHEADROOM #ENDIF# +#JAVACPUTIME#PROFILEOPT59 = -DJAVA_CPU_TIME #ENDIF# +PROFILEOPT60 = -DTAU_LARGEFILE -D_LARGEFILE64_SOURCE #ENDIF##TAU_LARGEFILE# +PROFILEOPT60 = -DTAU_LARGEFILE -D_LARGEFILE64_SOURCE -D__xlc__ #ENDIF##BGP# +# Omit the -D_LARGETFILE64_SOURCE till we can check the IBM crash +#SHMEM#PROFILEOPT61 = -DTAU_SHMEM #ENDIF# +#KTAU#PROFILEOPT62 = -DTAUKTAU -DKTAU_USER_SRC_COMPILE -I$(KTAU_INCDIR) -I$(KTAU_INCUSERDIR) -DKTAU_INCUSERDIR=\"$(KTAU_INCUSERDIR)\" -DKTAU_KALLSYMS_PATH=\"$(KTAU_KALLSYMS_PATH)\" #ENDIF# +#KTAU_MERGE#PROFILEOPT63 = -DTAUKTAU_MERGE -DKTAU_USER_SRC_COMPILE -I$(KTAU_INCDIR) -DKTAU_INCUSERDIR=\"$(KTAU_INCUSERDIR)\" -DKTAU_KALLSYMS_PATH=\"$(KTAU_KALLSYMS_PATH)\" #ENDIF# +#FREEBSD#PROFILEOPT64 = -DTAU_FREEBSD #ENDIF# +#PROFILEPARAM#PROFILEOPT65 = -DTAU_PROFILEPARAM #ENDIF# +#IBMMPI#PROFILEOPT66 = -DTAU_IBM_MPI #ENDIF# +#WEAKMPIINIT#PROFILEOPT67 = -DTAU_WEAK_MPI_INIT #ENDIF# +#LAMPI#PROFILEOPT68 = -DTAU_LAMPI #ENDIF# +#MPICH_IGNORE_CXX_SEEK#PROFILEOPT68 = -DMPICH_IGNORE_CXX_SEEK #ENDIF# +PROFILEOPT68 = -DMPICH_IGNORE_CXX_SEEK #ENDIF##BGP# +#MPICH2_MPI_INPLACE#PROFILEOPT73 = -DTAU_MPICH2_MPI_IN_PLACE #ENDIF# + + +############# RENCI Scalable Trace Lib Options ############# +STFF_DIR= +SDDF_DIR= +#RENCI_STFF#PROFILEOPT69 = -DRENCI_STFF -I$(STFF_DIR)/include #ENDIF# +#RENCI_STFF#TAU_LINKER_OPT11 = -L$(STFF_DIR)/lib -lstff -L$(SDDF_DIR)/lib -lPablo $(TAU_MPI_LIB) #ENDIF# +#RENCI_STFF#RENCI_STFF_O = RenciSTFF.o #ENDIF# + +############# KTAU (again) ############# +#KTAU_SHCTR#PROFILEOPT70 = -DTAUKTAU_SHCTR -DKTAU_USER_SRC_COMPILE -I$(KTAU_INCDIR) -DKTAU_INCUSERDIR=\"$(KTAU_INCUSERDIR)\" -DKTAU_KALLSYMS_PATH=\"$(KTAU_KALLSYMS_PATH)\" #ENDIF# +#KTAU#TAU_LINKER_OPT12 = -L$(KTAU_LIB) -lktau #ENDIF# + +#MIPS32LINUX#PROFILEOPT71 = -D_ABIN32=2 -D_MIPS_SIM=_ABIN32 #ENDIF# + +#BGL#PROFILEOPT72 = -DTAU_BGL -I/bgl/BlueLight/ppcfloor/bglsys/include #ENDIF# +PROFILEOPT72 = -DTAU_BGP -I/bgsys/drivers/ppcfloor/arch/include/common -I/bgsys/drivers/ppcfloor/arch/include -I/bgsys/drivers/ppcfloor/arch/include/spi #ENDIF##BGP# + +#For F90 support for all platforms +FWRAPPER = TauFMpi.o +MPI2EXTENSIONS = TauMpiExtensions.o #ENDIF##MPI2# +MPI2EXTENSIONS = #ENDIF##BGP# +#CRAYX1CC#MPI2EXTENSIONS = #ENDIF# + +#SGICOUNTERS#LEXTRA = -lperfex #ENDIF# +#ALPHATIMERS#LEXTRA = -lrt #ENDIF# +#SOL2#PCL_EXTRA_LIBS = -lcpc #ENDIF# +#PCL#LEXTRA = -L$(PCLDIR)/lib -lpcl $(PCL_EXTRA_LIBS) #ENDIF# +#PAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a #ENDIF# +#IA64PAPI#LEXTRA = -L$(PAPIDIR)/$(PAPISUBDIR) -lpapi #ENDIF# +#Due to some problems with older versions of libpfm, we are using the static lib +#IA64PAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a #ENDIF# +#PAPIPFM##LEXTRA = -L$(PAPIDIR)/$(PAPISUBDIR) -lpfm -lpapi -lpfm #ENDIF# +#X86_64PAPI#LEXTRA = -L$(PAPIDIR)/$(PAPISUBDIR)/ -L$(PAPIDIR)/lib64/ -lpapi -lperfctr #ENDIF# +#SOL2PAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a -lcpc #ENDIF# +#IBMPAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a -L/usr/lpp/pmtoolkit/lib -L/usr/pmapi/lib -lpmapi#ENDIF# +#PPC64PAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a #ENDIF# +#BGLPAPI_RTS#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.rts.a -L/bgl/BlueLight/ppcfloor/bglsys/lib -lbgl_perfctr.rts -lrts.rts -ldevices.rts #ENDIF# +#BGLPAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a -L/bgl/BlueLight/ppcfloor/bglsys/lib -lbgl_perfctr.rts -lrts.rts -ldevices.rts #ENDIF# +#BGPPAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a -L/bgsys/drivers/ppcfloor/runtime/SPI -lSPI.cna #ENDIF# +#IBM64PAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi64.a -L/usr/lpp/pmtoolkit/lib -L/usr/pmapi/lib -lpmapi #ENDIF# +#IBM64PAPILINUX#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a #ENDIF# +#SGI64PAPI#LEXTRA = -L$(PAPIDIR)/$(PAPISUBDIR) -lpapi64 #ENDIF# +#ALPHAPAPI#LEXTRA = $(PAPIDIR)/$(PAPISUBDIR)/libpapi.a /usr/lib/dcpi/dadd.a -lclu -lrt #ENDIF# + +TAU_PAPI_EXTRA_FLAGS = $(LEXTRA) +#IA64PAPI#TAU_PAPI_EXTRA_FLAGS = -L$(PAPIDIR)/$(PAPISUBDIR) -lpapi #ENDIF# + + +# By default make TAU_PAPI_RPATH null. Support it on a compiler by compiler basis. +#PAPI###TAU_PAPI_RPATH = -rpath $(PAPIDIR)/$(PAPISUBDIR) #ENDIF# +#PAPI##TAU_PAPI_RPATH = #ENDIF# +#PPC64PAPI#TAU_PAPI_RPATH = #ENDIF# +#BGLPAPI#TAU_PAPI_RPATH = #ENDIF# +#BGPPAPI#TAU_PAPI_RPATH = #ENDIF# +#USE_INTELCXX#TAU_PAPI_RPATH = #ENDIF# +#CRAYX1CC#TAU_PAPI_RPATH = #ENDIF# +#PGI#TAU_PAPI_RPATH = -R$(PAPIDIR)/$(PAPISUBDIR) #ENDIF# +#GNU#TAU_PAPI_RPATH = -Wl,-rpath $(PAPIDIR)/$(PAPISUBDIR) #ENDIF# +#USE_PATHCC#TAU_PAPI_RPATH = #ENDIF# + +# if the user has specified -cc=gcc -c++=g++ -fortran=intel, we shouldn't use -rpath +# because they are likely going to link with ifort +#INTEL32_FORTRAN#TAU_PAPI_RPATH = #ENDIF# +#SOL2PAPI#TAU_PAPI_RPATH = #ENDIF# +#IBMPAPI#TAU_PAPI_RPATH = #ENDIF# +#IBM64PAPI#TAU_PAPI_RPATH = #ENDIF# +#PAPI#TAU_LINKER_OPT1 = $(TAU_PAPI_RPATH) #ENDIF# + +#PTHREAD_AVAILABLE#LEXTRA1 = -lpthread #ENDIF# +#TULIPTHREADS#LEXTRA1 = -L$(TULIPDIR)/Tuliplib -ltulip #ENDIF# +#SMARTS##include $(TAU_INC_DIR)/makefiles/GNUmakefile-$(HOSTTYPE) #ENDIF# +#SMARTS#LEXTRA1 = $(LSMARTS) #ENDIF# + +TAU_GCCLIB = -lgcc_s +TAU_GCCLIB = #ENDIF##BGP# +#INTEL32_ON_64#TAU_GCCLIB = -lgcc #ENDIF# +#FREEBSD#TAU_GCCLIB = -lgcc #ENDIF# +#BGL#TAU_GCCLIB = -lgcc #ENDIF# +#GNU#TAU_FORTRANLIBS = -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lstdc++ $(TAU_GCCLIB) #ENDIF# +#OPEN64ORC_FORTRAN#TAU_FORTRANLIBS = -lfortran -lffio #ENDIF# +#PATHSCALE_FORTRAN#TAU_FORTRANLIBS = -lpathfstart -lpathfortran #ENDIF# +#SC_PATHSCALE#TAU_FORTRANLIBS = -lpathfstart -lpathfortran #ENDIF# +#NAGWARE_FORTRAN#TAU_FORTRANLIBS = $(EXTRADIR)/lib/quickfit.o -L$(EXTRADIR)/lib -lf96 #ENDIF# +#G95_FORTRAN#TAU_FORTRANLIBS = -L$(EXTRADIR) -lf95 #ENDIF# +#GNU_FORTRAN#TAU_FORTRANLIBS = -lg2c #ENDIF# +#GNU_GFORTRAN#TAU_FORTRANLIBS = -L$(TAUGFORTRANLIBDIR) -lgfortran -lgfortranbegin #ENDIF# +#SC_GFORTRAN#TAU_FORTRANLIBS = -lgfortran -lgfortranbegin #ENDIF# +#SGI_FORTRAN#TAU_FORTRANLIBS = -lfortran -lftn #ENDIF# +TAU_IBM_FORTRANLIBS = -bh:4 -bpT:0x10000000 -bpD:0x20000000 /lib/crt0.o -lxlf90 -lm -lc #ENDIF##USE_IBMXLC# +#GNU#TAU_IBM_FORTRANLIBS = -Wl,-bh:4 -Wl,-bpT:0x10000000 -Wl,-bpD:0x20000000 /lib/crt0.o -lxlf90 -lm -lc #ENDIF# +#KAI#TAU_IBM_FORTRANLIBS = --backend -bh:4 --backend -bpT:0x10000000 --backend -bpD:0x20000000 /lib/crt0.o -lxlf90 -lm -lc #ENDIF# +TAU_FORTRANLIBS = $(TAU_IBM_FORTRANLIBS) #ENDIF##IBM_FORTRAN# + +TAU_IBM64_FORTRANLIBS = -bh:4 -bpT:0x10000000 -bpD:0x20000000 -b64 /lib/crt0_64.o -lxlf90 -lm -lc #ENDIF##USE_IBMXLC# +#GNU#TAU_IBM64_FORTRANLIBS = -Wl,-bh:4 -Wl,-bpT:0x10000000 -Wl,-bpD:0x20000000 -Wl,-b64 /lib/crt0_64.o -lxlf90 -lm -lc #ENDIF# +#KAI#TAU_IBM64_FORTRANLIBS = --backend -bh:4 --backend -bpT:0x10000000 --backend -bpD:0x20000000 --backend -b64 /lib/crt0_64.o -lxlf90 -lm -lc #ENDIF# +#IBM64_FORTRAN#TAU_FORTRANLIBS = $(TAU_IBM64_FORTRANLIBS) #ENDIF# +#IBM64_FORTRAN#TAU_FORLIBDIR=lib64 #ENDIF# +TAU_FORLIBDIR=lib #ENDIF##IBM_FORTRAN# +#BGL#TAU_FORLIBDIR=blrts_dev_lib #ENDIF# +TAU_FORLIBDIR=bglib #ENDIF##BGP# +#PPC64#TAU_FORTRANLIBS = -L$(EXTRADIR)/$(TAU_FORLIBDIR) -lxlf90 -lxlfmath -lxl #ENDIF# +#BGL#TAU_FORTRANLIBS = -L$(EXTRADIR)/$(TAU_FORLIBDIR) -L$(EXTRADIR)/blrts_lib -lxlf90 -lxlfmath -lxl #ENDIF# + +TAU_BGL_OMP_SERIAL= -lxlomp_ser #ENDIF##BGP# +#OPENMP#TAU_BGL_OMP_SERIAL= #ENDIF# +TAU_OMP_SERIAL=$(TAU_BGL_OMP_SERIAL) #ENDIF##BGP# +TAU_FORTRANLIBS = -L$(EXTRADIR)/$(TAU_FORLIBDIR) -lxlf90 -lxlfmath $(TAU_OMP_SERIAL) #ENDIF##BGP# + +#IBMXLFAPPLE#TAU_FORTRANLIBS = -L$(EXTRADIR)/lib -lxlf90 -lxlfmath -lxl #ENDIF# + +#CRAY_FORTRAN#TAU_FORTRANLIBS = #ENDIF# +#CRAY_X1_FORTRAN#TAU_FORTRANLIBS = #ENDIF# +#PGI_FORTRAN#TAU_FORTRANLIBS = $(EXTRADIR)/lib/f90main.o -lpgf90 -lpgf90rtl -lpgf90_rpm1 -lpgf902 -lpgftnrtl -lrt #ENDIF# +#HP_FORTRAN#TAU_FORTRANLIBS = -L$(EXTRADIR)/lib/pa2.0 -lF90 -lcl #ENDIF# +#INTEL_FORTRAN#TAU_FORTRANLIBS = -lcprts -lPEPCF90 #ENDIF# +#INTEL32_FORTRAN#TAU_FORTRANLIBS = -lcprts -lCEPCF90 -lF90 #ENDIF# +#INTELIFORT#TAU_FORTRANLIBS = -lcprts #ENDIF# +#INTEL81FIX#TAU_FORTRANLIBS = -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lstdc++ $(TAU_GCCLIB) -lcxa -lunwind -L$(EXTRADIR)/lib -lifcore $(EXTRADIR)/lib/for_main.o #ENDIF# +#INTEL10FIX#TAU_FORTRANLIBS = -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lstdc++ $(TAU_GCCLIB) -L$(EXTRADIR)/lib -lifcore $(EXTRADIR)/lib/for_main.o #ENDIF# +#INTELCXXLIBICC#TAU_FORTRANLIBS = -lcprts -L$(EXTRADIR)/lib -lifcore $(EXTRADIR)/lib/for_main.o #ENDIF# +#PGI1.7#LEXTRA = -lstd -lstrm#ENDIF# +#PGI1.7#TAUHELPER = $(TAUROOT)/src/Profile/TauPGIHelper.cpp #ENDIF# +# LINKER OPTIONS +TAU_LINKER_OPT2 = $(LEXTRA) + + +#ACC#TAUHELPER = -AA #ENDIF# +#FUJITSU_FORTRAN#TAU_FORTRANLIBS = $(EXTRADIR)/lib/fj90rt0.o -L$(EXTRADIR)/lib -lfj9i6 -lfj9f6 -lfj9e6 #ENDIF# +#FUJITSU_SOLARIS#TAU_FORTRANLIBS = $(EXTRADIR)/lib/fj90rt0.o -L$(EXTRADIR)/lib -lfj90l -lfj90f #ENDIF# +#SUN_FORTRAN#TAU_FORTRANLIBS = -lfui -lfsumai -lfprodai -lfminlai -lfmaxlai -lfminvai -lfmaxvai -lfsu -lsunmath #ENDIF# +#SUN_FORTRAN#TAU_FORTRANLIBS_SUN_OPTERON = -lfsu -lsunmath #ENDIF# +#SUN_FORTRAN#TAU_FORTRANLIBS_SUNCC = -lfsu #ENDIF# +#SUN386I#TAU_FORTRANLIBS = $(TAU_FORTRANLIBS_SUN_OPTERON) #ENDIF# +#SUNX86_64#TAU_FORTRANLIBS = $(TAU_FORTRANLIBS_SUN_OPTERON) #ENDIF# +#SUNCC#TAU_FORTRANLIBS = $(TAU_FORTRANLIBS_SUNCC) #ENDIF# +#SOL2#EXTRALIBS = -lsocket -lnsl #ENDIF# +#SUN386I#EXTRALIBS = -lsocket -lnsl -lrt #ENDIF# +#SUNX86_64#EXTRALIBS = -lsocket -lnsl -lrt #ENDIF# +#COMPAQ_FORTRAN#TAU_FORTRANLIBS = $(EXTRADIR)/lib/cmplrs/fort90/for_main.o -L$(EXTRADIR)/lib -L$(EXTRADIR)/lib/cmplrs/fort90 -L$(EXTRADIR)/lib/cmplrs/fort90 -lUfor -lfor -lFutil -lm -lmld -lexc -lc #ENDIF# +#ABSOFT_FORTRAN#TAU_FORTRANLIBS = -L$(EXTRADIR)/lib -lfio -lf90math -lU77 -lf77math -lfio #ENDIF# +#LAHEY_FORTRAN#TAU_FORTRANLIBS = $(EXTRADIR)/lib/fj90rt0.o -L$(EXTRADIR)/lib -lfj9i6 -lfj9f6 -lfj9e6 -lfccx86_6a #ENDIF# +#LAHEY64_FORTRAN#TAU_FORTRANLIBS = $(EXTRADIR)/lib64/fj90rt0.o -L$(EXTRADIR)/lib64 -lfj90f -lfj90i -lelf #ENDIF# +#HITACHI_FORTRAN#TAU_FORTRANLIBS = -lf90 -lhf90math #ENDIF# +#NEC_FORTRAN#TAU_FORTRANLIBS = -f90lib #ENDIF# +#COMPAQ_GUIDEF90#TAU_FORTRANLIBS = $(EXTRADIR)/lib/cmplrs/fort90/for_main.o -lfor #ENDIF# + + +#HITACHI#TAU_HITACHI_EXTRA = -L/usr/local/lib -llrz32 #ENDIF# + +## To use the standard F90 linker instead of TAU_LINKER + TAU_FORTRANLIBS, add +#GNU#TAU_CXXLIBS = -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lstdc++ $(TAU_GCCLIB) #ENDIF# +#GNU#TAU_GNUCXXLIBS = -L$(TAUGCCLIBDIR) -lstdc++ $(TAU_GCCLIB) #ENDIF# +#OPEN64ORC#TAU_CXXLIBS = -lstdc++ #ENDIF# +#PATHSCALE_FORTRAN#TAU_CXXLIBS = -lstdc++ #ENDIF# +#LAHEY_FORTRAN#TAU_CXXLIBS = $(TAU_GNUCXXLIBS) /usr/lib/libc.a #ENDIF# +#NAGWARE_FORTRAN#TAU_CXXLIBS = $(TAU_GNUCXXLIBS) /usr/lib/libc.a #ENDIF# +#PGI#TAU_CXXLIBS = -lstd -lC #ENDIF# +#CRAYCNL#TAU_CXXLIBS = -L$(EXTRADIR)/lib -lstd -lC -lpgc #ENDIF# +#CRAYX1CC#TAU_CXXLIBS = -L/opt/ctl/CC/CC/lib -lC #ENDIF# + +TAU_SGI_INIT = /usr/lib32/c++init.o +#ENABLE64BIT#TAU_SGI_INIT = /usr/lib64/c++init.o #ENDIF# +#ENABLEN32BIT#TAU_SGI_INIT = /usr/lib32/c++init.o #ENDIF# +#ENABLE32BIT#TAU_SGI_INIT = /usr/lib/c++init.o #ENDIF# + +#SGICC#TAU_CXXLIBS = $(TAU_SGI_INIT) -lC #ENDIF# +#APPLECXX#TAU_CXXLIBS = -lstd -lC #ENDIF# +#SOL2#TAU_CXXLIBS = -lCstd -lCrun #ENDIF# +#SOL2CC#TAU_CXXLIBS_SUN_OPTERON = -lCstd -lCrun -lm #ENDIF# +#SUNCC#TAU_CXXLIBS_SUNCC = -lCstd -lCrun #ENDIF# +#SUN386I#TAU_CXXLIBS = $(TAU_CXXLIBS_SUN_OPTERON) #ENDIF# +#SUNCC#TAU_CXXLIBS = $(TAU_CXXLIBS_SUNCC) #ENDIF# +#SUNX86_64#TAU_CXXLIBS = $(TAU_CXXLIBS_SUN_OPTERON) #ENDIF# +#FUJITSU_SOLARIS#TAU_CXXLIBS = -lstd -lstdm #ENDIF# +#PPC64#TAU_XLCLIBS = -L$(EXTRADIRCXX)/$(TAU_FORLIBDIR) -libmc++ -lstdc++ #ENDIF# +#IBMXLCAPPLE#TAU_FORLIBDIR =lib #ENDIF# +#IBMXLCAPPLE#TAU_XLCLIBS = -L$(EXTRADIRCXX)/$(TAU_FORLIBDIR) -libmc++ -lstdc++ #ENDIF# +#BGL#TAU_XLCLIBS = -L$(EXTRADIRCXX)/blrts_dev_lib -L$(EXTRADIRCXX)/blrts_lib -libmc++ -L/bgl/BlueLight/ppcfloor/blrts-gnu/powerpc-bgl-blrts-gnu/lib -lstdc++ #ENDIF# +TAU_XLCLIBS = -L$(EXTRADIRCXX)/bglib -libmc++ -lstdc++ #ENDIF##BGP# +#SP1#TAU_XLCLIBS = -lC #ENDIF# +TAU_CXXLIBS = $(TAU_XLCLIBS) #ENDIF##USE_IBMXLC# +#USE_DECCXX#TAU_CXXLIBS = -lcxxstd -lcxx #ENDIF# +#USE_INTELCXX#TAU_CXXLIBS_INTEL = -lcprts -lPEPCF90 #ENDIF# +#USE_INTELCXX#TAU_CXXLIBS_INTEL = -lcprts #ENDIF# +#INTELIFORT#TAU_CXXLIBS_INTEL = -lcprts #ENDIF# +#INTEL81FIX#TAU_CXXLIBS_INTEL = -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lstdc++ $(TAU_GCCLIB) -lcxa -lunwind#ENDIF# +#INTEL10FIX#TAU_CXXLIBS_INTEL = -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lstdc++ $(TAU_GCCLIB) #ENDIF# +#INTELCXXLIBICC#TAU_CXXLIBS_INTEL = -lcprts #ENDIF# +#USE_INTELCXX#TAU_CXXLIBS = $(TAU_CXXLIBS_INTEL) #ENDIF# +#APPLECXX#TAU_CXXLIBS = -lstdc++ -L$(TAUGCCLIBDIR) $(TAUGCCLIBOPTS) -lgcc_s.1 -lSystemStubs #ENDIF# + +# EXTERNAL PACKAGES: VAMPIRTRACE +#VAMPIRTRACE#TAU_LINKER_OPT3 = -L$(VAMPIRTRACEDIR)/lib -L$(VAMPIRTRACEDIR)/vtlib -lvt -lotf -lz $(TAU_HITACHI_EXTRA) #ENDIF# +#VAMPIRTRACEMPI#TAU_LINKER_OPT3 = -L$(VAMPIRTRACEDIR)/lib -L$(VAMPIRTRACEDIR)/vtlib -lvt.mpi -lotf -lz $(TAU_HITACHI_EXTRA) #ENDIF# +#VAMPIRTRACEOMPI#TAU_LINKER_OPT3 = -L$(VAMPIRTRACEDIR)/lib -L$(VAMPIRTRACEDIR)/vtlib -lvt.ompi -lotf -lz $(TAU_HITACHI_EXTRA) #ENDIF# +#VAMPIRTRACEOMP#TAU_LINKER_OPT3 = -L$(VAMPIRTRACEDIR)/lib -L$(VAMPIRTRACEDIR)/vtlib -lvt.omp -lotf -lz $(TAU_HITACHI_EXTRA) #ENDIF# + +# EXTERNAL PACKAGES: EPILOG +#SCALASCA#TAU_ELG_SERIAL_SUFFIX =.ser #ENDIF# +#EPILOG#TAU_LINKER_OPT3 = -L$(EPILOGLIBDIR) -lelg$(TAU_ELG_SERIAL_SUFFIX) $(EPILOGEXTRALINKCMD) $(TAU_HITACHI_EXTRA) #ENDIF# +#EPILOGMPI#TAU_LINKER_OPT3 = -L$(EPILOGLIBDIR) -lelg.mpi $(EPILOGEXTRALINKCMD) $(TAU_HITACHI_EXTRA) #ENDIF# +#EPILOGOMPI#TAU_LINKER_OPT3 = -L$(EPILOGLIBDIR) -lelg.ompi $(EPILOGEXTRALINKCMD) $(TAU_HITACHI_EXTRA) #ENDIF# +#EPILOGOMP#TAU_LINKER_OPT3 = -L$(EPILOGLIBDIR) -lelg.omp $(EPILOGEXTRALINKCMD) $(TAU_HITACHI_EXTRA) #ENDIF# + +# When using shared, we don't want -lelg.mpi or -lvt.mpi showing up +#FORCESHARED#TAU_LINKER_OPT3=#ENDIF# + +TAU_LINKER_OPT4 = $(LEXTRA1) +#HITACHI_OPENMP#TAU_LINKER_OPT4 = -lcompas -lpthreads -lc_r #ENDIF# +#OPENMP#TAU_LINKER_OPT5 = -mp #ENDIF# +#SOL2CC_OPENMP#TAU_LINKER_OPT5 = -xopenmp #ENDIF# +#SUNCC_OPENMP#TAU_LINKER_OPT5 = -xopenmp=parallel #ENDIF# +#GNU#TAU_LINKER_OPT5 = #ENDIF# +#COMPAQCXX_OPENMP#TAU_LINKER_OPT5 = -omp #ENDIF# +#IBMXLC_OPENMP#TAU_LINKER_OPT5 = -qsmp=omp #ENDIF# +#OPEN64_OPENMP#TAU_LINKER_OPT5 = -mp #ENDIF# +#GUIDE#TAU_LINKER_OPT5 = #ENDIF# +#PGIOPENMP#TAU_LINKER_OPT5 = -mp #ENDIF# +#INTELOPENMP#TAU_LINKER_OPT5 = -openmp #ENDIF# + +# MALLINFO needs -lmalloc on sgi, sun +#SGIMP#TAU_LINKER_OPT6 = -lmalloc #ENDIF# +#SOL2#TAU_LINKER_OPT6 = #ENDIF# +#SUN386I#TAU_LINKER_OPT6 = -lmalloc #ENDIF# +#SUNX86_64#TAU_LINKER_OPT6 = -lmalloc #ENDIF# + +# We need -lCio with SGI CC 7.4+ +#SGICC#TAU_LINKER_OPT7 = -lCio #ENDIF# + +# charm +#TAU_CHARM#TAU_LINKER_OPT8 = -lconv-core #ENDIF# + +# extra libs +#SUN386I#TAU_LINKER_OPT9 = $(EXTRALIBS) #ENDIF# +#SUNX86_64#TAU_LINKER_OPT9 = $(EXTRALIBS) #ENDIF# +#SOL2#TAU_LINKER_OPT9 = $(ExTRALIBS) #ENDIF# + +#BGL#TAU_LINKER_OPT10 = -L/bgl/BlueLight/ppcfloor/bglsys/lib -lrts.rts #ENDIF# + +TAU_IBM_PYTHON_SHFLAG = -Wl,-bI:$(PYTHON_LIBDIR)/config/python.exp -Wl,-einitpytau#ENDIF##USE_IBMXLC# +#GNU#TAU_IBM_PYTHON_SHFLAG = -Wl,-bI:$(PYTHON_LIBDIR)/config/python.exp -Wl,-einitpytau#ENDIF# +#KAI#TAU_IBM_PYTHON_SHFLAG = --backend -Wl,-bI:$(PYTHON_LIBDIR)/config/python.exp --backend -Wl,-einitpytau#ENDIF# +#ACC#TAU_HPUX_PYTHON_SHFLAG = -lstd_v2 -lCsup_v2 -lm -lcl -lc #ENDIF# + +TAU_IBM_LD_FLAGS = -binitfini:poe_remote_main #ENDIF##USE_IBMXLC# +#GNU#TAU_IBM_LD_FLAGS = -Wl,-binitfini:poe_remote_main #ENDIF# +#KAI#TAU_IBM_LD_FLAGS = --backend -binitfini:poe_remote_main #ENDIF# + + +#PYTHON#TAU_IBM_SHFLAGS = $(TAU_IBM_PYTHON_SHFLAG) #ENDIF# +#PYTHON#TAU_HPUX_SHFLAGS = $(TAU_HPUX_PYTHON_SHFLAG) #ENDIF# +#SP1#TAU_EXTRA_LIBRARY_FLAGS = $(TAU_IBM_SHFLAGS) #ENDIF# +#SOL2#TAU_EXTRA_LIBRARY_FLAGS = #ENDIF# +#SGIMP#TAU_EXTRA_LIBRARY_FLAGS = -lmalloc #ENDIF# +#HP#TAU_EXTRA_LIBRARY_FLAGS = $(TAU_HPUX_SHFLAGS) #ENDIF# + +TAU_MPI_WRAPPER_LIB= -L$(TAU_LIB_DIR) -lTauMpi$(TAU_CONFIG) #ENDIF##MPI# +#EPILOGMPI#TAU_MPI_WRAPPER_LIB= #ENDIF# +#EPILOGOMPI#TAU_MPI_WRAPPER_LIB= #ENDIF# + +############################################## +# Build TAU_LINKER_SHOPTS +#GNU#TAU_IBM_LINKER_SHOPTS=-Wl,-brtl -Wl,-bexpall #ENDIF# +TAU_IBM_LINKER_SHOPTS= -brtl -bexpall #ENDIF##USE_IBMXLC# +#KAI#TAU_IBM_LINKER_SHOPTS= --backend -brtl #ENDIF# +#SP1#TAU_LINKER_SHOPTS= $(TAU_IBM_LINKER_SHOPTS) #ENDIF# + +############################################## +# MPI _r suffix check (as in libmpi_r) +#MPI_R_SUFFIX#TAU_MPI_R_SUFFIX=_r #ENDIF# + +############################################## +# Flags to build a shared object: TAU_SHFLAGS +#GNU#AR_SHFLAGS = -shared #ENDIF# +#PGI#AR_SHFLAGS = -shared #ENDIF# +#SGICC#AR_SHFLAGS = -shared #ENDIF# +#APPLECXX#AR_SHFLAGS = -dynamiclib -flat_namespace -undefined suppress #ENDIF# +#SOL2#AR_SHFLAGS = -G #ENDIF# +#SUN386I#AR_SHFLAGS = -G #ENDIF# +#SUNX86_64#AR_SHFLAGS = -G #ENDIF# +AR_SHFLAGS = -G #ENDIF##USE_IBMXLC# +#USE_DECCXX#AR_SHFLAGS = -shared #ENDIF# +#USE_INTELCXX#AR_SHFLAGS = -shared #ENDIF# +#ACC#AR_SHFLAGS = -b #ENDIF# +TAU_SHFLAGS = $(AR_SHFLAGS) -o + +############# RANLIB Options ############# +TAU_RANLIB = echo "Built" +#APPLECXX#TAU_RANLIB = ranlib #ENDIF# +#IBMXLCAPPLE#TAU_RANLIB = ranlib #ENDIF# + +############################################## +TAU_AR = ar #ENDIF# +#SP1#TAU_AR = ar -X32 #ENDIF# +#IBM64#TAU_AR = ar -X64 #ENDIF# +#PPC64#TAU_AR = ar #ENDIF# +#IBM64LINUX#TAU_AR = ar #ENDIF# + + +############################################## +# PDT OPTIONS +# You can specify -pdtcompdir=intel -pdtarchdir=x86_64 +# If nothing is specified, PDTARCHDIR uses TAU_ARCH +PDTARCHDIRORIG=$(TAU_ARCH) +PDTARCHITECTURE=x86_64 +PDTARCHDIRFINAL=$(PDTARCHDIRORIG) +#PDTARCHITECTURE#PDTARCHDIRFINAL=$(PDTARCHITECTURE)#ENDIF# +PDTARCHDIR=$(PDTARCHDIRFINAL) +#PDTARCH#PDTARCHDIR=$(PDTARCHDIRFINAL)/$(PDTCOMPDIR)#ENDIF# + + +############################################## + +PROFILEOPTS = $(PROFILEOPT1) $(PROFILEOPT2) $(PROFILEOPT3) $(PROFILEOPT4) \ + $(PROFILEOPT5) $(PROFILEOPT6) $(PROFILEOPT7) $(PROFILEOPT8) \ + $(PROFILEOPT9) $(PROFILEOPT10) $(PROFILEOPT11) $(PROFILEOPT12) \ + $(PROFILEOPT13) $(PROFILEOPT14) $(PROFILEOPT15) $(PROFILEOPT16) \ + $(PROFILEOPT17) $(PROFILEOPT18) $(PROFILEOPT19) $(PROFILEOPT20) \ + $(PROFILEOPT21) $(PROFILEOPT22) $(PROFILEOPT23) $(PROFILEOPT24) \ + $(PROFILEOPT25) $(PROFILEOPT26) $(PROFILEOPT27) $(PROFILEOPT28) \ + $(PROFILEOPT29) $(PROFILEOPT30) $(PROFILEOPT31) $(PROFILEOPT32) \ + $(PROFILEOPT33) $(PROFILEOPT34) $(PROFILEOPT35) $(PROFILEOPT36) \ + $(PROFILEOPT37) $(PROFILEOPT38) $(PROFILEOPT39) $(PROFILEOPT40) \ + $(PROFILEOPT41) $(PROFILEOPT42) $(PROFILEOPT43) $(PROFILEOPT44) \ + $(PROFILEOPT45) $(PROFILEOPT46) $(PROFILEOPT47) $(PROFILEOPT48) \ + $(PROFILEOPT49) $(PROFILEOPT50) $(PROFILEOPT51) $(PROFILEOPT52) \ + $(PROFILEOPT53) $(PROFILEOPT54) $(PROFILEOPT55) $(PROFILEOPT56) \ + $(PROFILEOPT57) $(PROFILEOPT58) $(PROFILEOPT59) $(PROFILEOPT60) \ + $(PROFILEOPT61) $(PROFILEOPT62) $(PROFILEOPT63) $(PROFILEOPT64) \ + $(PROFILEOPT65) $(PROFILEOPT66) $(PROFILEOPT67) $(PROFILEOPT68) \ + $(PROFILEOPT69) $(PROFILEOPT70) $(PROFILEOPT71) $(PROFILEOPT72) \ + $(PROFILEOPT73) $(PROFILEOPT74) $(PROFILEOPT75) $(PROFILEOPT76) \ + $(TRACEOPT) + +############################################## + +TAU_LINKER_OPTS = $(TAU_LINKER_OPT1) $(TAU_LINKER_OPT2) $(TAU_LINKER_OPT3) \ + $(TAU_LINKER_OPT4) $(TAU_LINKER_OPT5) $(TAU_LINKER_OPT6) \ + $(TAU_LINKER_OPT7) $(TAU_LINKER_OPT8) $(TAU_LINKER_OPT9) \ + $(TAU_LINKER_OPT10) $(TAU_LINKER_OPT11) $(TAU_LINKER_OPT12) + +############################################## + +############# TAU Fortran #################### +TAU_LINKER=$(TAU_CXX) +#INTEL_FORTRAN##TAU_LINKER=$(TAU_F90) #ENDIF# +#INTEL32_FORTRAN##TAU_LINKER=$(TAU_F90) #ENDIF# +# Intel efc compiler acts as a linker - NO. Let C++ be the linker. + +############################################## +############# TAU Options #################### +TAUDEFS = $(PROFILEOPTS) + +TAUINC = -I$(TAU_INC_DIR) + +TAULIBS = $(TAUHELPER) -L$(TAU_LIB_DIR) -ltau$(TAU_CONFIG) $(TAU_LINKER_OPTS) + +TAUMPILIBS = $(TAU_MPI_LIB) + +TAUMPIFLIBS = $(TAU_MPI_FLIB) + +### ACL S/W requirement +TAU_DEFS = $(TAUDEFS) + +TAU_INCLUDE = -I$(TAU_INC_DIR) +#PERFLIB#TAU_INCLUDE = -I$(PERFINCDIR) #ENDIF# +#PERFLIB#TAU_DEFS = #ENDIF# +#PERFLIB#TAU_COMPILER_EXTRA_OPTIONS=-optTau=-p #ENDIF# + +TAU_INCLUDE_MEMORY = -I$(TAU_INC_DIR)/Memory +#IBMXLCAPPLE#TAU_INCLUDE_MEMORY = -I$(TAU_INC_DIR)/MemoryWrapper #ENDIF# +#APPLECXX#TAU_INCLUDE_MEMORY = -I$(TAU_INC_DIR)/MemoryWrapper #ENDIF# + +TAU_LIBS = $(TAUHELPER) -L$(TAU_LIB_DIR) -ltau$(TAU_CONFIG) $(TAU_LINKER_OPTS) +#PERFLIB#TAU_LIBS = #ENDIF# + +TAU_SHLIBS = $(TAUHELPER) -L$(TAU_LIB_DIR) -lTAUsh$(TAU_CONFIG) $(TAU_LINKER_OPTS) $(TAU_LINKER_SHOPTS) $(TAU_MPI_LIB) +#PERFLIB#TAU_SHLIBS = #ENDIF# +TAU_EXLIBS = $(TAUHELPER) -L$(TAU_LIB_DIR) -lTAU $(TAU_LINKER_OPTS) $(TAU_LINKER_SHOPTS) $(TAU_MPI_LIB) + +TAU_SHLIBS_NOSHOPTS = $(TAUHELPER) -L$(TAU_LIB_DIR) -lTAUsh$(TAU_CONFIG) $(TAU_LINKER_OPTS) + +TAU_DISABLE = $(TAUHELPER) -L$(TAU_LIB_DIR) -lTauDisable + +TAU_MPI_INCLUDE = $(TAU_MPI_INC) + +TAU_MPI_LIBS = $(TAU_MPI_LIB) + +TAU_MPI_FLIBS = $(TAU_MPI_FLIB) + +## TAU TRACE INPUT LIBRARY (can build a trace converter using TAU TIL) +TAU_TRACE_INPUT_LIB = -L$(TAU_LIB_DIR) -lTAU_traceinput$(TAU_CONFIG) + +## Don't include -lpthread or -lsmarts. Let app. do that. +############################################# +## IBM SPECIFIC CHANGES TO TAU_MPI_LIBS +#SP1#TAU_MPI_LDFLAGS = $(TAU_IBM_LD_FLAGS) #ENDIF# +TAU_LDFLAGS = $(TAU_MPI_LDFLAGS) #ENDIF##MPI# +#SP1#TAU_IBM_MPI_LIBS = $(TAU_MPI_LIB) -L$(TAU_MPILIB_DIR)/ip -lvtd$(TAU_MPI_R_SUFFIX) #ENDIF# +#SP1#TAU_IBM_FMPI_LIBS = $(TAU_MPI_FLIB) -L$(TAU_MPILIB_DIR)/ip -lvtd$(TAU_MPI_R_SUFFIX) #ENDIF# +#SP1#TAU_MPI_LIBS_FLAGS= $(TAU_IBM_MPI_LIBS) #ENDIF# +#SP1#TAU_MPI_FLIBS_FLAGS = $(TAU_IBM_MPI_FLIBS) #ENDIF# +TAU_MPI_LIBS_FLAGS = $(TAU_MPI_LIB) #ENDIF##MPI# +TAU_MPI_FLIBS_FLAGS = $(TAU_MPI_FLIB) #ENDIF##MPI# +TAU_MPI_LIBS = $(TAU_MPI_LIBS_FLAGS) #ENDIF##MPI# +TAU_MPI_FLIBS = $(TAU_MPI_FLIBS_FLAGS) #ENDIF##MPI# + +#SP1#TAUMPILIBS = $(TAU_MPI_LIBS) #ENDIF# +#SP1#TAUMPIFLIBS = $(TAU_MPI_FLIBS) #ENDIF# +############################################# +#SHMEM#TAU_SHMEM_OBJS = TauShmemCray.o #ENDIF# +#SP1#TAU_SHMEM_OBJS = TauShmemTurbo.o #ENDIF# +#GPSHMEM#TAU_SHMEM_OBJS = TauShmemGpshmem.o #ENDIF# + +TAU_SHMEM_INCLUDE = $(TAU_SHMEM_INC) + +TAU_SHMEM_LIBS = -L$(TAU_PREFIX_INSTALL_DIR)/$(CONFIG_ARCH)/ -lTauShmem$(TAU_CONFIG) $(TAU_SHMEM_LIB) +############################################# +# TAU COMPILER SHELL SCRIPT OPTIONS +TAUCOMPILEROPTS= -optPdtDir="$(PDTDIR)/${PDTARCHDIR}"\ + -optPdtCOpts="$(TAU_INCLUDE) $(TAU_DEFS) $(TAU_MPI_INCLUDE)"\ + -optPdtCxxOpts="$(TAU_INCLUDE) $(TAU_DEFS) $(TAU_MPI_INCLUDE)"\ + -optTauInstr="$(TAU_BIN_DIR)/tau_instrumentor" \ + -optNoMpi \ + -optOpariDir="$(OPARIDIR)" -optOpariTool="$(TAU_OPARI_TOOL)" \ + -optTauCC="$(TAU_CC)" \ + -optTauIncludes="$(TAU_INCLUDE) $(TAU_MPI_INCLUDE)" \ + -optTauDefs="$(TAU_DEFS)" \ + -optTauCompile="$(TAU_INCLUDE) $(TAU_MPI_INCLUDE) $(TAU_DEFS) "\ + -optLinking="$(TAU_MPI_FLIBS) $(TAU_LIBS) $(TAU_LDFLAGS) $(TAU_CXXLIBS)"\ + -optSharedLinking="$(TAU_MPI_FLIBS) $(TAU_EXLIBS) $(TAU_LDFLAGS) $(TAU_CXXLIBS)"\ + $(TAU_COMPILER_EXTRA_OPTIONS) \ + -optIncludeMemory="$(TAU_INCLUDE_MEMORY)" +############################################# + +TAU_SHAREDLIBS=$(TAUHELPER) -L$(TAU_LIB_DIR) -lTAU $(TAU_LINKER_OPTS) $(TAU_LINKER_SHOPTS) +SHAREDEXTRAS= +#FORCESHARED#SHAREDEXTRAS=-optSharedLinkReset="$(TAU_SHAREDLIBS) $(TAU_LDFLAGS) $(TAU_CXXLIBS) $(TAU_MPI_NOWRAP_FLIB)" -optShared #ENDIF# +TAU_COMPILER=$(TAU_BIN_DIR)/tau_compiler.sh $(TAUCOMPILEROPTS) $(SHAREDEXTRAS) +############################################# +# These options could be included in the application Makefile as +#CFLAGS = $(TAUDEFS) $(TAUINC) +# +#LIBS = $(TAULIBS) +# +# To run the application without Profiling/Tracing use +#CFLAGS = $(TAUINC) +# Don't use TAUDEFS but do include TAUINC +# Also ignore TAULIBS when Profiling/Tracing is not used. +############################################# + diff --git a/source/unres/src_MD-DFA-restraints/Makefile_MPICH_PGI b/source/unres/src_MD-DFA-restraints/Makefile_MPICH_PGI new file mode 100644 index 0000000..f55b08f --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/Makefile_MPICH_PGI @@ -0,0 +1,126 @@ +FC= mpif90 +OPT = -fast + +FFLAGS = -c ${OPT} +#FFLAGS = -c -g -C +FFLAGS1 = -c -g +FFLAGS2 = -c -g -O0 +FFLAGSE = -c -fast -Minline=name:scalar2,scalar,transpose2,matvec2,prodmat3 + +CFLAGS = -c -DLINUX -DPGI + +LIBS = xdrf/libxdrf.a + +ARCH = LINUX +PP = /lib/cpp -P + +LIBS = xdrf/libxdrf.a + +ARCH = LINUX +PP = /lib/cpp -P + + +all: unres + +.SUFFIXES: .F +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + + +object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ + matmult.o readrtns.o parmread.o gen_rand_conf.o printmat.o map.o \ + pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ + cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ + energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \ + cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ + mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ + eigen.o blas.o add.o entmcm.o minim_mcmf.o \ + MP.o compare_s1.o prng.o proc_proc.o\ + banach.o rmsd.o elecont.o dihed_cons.o \ + sc_move.o local_move.o \ + intcartderiv.o lagrangian_lesyng.o\ + stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ + surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ + q_measure.o gnmr1.o test.o ssMD.o + +GAB: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DUNRES -DMP -DMPI \ + -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC +GAB: BIN = /users/adam/bin/unres_PGI_MPI_GAB-r.exe +GAB: ${object} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + +E0LL2Y: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DUNRES -DMP -DMPI \ + -DSPLITELE -DLANG0 +E0LL2Y: BIN = /users/adam/bin/unres_PGI_MPI_E0LL2Y-r.exe +E0LL2Y: ${object} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + +xdrf/libxdrf.a: + cd xdrf && make + + +clean: + /bin/rm -f *.o && /bin/rm -f compinfo && cd xdrf && make clean + +test.o: test.F + ${FC} ${FFLAGS} ${CPPFLAGS} test.F + +chainbuild.o: chainbuild.F + ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F + +matmult.o: matmult.f + ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f + +parmread.o : parmread.F + ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F + +intcor.o : intcor.f + ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f + +cartder.o : cartder.F + ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F + +readpdb.o : readpdb.F + ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.F + +sumsld.o : sumsld.f + ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f + +cored.o : cored.f + ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f + +rmdd.o : rmdd.f + ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f + +energy_p_new_barrier.o : energy_p_new_barrier.F + ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new_barrier.F + +gradient_p.o : gradient_p.F + ${FC} ${FFLAGSE} ${CPPFLAGS} gradient_p.F + +energy_p_new-sep_barrier.o : energy_p_new-sep_barrier.F + ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep_barrier.F + +lagrangian_lesyng.o : lagrangian_lesyng.F + ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F + +MD_A-MTS.o : MD_A-MTS.F + ${FC} ${FFLAGSE} ${CPPFLAGS} MD_A-MTS.F + +blas.o : blas.f + ${FC} ${FFLAGS1} blas.f + +add.o : add.f + ${FC} ${FFLAGS1} add.f + +eigen.o : eigen.f + ${FC} ${FFLAGS2} eigen.f + +proc_proc.o: proc_proc.c + ${CC} ${CFLAGS} proc_proc.c diff --git a/source/unres/src_MD-DFA-restraints/Makefile_MPICH_ifort b/source/unres/src_MD-DFA-restraints/Makefile_MPICH_ifort new file mode 100644 index 0000000..d763388 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/Makefile_MPICH_ifort @@ -0,0 +1,127 @@ +################################################################### +INSTALL_DIR = /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh + + +FC= ifort + +OPT = -O3 -ip + +FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include +FFLAGS1 = -c -g -CA -CB -I$(INSTALL_DIR)/include +FFLAGS2 = -c -g -O0 -I$(INSTALL_DIR)/include +FFLAGSE = -c -O3 -ipo -opt_report -I$(INSTALL_DIR)/include + + +LIBS = -L$(INSTALL_DIR)/lib -lmpich xdrf/libxdrf.a + +ARCH = LINUX +PP = /lib/cpp -P + + +all: no_option + @echo "give optin GAB or E0LL2Y" + +.SUFFIXES: .F +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + + +object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ + matmult.o readrtns.o parmread.o gen_rand_conf.o printmat.o map.o \ + pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ + cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ + energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \ + cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ + mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ + eigen.o blas.o add.o entmcm.o minim_mcmf.o \ + MP.o compare_s1.o prng.o \ + banach.o rmsd.o elecont.o dihed_cons.o \ + sc_move.o local_move.o \ + intcartderiv.o lagrangian_lesyng.o\ + stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ + surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ + q_measure.o gnmr1.o test.o dfa.o ssMD.o + +no_option: + +GAB: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DUNRES -DISNAN -DMP -DMPI \ + -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC +GAB: BIN = ../../../bin/unres/MD/unres_ifort_MPICH_GAB.exe +GAB: ${object} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + +E0LL2Y: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DUNRES -DISNAN -DMP -DMPI \ + -DSPLITELE -DLANG0 +E0LL2Y: BIN = ../../../bin/unres/MD/unres_ifort_MPICH_E0LL2Y.exe +E0LL2Y: ${object} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + +xdrf/libxdrf.a: + cd xdrf && make + + +clean: + /bin/rm -f *.o && /bin/rm -f compinfo && cd xdrf && make clean + +test.o: test.F + ${FC} ${FFLAGS} ${CPPFLAGS} test.F + +chainbuild.o: chainbuild.F + ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F + +matmult.o: matmult.f + ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f + +parmread.o : parmread.F + ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F + +intcor.o : intcor.f + ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f + +cartder.o : cartder.F + ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F + +readpdb.o : readpdb.F + ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.F + +sumsld.o : sumsld.f + ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f + +cored.o : cored.f + ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f + +rmdd.o : rmdd.f + ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f + +energy_p_new_barrier.o : energy_p_new_barrier.F + ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new_barrier.F + +gradient_p.o : gradient_p.F + ${FC} ${FFLAGSE} ${CPPFLAGS} gradient_p.F + +energy_p_new-sep_barrier.o : energy_p_new-sep_barrier.F + ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep_barrier.F + +lagrangian_lesyng.o : lagrangian_lesyng.F + ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F + +MD_A-MTS.o : MD_A-MTS.F + ${FC} ${FFLAGSE} ${CPPFLAGS} MD_A-MTS.F + +blas.o : blas.f + ${FC} ${FFLAGS1} blas.f + +add.o : add.f + ${FC} ${FFLAGS1} add.f + +eigen.o : eigen.f + ${FC} ${FFLAGS2} eigen.f + +proc_proc.o: proc_proc.c + ${CC} ${CFLAGS} proc_proc.c diff --git a/source/unres/src_MD-DFA-restraints/Makefile_aix_xlf b/source/unres/src_MD-DFA-restraints/Makefile_aix_xlf new file mode 100644 index 0000000..b226425 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/Makefile_aix_xlf @@ -0,0 +1,113 @@ +CPPFLAGS = -WF,-DUNRES -WF,-DMP -WF,-DMPI -WF,-DSPLITELE -WF,-DISNAN -WF,-DAIX +#-DPROCOR +## -DMOMENT +#-DCO_BIAS +#-DCRYST_TOR +#-DDEBUG + +INSTALL_DIR = +# +FC= mpxlf90 -qfixed -w + +OPT = -q64 + +FFLAGS = -c ${OPT} -O3 +FFLAGS1 = -c ${OPT} -O2 +FFLAGS2 = -c ${OPT} -O +FFLAGSE = -c ${OPT} -O4 + + +BIN = ${HOME}/UNRES/bin/unres_MD.exe +LIBS = -qipa + +ARCH = LINUX +PP = /lib/cpp -P + +all: unresCSA + +.SUFFIXES: .F +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + +object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ + matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ + pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ + cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ + energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \ + cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ + mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ + eigen.o blas.o add.o entmcm.o minim_mcmf.o \ + together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ + indexx.o MP.o compare_s1.o prng_32.o \ + test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ + sc_move.o local_move.o \ + intcartderiv.o lagrangian_lesyng.o\ + stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ + surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ + q_measure.o gnmr1.o + + +unresCSA: ${objectCSA} + cc -o compinfo compinfo.c + ./compinfo + ${FC} ${FFLAGS} cinfo.f + ${FC} ${OPT} ${objectCSA} cinfo.o ${LIBS} -o ${BIN} + + +clean: + /bin/rm *.o + /bin/rm *.il + +newconf.o: newconf.f + ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f + +bank.o: bank.F + ${FC} ${FFLAGS} ${CPPFLAGS} bank.F + +diff12.o: diff12.f + ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f + +csa.o: csa.f + ${FC} ${FFLAGS} ${CPPFLAGS} csa.f + +shift.o: shift.F + ${FC} ${FFLAGS} ${CPPFLAGS} shift.F + +ran.o: ran.f + ${FC} ${FFLAGS} ${CPPFLAGS} ran.f + +together.o: together.F + ${FC} ${FFLAGS} ${CPPFLAGS} together.F + +test.o: test.F + ${FC} ${FFLAGS} ${CPPFLAGS} test.F + +chainbuild.o: chainbuild.F + ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F + +matmult.o: matmult.f + ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f + +parmread.o : parmread.F + ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F + +intcor.o : intcor.f + ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f + +cartder.o : cartder.F + ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F + +readpdb.o : readpdb.f + ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.f + +sumsld.o : sumsld.f + ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f + +cored.o : cored.f + ${FC} ${FFLAGS} ${CPPFLAGS} cored.f + +rmdd.o : rmdd.f + ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f + +energy_p_new.o : energy_p_new.F + ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F diff --git a/source/unres/src_MD-DFA-restraints/Makefile_bigben b/source/unres/src_MD-DFA-restraints/Makefile_bigben new file mode 100644 index 0000000..261dd8e --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/Makefile_bigben @@ -0,0 +1,138 @@ +# +FC= ftn +OPT = -fast \ +-Minline=name:scalar2,scalar,transpose2,matvec2,prodmat3 \ +-Mprefetch=distance:8,nta + +#OPT = -C -g +#OPT1 = -g -fast +OPT1 = ${OPT} +OPT2 = -fast +OPT2 = ${OPT} +OPTE = ${OPT} + +FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include +FFLAGS1 = -c ${OPT1} -I$(INSTALL_DIR)/include +FFLAGS2 = -c ${OPT2} -I$(INSTALL_DIR)/include +FFLAGSE = ${FFLAGS} + +CFLAGS = -DSGI -c + +BIN = ../bin/unres_MD_Tc_procor-newmat-novec-noparint_barrier_corr-split.exe +LIBS = xdrf/libxdrf.a + +CPPFLAGS = -DLINUX -DUNRES -DMP -DMPI -DPGI \ + -DSPLITELE -DPROCOR -DAMD64 -DLANG0 \ +#-DTIMING \ +# -DCRYST_BOND -DCRYST_THETA -DCRYST_SC +#-DPARVEC #-DPARINT -DPARINTDER + +ARCH = LINUX +PP = /lib/cpp -P + + +all: unres + +.SUFFIXES: .F +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + + +object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ + matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ + pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ + cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ + energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \ + cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ + mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ + eigen.o blas.o add.o entmcm.o minim_mcmf.o \ + together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ + indexx.o MP.o compare_s1.o prng.o \ + test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ + sc_move.o local_move.o \ + intcartderiv.o lagrangian_lesyng.o\ + stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ + surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ + q_measure.o gnmr1.o + +unres: ${object} proc_proc.o + cc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + ${FC} ${OPT} ${object} proc_proc.o cinfo.o ${LIBS} -o ${BIN} + + +clean: + /bin/rm *.o + +newconf.o: newconf.f + ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f + +bank.o: bank.F + ${FC} ${FFLAGS} ${CPPFLAGS} bank.F + +diff12.o: diff12.f + ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f + +csa.o: csa.f + ${FC} ${FFLAGS} ${CPPFLAGS} csa.f + +shift.o: shift.F + ${FC} ${FFLAGS} ${CPPFLAGS} shift.F + +ran.o: ran.f + ${FC} ${FFLAGS} ${CPPFLAGS} ran.f + +together.o: together.F + ${FC} ${FFLAGS} ${CPPFLAGS} together.F + +test.o: test.F + ${FC} ${FFLAGS} ${CPPFLAGS} test.F + +chainbuild.o: chainbuild.F + ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F + +matmult.o: matmult.f + ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f + +parmread.o : parmread.F + ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F + +intcor.o : intcor.f + ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f + +cartder.o : cartder.F + ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F + +readpdb.o : readpdb.f + ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.f + +sumsld.o : sumsld.f + ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f + +cored.o : cored.f + ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f + +rmdd.o : rmdd.f + ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f + +energy_p_new.o : energy_p_new.F + ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F + +energy_p_new-sep.o : energy_p_new-sep.F + ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep.F + +lagrangian_lesyng.o : lagrangian_lesyng.F + ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F + +blas.o : blas.f + ${FC} ${FFLAGS1} blas.f + +add.o : add.f + ${FC} ${FFLAGS1} add.f + +eigen.o : eigen.f + ${FC} ${FFLAGS1} eigen.f + +proc_proc.o: proc_proc.c + ${CC} ${CFLAGS} proc_proc.c diff --git a/source/unres/src_MD-DFA-restraints/Makefile_bigben-oldparm b/source/unres/src_MD-DFA-restraints/Makefile_bigben-oldparm new file mode 100644 index 0000000..87d66c7 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/Makefile_bigben-oldparm @@ -0,0 +1,136 @@ +# +FC= ftn +OPT = -fast \ +-Minline=name:scalar2,scalar,transpose2,matvec2,prodmat3 \ +-Mprefetch=distance:8,nta + +#OPT = -C -g +#OPT1 = -g -fast +OPT1 = -fast +OPT2 = -fast +OPT2 = ${OPT} +OPTE = ${OPT} + +FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include +FFLAGS1 = -c ${OPT1} -I$(INSTALL_DIR)/include +FFLAGS2 = -c ${OPT2} -I$(INSTALL_DIR)/include +FFLAGSE = ${FFLAGS} + +CFLAGS = -DSGI -c + +BIN = ../bin/unres_MD_Tc_procor-newmat-matgather-oldparm.exe +LIBS = xdrf/libxdrf.a + +CPPFLAGS = -DLINUX -DUNRES -DMP -DMPI -DPGI \ + -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -DPARVEC -DPARINT -DPARINTDER \ + -DCRYST_BOND -DCRYST_THETA -DCRYST_SC + +ARCH = LINUX +PP = /lib/cpp -P + + +all: unres + +.SUFFIXES: .F +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + + +object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ + matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ + pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ + cartder.o checkder_p.o econstr_local.o energy_p_new.o \ + energy_p_new-sep.o gradient_p.o minimize_p.o sumsld.o \ + cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ + mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ + eigen.o blas.o add.o entmcm.o minim_mcmf.o \ + together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ + indexx.o MP.o compare_s1.o prng.o \ + test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ + sc_move.o local_move.o \ + intcartderiv.o lagrangian_lesyng.o\ + stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ + surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ + q_measure.o gnmr1.o + +unres: ${object} proc_proc.o + cc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + ${FC} ${OPT} ${object} proc_proc.o cinfo.o ${LIBS} -o ${BIN} + + +clean: + /bin/rm *.o + +newconf.o: newconf.f + ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f + +bank.o: bank.F + ${FC} ${FFLAGS} ${CPPFLAGS} bank.F + +diff12.o: diff12.f + ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f + +csa.o: csa.f + ${FC} ${FFLAGS} ${CPPFLAGS} csa.f + +shift.o: shift.F + ${FC} ${FFLAGS} ${CPPFLAGS} shift.F + +ran.o: ran.f + ${FC} ${FFLAGS} ${CPPFLAGS} ran.f + +together.o: together.F + ${FC} ${FFLAGS} ${CPPFLAGS} together.F + +test.o: test.F + ${FC} ${FFLAGS} ${CPPFLAGS} test.F + +chainbuild.o: chainbuild.F + ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F + +matmult.o: matmult.f + ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f + +parmread.o : parmread.F + ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F + +intcor.o : intcor.f + ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f + +cartder.o : cartder.F + ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F + +readpdb.o : readpdb.f + ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.f + +sumsld.o : sumsld.f + ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f + +cored.o : cored.f + ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f + +rmdd.o : rmdd.f + ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f + +energy_p_new.o : energy_p_new.F + ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F + +energy_p_new-sep.o : energy_p_new-sep.F + ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep.F + +lagrangian_lesyng.o : lagrangian_lesyng.F + ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F + +blas.o : blas.f + ${FC} ${FFLAGS1} blas.f + +add.o : add.f + ${FC} ${FFLAGS1} add.f + +eigen.o : eigen.f + ${FC} ${FFLAGS1} eigen.f + +proc_proc.o: proc_proc.c + ${CC} ${CFLAGS} proc_proc.c diff --git a/source/unres/src_MD-DFA-restraints/Makefile_bigben-tau b/source/unres/src_MD-DFA-restraints/Makefile_bigben-tau new file mode 100644 index 0000000..ee02905 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/Makefile_bigben-tau @@ -0,0 +1,137 @@ +# +#FC= ftn +TAU_MAKEFILE=/usr/local/packages/TAU-2.17/tau-2.17/xt3/lib/Makefile.tau-mpi-pdt-pgi +FC=tau_f90.sh +OPT = -fast \ +-Minline=name:scalar2,scalar,transpose2,matvec2,prodmat3 \ +-Mprefetch=distance:8,nta + +#OPT = -C -g +#OPT1 = -g -fast +OPT1 = -fast +OPT2 = -fast +OPT2 = ${OPT} +OPTE = ${OPT} + +FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include +FFLAGS1 = -c ${OPT1} -I$(INSTALL_DIR)/include +FFLAGS2 = -c ${OPT2} -I$(INSTALL_DIR)/include +FFLAGSE = ${FFLAGS} + +CFLAGS = -DSGI -c + +BIN = ../bin/unres_MD_Tc_procor-newmat-noparint-barrier-tau.exe +LIBS = xdrf/libxdrf.a + +CPPFLAGS = -DLINUX -DUNRES -DMP -DMPI -DPGI \ + -DSPLITELE -DPROCOR -DAMD64 -DLANG0 -DPARVEC + +ARCH = LINUX +PP = /lib/cpp -P + + +all: unres + +.SUFFIXES: .F +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + + +object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ + matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ + pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ + cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ + energy_p_new-sep.o gradient_p.o minimize_p.o sumsld.o \ + cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ + mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ + eigen.o blas.o add.o entmcm.o minim_mcmf.o \ + together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ + indexx.o MP.o compare_s1.o prng.o \ + test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ + sc_move.o local_move.o \ + intcartderiv.o lagrangian_lesyng.o\ + stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ + surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ + q_measure.o gnmr1.o + +unres: ${object} proc_proc.o + cc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + ${FC} ${OPT} ${object} proc_proc.o cinfo.o ${LIBS} -o ${BIN} + + +clean: + /bin/rm *.o *.pp.[fF] *.pp.inst.[fF] + +newconf.o: newconf.f + ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f + +bank.o: bank.F + ${FC} ${FFLAGS} ${CPPFLAGS} bank.F + +diff12.o: diff12.f + ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f + +csa.o: csa.f + ${FC} ${FFLAGS} ${CPPFLAGS} csa.f + +shift.o: shift.F + ${FC} ${FFLAGS} ${CPPFLAGS} shift.F + +ran.o: ran.f + ${FC} ${FFLAGS} ${CPPFLAGS} ran.f + +together.o: together.F + ${FC} ${FFLAGS} ${CPPFLAGS} together.F + +test.o: test.F + ${FC} ${FFLAGS} ${CPPFLAGS} test.F + +chainbuild.o: chainbuild.F + ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F + +matmult.o: matmult.f + ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f + +parmread.o : parmread.F + ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F + +intcor.o : intcor.f + ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f + +cartder.o : cartder.F + ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F + +readpdb.o : readpdb.f + ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.f + +sumsld.o : sumsld.f + ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f + +cored.o : cored.f + ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f + +rmdd.o : rmdd.f + ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f + +energy_p_new.o : energy_p_new.F + ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F + +energy_p_new-sep.o : energy_p_new-sep.F + ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep.F + +lagrangian_lesyng.o : lagrangian_lesyng.F + ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F + +blas.o : blas.f + ${FC} ${FFLAGS1} blas.f + +add.o : add.f + ${FC} ${FFLAGS1} add.f + +eigen.o : eigen.f + ${FC} ${FFLAGS1} eigen.f + +proc_proc.o: proc_proc.c + ${CC} ${CFLAGS} proc_proc.c diff --git a/source/unres/src_MD-DFA-restraints/Makefile_galera b/source/unres/src_MD-DFA-restraints/Makefile_galera new file mode 100644 index 0000000..899ec63 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/Makefile_galera @@ -0,0 +1,147 @@ +CPPFLAGS = -DPROCOR -DLINUX -DUNRES -DMP -DMPI -DPGI -DISNAN \ + -DSPLITELE -DAMD64 -DLANG0 +# -DCRYST_BOND -DCRYST_THETA -DCRYST_SC +#-DCRYST_TOR +# -DPROCOR +# -DTSCSC +#-DTIMING \ +# -DCRYST_BOND -DCRYST_THETA -DCRYST_SC +# -DMOMENT +#-DPARVEC +#-DPARINT -DPARINTDER + +#INSTALL_DIR = /users/local/mpi64/mpich-1.2.7p1/ +#INSTALL_DIR = /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh +#INSTALL_DIR = /users/software/mpich2.x86_64/ +#INSTALL_DIR = /opt/mpi/mvapich2 +INSTALL_DIR = /opt/mpi/mvapich + +FC= ifort +FCL= ${INSTALL_DIR}/bin/mpif77 + +OPT = -O3 -ip -w -xHost + +FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include +FFLAGS1 = -c -w -g -d2 -CA -CB -I$(INSTALL_DIR)/include +FFLAGS2 = -c -w -g -O0 -I$(INSTALL_DIR)/include +FFLAGSE = -c -w -xHost -O3 -ipo -ipo_obj -no-prec-div -opt_report -I$(INSTALL_DIR)/include + + +BIN = ../bin/unres_Tc_procor_new_em64_hremd_mpich1.exe +LIBS = -L$(INSTALL_DIR)/lib -lmpich xdrf_em64/libxdrf.a -lpthread + +ARCH = LINUX +PP = /lib/cpp -P + + +all: unres + +.SUFFIXES: .F +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + + +object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ + matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ + pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ + cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ + energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \ + cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ + mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ + eigen.o blas.o add.o entmcm.o minim_mcmf.o \ + together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ + indexx.o MP.o compare_s1.o prng_32.o \ + test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ + sc_move.o local_move.o \ + intcartderiv.o lagrangian_lesyng.o\ + stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ + surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ + q_measure.o gnmr1.o + +unres: ${object} + cc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + ${FCL} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + + +clean: + /bin/rm *.o *.il + +newconf.o: newconf.f + ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f + +bank.o: bank.F + ${FC} ${FFLAGS} ${CPPFLAGS} bank.F + +diff12.o: diff12.f + ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f + +csa.o: csa.f + ${FC} ${FFLAGS} ${CPPFLAGS} csa.f + +shift.o: shift.F + ${FC} ${FFLAGS} ${CPPFLAGS} shift.F + +ran.o: ran.f + ${FC} ${FFLAGS} ${CPPFLAGS} ran.f + +together.o: together.F + ${FC} ${FFLAGS} ${CPPFLAGS} together.F + +test.o: test.F + ${FC} ${FFLAGS} ${CPPFLAGS} test.F + +chainbuild.o: chainbuild.F + ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F + +matmult.o: matmult.f + ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f + +parmread.o : parmread.F + ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F + +intcor.o : intcor.f + ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f + +cartder.o : cartder.F + ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F + +readpdb.o : readpdb.F + ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.F + +sumsld.o : sumsld.f + ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f + +cored.o : cored.f + ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f + +rmdd.o : rmdd.f + ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f + +energy_p_new_barrier.o : energy_p_new_barrier.F + ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new_barrier.F + +gradient_p.o : gradient_p.F + ${FC} ${FFLAGSE} ${CPPFLAGS} gradient_p.F + +energy_p_new-sep_barrier.o : energy_p_new-sep_barrier.F + ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep_barrier.F + +lagrangian_lesyng.o : lagrangian_lesyng.F + ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F + +MD_A-MTS.o : MD_A-MTS.F + ${FC} ${FFLAGSE} ${CPPFLAGS} MD_A-MTS.F + +blas.o : blas.f + ${FC} ${FFLAGS1} blas.f + +add.o : add.f + ${FC} ${FFLAGS1} add.f + +eigen.o : eigen.f + ${FC} ${FFLAGS2} eigen.f + +proc_proc.o: proc_proc.c + ${CC} ${CFLAGS} proc_proc.c diff --git a/source/unres/src_MD-DFA-restraints/Makefile_intrepid b/source/unres/src_MD-DFA-restraints/Makefile_intrepid new file mode 100644 index 0000000..2b57f9e --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/Makefile_intrepid @@ -0,0 +1,151 @@ +# +FC=/bgsys/drivers/ppcfloor/comm/bin/mpixlf77 +OPT = -O4 -qarch=450 -qtune=450 +#OPT = -O3 -qarch=450 -qtune=450 -qdebug=function_trace +#OPT = -O -qarch=450 -qtune=450 +#OPT = -O0 -C -g -qarch=450 -qtune=450 #-qdebug=function_trace +#-Minline=name:scalar2,scalar,transpose2,matvec2,prodmat3 \ +#-Mprefetch=distance:8,nta + +#OPT1 = -O -g -qarch=450 -qtune=450 +#OPT1 = -O -g -qarch=450 -qtune=450 -qdebug=function_trace +OPT1 = ${OPT} +#OPT2 = -O2 -qarch=450 -qtune=450 +#OPT2 = -O2 -qarch=450 -qtune=450 -qdebug=function_trace +OPT2 = ${OPT} +#OPTE = -O4 -qarch=450 -qtune=450 +#OPTE = -O4 -qarch=450 -qtune=450 +OPTE=${OPT} + +CFLAGS = -c +FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include +FFLAGS1 = -c ${OPT1} -I$(INSTALL_DIR)/include +FFLAGS2 = -c ${OPT2} -I$(INSTALL_DIR)/include +FFLAGSE = -c ${OPTE} -I$(INSTALL_DIR)/include + +BIN = ../bin/unres_MD_Tc_procor-newparm-O4-parcorr.exe +#BIN = ../bin/unres_MD_Tc_procor-newparm-O4-PARINT-parcorr.exe +#BIN = ../bin/unres_MD_Tc_procor-newparm-parvecmatint-O4-notau1.exe +#BIN = ../bin/unres_MD_Tc_procor-newparm-O4-notau1.exe +#LIBS = xdrf/libxdrf.a /home/liwo/UNRES/LIB/libmemmon.a +LIBS = xdrf/libxdrf.a + +CPPFLAGS = -WF,-DAIX -WF,-DISNAN -WF,-DUNRES -WF,-DMP -WF,-DMPI -WF,-DPGI \ + -WF,-DSPLITELE -WF,-DPROCOR -WF,-DAMD64 -WF,-DLANG0 +#-WF,-DPARINT -WF,-DPARINTDER +#-WF,-DPARVEC -WF,-DPARMAT -WF,-DMATGATHER + +ARCH = LINUX +PP = /lib/cpp -P + + +all: unres + +obj: ${object} + +.SUFFIXES: .F +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + + +object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ + matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ + pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ + cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ + energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \ + cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ + mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ + eigen.o blas.o add.o entmcm.o minim_mcmf.o \ + together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ + indexx.o MP.o compare_s1.o prng.o \ + test.o banach.o distfit.o rmsd.o elecont.o dihed_cons.o \ + sc_move.o local_move.o \ + intcartderiv.o lagrangian_lesyng.o\ + stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ + surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ + q_measure.o gnmr1.o + +unres: ${object} + ${CC} -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + + +clean: + /bin/rm *.o + +newconf.o: newconf.f + ${FC} ${FFLAGS} ${CPPFLAGS} newconf.f + +bank.o: bank.F + ${FC} ${FFLAGS} ${CPPFLAGS} bank.F + +diff12.o: diff12.f + ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f + +csa.o: csa.f + ${FC} ${FFLAGS} ${CPPFLAGS} csa.f + +shift.o: shift.F + ${FC} ${FFLAGS} ${CPPFLAGS} shift.F + +ran.o: ran.f + ${FC} ${FFLAGS} ${CPPFLAGS} ran.f + +together.o: together.F + ${FC} ${FFLAGS} ${CPPFLAGS} together.F + +test.o: test.F + ${FC} ${FFLAGS} ${CPPFLAGS} test.F + +chainbuild.o: chainbuild.F + ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F + +matmult.o: matmult.f + ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f + +parmread.o : parmread.F + ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F + +intcor.o : intcor.f + ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f + +cartder.o : cartder.F + ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F + +readpdb.o : readpdb.f + ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.f + +sumsld.o : sumsld.f + ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f + +cored.o : cored.f + ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f + +rmdd.o : rmdd.f + ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f + +eigen.o : eigen.f + ${FC} ${FFLAGS1} ${CPPFLAGS} eigen.f + +blas.o : blas.f + ${FC} ${FFLAGS1} ${CPPFLAGS} blas.f + +add.o : add.f + ${FC} ${FFLAGS1} ${CPPFLAGS} add.f + +energy_p_new.o : energy_p_new.F + ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new.F + +energy_p_new-sep.o : energy_p_new-sep.F + ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep.F + +lagrangian_lesyng.o : lagrangian_lesyng.F + ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F + +proc_proc.o: proc_proc.c + ${CC} ${CFLAGS} proc_proc.c + +compinfo: compinfo.c + ${CC} ${CFLAGS} compinfo.c diff --git a/source/unres/src_MD-DFA-restraints/Makefile_single_gfortran b/source/unres/src_MD-DFA-restraints/Makefile_single_gfortran new file mode 100644 index 0000000..3ef2052 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/Makefile_single_gfortran @@ -0,0 +1,130 @@ +FC= gfortran +FFLAGS = -c ${OPT} -I. +FFLAGS1 = -c ${OPT1} -I. + +CC = cc + +CFLAGS = -DLINUX -DPGI -c + +OPT = -O -fbounds-check -g +OPT1 = -g + +#OPT = -fbounds-check -g +#OPT1 = -g + +# -Mvect <---slows down +# -Minline=name:matmat2 <---false convergence + +LIBS = -Lxdrf -lxdrf +#-DMOMENT +#-DCO_BIAS +#-DCRYST_TOR +#-DDEBUG + +ARCH = LINUX +PP = /lib/cpp -P + +all: + @echo "Specify force field: GAB or E0LL2Y" + +.SUFFIXES: .F +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + +object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ + matmult.o readrtns.o parmread.o gen_rand_conf.o printmat.o map.o \ + pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ + cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ + energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \ + cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ + mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ + eigen.o blas.o add.o entmcm.o minim_mcmf.o \ + MP.o compare_s1.o prng_32.o \ + banach.o rmsd.o elecont.o dihed_cons.o \ + sc_move.o local_move.o \ + intcartderiv.o lagrangian_lesyng.o\ + stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ + surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ + q_measure.o gnmr1.o test.o ssMD.o + +GAB: CPPFLAGS = -DPROCOR -DLINUX -DUNRES -DISNAN \ + -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC +GAB: BIN = ../../../bin/unres/MD/unres_gfortran_single_GAB.exe +GAB: ${object} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + +E0LL2Y: CPPFLAGS = -DPROCOR -DLINUX -DUNRES -DISNAN \ + -DSPLITELE -DLANG0 +E0LL2Y: BIN = ../../../bin/unres/MD/unres_gfortran_single_E0LL2Y.exe +E0LL2Y: ${object} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + +xdrf/libxdrf.a: + cd xdrf && make + +clean: + /bin/rm -f *.o && /bin/rm -f compinfo && cd xdrf && make clean + +newconf.o: newconf.F + ${FC} ${FFLAGS} ${CPPFLAGS} newconf.F + +bank.o: bank.F + ${FC} ${FFLAGS} ${CPPFLAGS} bank.F + +diff12.o: diff12.f + ${FC} ${FFLAGS} ${CPPFLAGS} diff12.f + +csa.o: csa.f + ${FC} ${FFLAGS1} ${CPPFLAGS} csa.f + +shift.o: shift.F + ${FC} ${FFLAGS1} ${CPPFLAGS} shift.F + +ran.o: ran.f + ${FC} ${FFLAGS1} ${CPPFLAGS} ran.f + +together.o: together.F + ${FC} ${FFLAGS} ${CPPFLAGS} together.F + +fitsq.o: fitsq.f + ${FC} ${FFLAGS1} ${CPPFLAGS} fitsq.f + +rmsd.o: rmsd.F + ${FC} ${FFLAGS1} ${CPPFLAGS} rmsd.F + +contact.o: contact.f + ${FC} ${FFLAGS1} ${CPPFLAGS} contact.f + +minim_jlee.o: minim_jlee.F + ${FC} ${FFLAGS1} ${CPPFLAGS} minim_jlee.F + +minimize_p.o: minimize_p.F + ${FC} ${FFLAGS1} ${CPPFLAGS} minimize_p.F + +gen_rand_conf.o: gen_rand_conf.F + ${FC} ${FFLAGS} ${CPPFLAGS} gen_rand_conf.F + + +test.o: test.F + ${FC} ${FFLAGS1} ${CPPFLAGS} test.F + +elecont.o: elecont.f + ${FC} ${FFLAGS} ${CPPFLAGS} elecont.f + +eigen.o: eigen.f + ${FC} ${FFLAGS1} eigen.f + +blas.o: blas.f + ${FC} ${FFLAGS1} blas.f + +add.o: add.f + ${FC} ${FFLAGS1} add.f + +proc_proc.o: proc_proc.c + ${CC} ${CFLAGS} proc_proc.c diff --git a/source/unres/src_MD-DFA-restraints/Makefile_single_ifort b/source/unres/src_MD-DFA-restraints/Makefile_single_ifort new file mode 100644 index 0000000..c651e39 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/Makefile_single_ifort @@ -0,0 +1,127 @@ +FC = ifort +FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include +FFLAGS1 = -c -w -g -d2 -CA -CB -I$(INSTALL_DIR)/include +FFLAGS2 = -c -w -g -O0 -I$(INSTALL_DIR)/include +FFLAGSE = -c -w -O3 -ipo -ipo_obj -opt_report -I$(INSTALL_DIR)/include + +CC = cc + +CFLAGS = -DLINUX -DPGI -c + +OPT = -O3 -ip -w + +# -Mvect <---slows down +# -Minline=name:matmat2 <---false convergence + +LIBS = -Lxdrf -lxdrf +#-DMOMENT +#-DCO_BIAS +#-DCRYST_TOR +#-DDEBUG + +ARCH = LINUX +PP = /lib/cpp -P + +all: + @echo "Specify force field: GAB or E0LL2Y" + +.SUFFIXES: .F +.F.o: + ${FC} ${FFLAGS} ${CPPFLAGS} $*.F + +object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ + matmult.o readrtns.o parmread.o gen_rand_conf.o printmat.o map.o \ + pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ + cartder.o checkder_p.o econstr_local.o energy_p_new_barrier.o \ + energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \ + cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ + mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o djacob.o \ + eigen.o blas.o add.o entmcm.o minim_mcmf.o \ + MP.o compare_s1.o prng.o \ + banach.o rmsd.o elecont.o dihed_cons.o \ + sc_move.o local_move.o \ + intcartderiv.o lagrangian_lesyng.o\ + stochfric.o kinetic_lesyng.o MD_A-MTS.o moments.o int_to_cart.o \ + surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ + q_measure.o gnmr1.o test.o ssMD.o + +GAB: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DUNRES -DISNAN \ + -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC +GAB: BIN = ../../../bin/unres/MD/unres_ifort_single_GAB.exe +GAB: ${object} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + +E0LL2Y: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DUNRES -DISNAN \ + -DSPLITELE -DLANG0 +E0LL2Y: BIN = ../../../bin/unres/MD/unres_ifort_single_E0LL2Y.exe +E0LL2Y: ${object} xdrf/libxdrf.a + cc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + +xdrf/libxdrf.a: + cd xdrf && make + +clean: + /bin/rm -f *.o && /bin/rm -f compinfo && cd xdrf && make clean + +test.o: test.F + ${FC} ${FFLAGS} ${CPPFLAGS} test.F + +chainbuild.o: chainbuild.F + ${FC} ${FFLAGS} ${CPPFLAGS} chainbuild.F + +matmult.o: matmult.f + ${FC} ${FFLAGS} ${CPPFLAGS} matmult.f + +parmread.o : parmread.F + ${FC} ${FFLAGS} ${CPPFLAGS} parmread.F + +intcor.o : intcor.f + ${FC} ${FFLAGS} ${CPPFLAGS} intcor.f + +cartder.o : cartder.F + ${FC} ${FFLAGS} ${CPPFLAGS} cartder.F + +readpdb.o : readpdb.F + ${FC} ${FFLAGS2} ${CPPFLAGS} readpdb.F + +sumsld.o : sumsld.f + ${FC} ${FFLAGS} ${CPPFLAGS} sumsld.f + +cored.o : cored.f + ${FC} ${FFLAGS1} ${CPPFLAGS} cored.f + +rmdd.o : rmdd.f + ${FC} ${FFLAGS} ${CPPFLAGS} rmdd.f + +energy_p_new_barrier.o : energy_p_new_barrier.F + ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new_barrier.F + +gradient_p.o : gradient_p.F + ${FC} ${FFLAGSE} ${CPPFLAGS} gradient_p.F + +energy_p_new-sep_barrier.o : energy_p_new-sep_barrier.F + ${FC} ${FFLAGSE} ${CPPFLAGS} energy_p_new-sep_barrier.F + +lagrangian_lesyng.o : lagrangian_lesyng.F + ${FC} ${FFLAGSE} ${CPPFLAGS} lagrangian_lesyng.F + +MD_A-MTS.o : MD_A-MTS.F + ${FC} ${FFLAGSE} ${CPPFLAGS} MD_A-MTS.F + +blas.o : blas.f + ${FC} ${FFLAGS1} blas.f + +add.o : add.f + ${FC} ${FFLAGS1} add.f + +eigen.o : eigen.f + ${FC} ${FFLAGS2} eigen.f + +proc_proc.o: proc_proc.c + ${CC} ${CFLAGS} proc_proc.c diff --git a/source/unres/src_MD-DFA-restraints/README b/source/unres/src_MD-DFA-restraints/README new file mode 100644 index 0000000..2b1d2be --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/README @@ -0,0 +1,2 @@ +The program will fail if there is no "Makefile" file. +You must copy (cp MakeXXXX Makefile) or use a symbolic link (ln -s MakeXXXX Makefile) before compiling. diff --git a/source/unres/src_MD-DFA-restraints/add.f b/source/unres/src_MD-DFA-restraints/add.f new file mode 100644 index 0000000..fd91a70 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/add.f @@ -0,0 +1,28 @@ + SUBROUTINE ABRT + STOP 'IN ABRT' + END +C*MODULE MTHLIB *DECK VCLR + SUBROUTINE VCLR(A,INCA,N) +C + IMPLICIT DOUBLE PRECISION(A-H,O-Z) +C + DIMENSION A(*) +C + PARAMETER (ZERO=0.0D+00) +C +C ----- ZERO OUT VECTOR -A-, USING INCREMENT -INCA- ----- +C + IF (INCA .NE. 1) GO TO 200 + DO 110 L=1,N + A(L) = ZERO + 110 CONTINUE + RETURN +C + 200 CONTINUE + LA=1-INCA + DO 210 L=1,N + LA=LA+INCA + A(LA) = ZERO + 210 CONTINUE + RETURN + END diff --git a/source/unres/src_MD-DFA-restraints/arcos.f b/source/unres/src_MD-DFA-restraints/arcos.f new file mode 100644 index 0000000..f054118 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/arcos.f @@ -0,0 +1,9 @@ + FUNCTION ARCOS(X) + implicit real*8 (a-h,o-z) + include 'COMMON.GEO' + IF (DABS(X).LT.1.0D0) GOTO 1 + ARCOS=PIPOL*(1.0d0-DSIGN(1.0D0,X)) + RETURN + 1 ARCOS=DACOS(X) + RETURN + END diff --git a/source/unres/src_MD-DFA-restraints/banach.f b/source/unres/src_MD-DFA-restraints/banach.f new file mode 100644 index 0000000..7c43d77 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/banach.f @@ -0,0 +1,99 @@ +C +C********************** + SUBROUTINE BANACH(N,NMAX,A,X,osob) +C********************** +C Banachiewicz + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + DIMENSION A(NMAX,NMAX),X(NMAX),D(MAXRES6) + COMMON /BANII/ D + logical osob + osob=.false. + if (dabs(a(1,1)).lt.1.0d-15) then + osob=.true. + return + endif + D(1)=1./A(1,1) + DO 80 I=2,N + A(I,1)=A(1,I) + DO 81 J=2,I-1 + XX=A(J,I) + DO 82 K=1,J-1 + XX=XX-A(I,K)*A(J,K) + 82 CONTINUE + A(I,J)=XX + 81 CONTINUE + XX=A(I,I) + JJJJ=I-1 + DO 83 J=1,JJJJ + AIJ=A(I,J) + AIJD=AIJ*D(J) + A(I,J)=AIJD + XX=XX-AIJ*AIJD + 83 CONTINUE + if (dabs(xx).lt.1.0d-15) then + osob=.true. + return + endif + D(I)=1./XX + 80 CONTINUE +C + CALL BANAII(N,NMAX,A,X) + RETURN + END +C************************ + SUBROUTINE BANAII(N,NMAX,A,X) +C************************ + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + DIMENSION A(NMAX,NMAX),X(NMAX),D(MAXRES6) + COMMON /BANII/ D + DO 90 I=1,N + Z=X(I) + JJJJ=I-1 + DO 91 J=JJJJ,1,-1 + Z=Z-A(I,J)*X(J) + 91 CONTINUE + X(I)=Z + 90 CONTINUE + DO 92 I=N,1,-1 + Z=X(I)*D(I) + JJJJ=I+1 + DO 93 J=JJJJ,N + Z=Z-A(J,I)*X(J) + 93 CONTINUE + X(I)=Z + 92 CONTINUE + RETURN + END +C + SUBROUTINE MATINVERT(N,NMAX,A,A1,osob) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + DIMENSION A(NMAX,NMAX),A1(NMAX,NMAX),D(MAXRES6) + COMMON /BANII/ D + DIMENSION X(NMAX) + logical osob + DO I=1,N + X(I)=0.0 + ENDDO + X(1)=1.0 + CALL BANACH(N,NMAX,A,X,osob) + if (osob) return + DO I=1,N + A1(I,1)=X(I) + ENDDO + DO I=2,N + DO J=1,N + X(J)=0.0 + ENDDO + X(I)=1.0 + CALL BANAII(N,NMAX,A,X) + DO J=1,N + A1(J,I)=X(J) + ENDDO + ENDDO + RETURN + END + + diff --git a/source/unres/src_MD-DFA-restraints/blas.f b/source/unres/src_MD-DFA-restraints/blas.f new file mode 100644 index 0000000..142d821 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/blas.f @@ -0,0 +1,575 @@ +C 10 NOV 94 - MWS - DNRM2: REMOVE FTNCHECK WARNINGS +C 11 JUN 94 - MWS - INCLUDE A COPY OF DGEMV (LEVEL TWO ROUTINE) +C 11 AUG 87 - MWS - SANITIZE FLOATING POINT CONSTANTS IN DNRM2 +C 26 MAR 87 - MWS - USE GENERIC SIGN IN DROTG +C 28 NOV 86 - STE - SUPPLY ALL LEVEL ONE BLAS +C 7 JUL 86 - JAB - SANITIZE FLOATING POINT CONSTANTS +C +C BASIC LINEAR ALGEBRA SUBPROGRAMS (BLAS) FROM LINPACK (LEVEL 1) +C +C THIS MODULE SHOULD BE COMPILED ONLY IF SPECIALLY CODED +C VERSIONS OF THESE ROUTINES ARE NOT AVAILABLE ON THE TARGET MACHINE +C +C*MODULE BLAS1 *DECK DASUM + DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) +C +C TAKES THE SUM OF THE ABSOLUTE VALUES. +C JACK DONGARRA, LINPACK, 3/11/78. +C + DOUBLE PRECISION DX(1),DTEMP + INTEGER I,INCX,M,MP1,N,NINCX +C + DASUM = 0.0D+00 + DTEMP = 0.0D+00 + IF(N.LE.0)RETURN + IF(INCX.EQ.1)GO TO 20 +C +C CODE FOR INCREMENT NOT EQUAL TO 1 +C + NINCX = N*INCX + DO 10 I = 1,NINCX,INCX + DTEMP = DTEMP + ABS(DX(I)) + 10 CONTINUE + DASUM = DTEMP + RETURN +C +C CODE FOR INCREMENT EQUAL TO 1 +C +C +C CLEAN-UP LOOP +C + 20 M = MOD(N,6) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DTEMP = DTEMP + ABS(DX(I)) + 30 CONTINUE + IF( N .LT. 6 ) GO TO 60 + 40 MP1 = M + 1 + DO 50 I = MP1,N,6 + DTEMP = DTEMP + ABS(DX(I)) + ABS(DX(I + 1)) + ABS(DX(I + 2)) + * + ABS(DX(I + 3)) + ABS(DX(I + 4)) + ABS(DX(I + 5)) + 50 CONTINUE + 60 DASUM = DTEMP + RETURN + END +C*MODULE BLAS1 *DECK DAXPY + SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + DIMENSION DX(1),DY(1) +C +C CONSTANT TIMES A VECTOR PLUS A VECTOR. +C DY(I) = DY(I) + DA * DX(I) +C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. +C JACK DONGARRA, LINPACK, 3/11/78. +C + IF(N.LE.0)RETURN + IF (DA .EQ. 0.0D+00) RETURN + IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 +C +C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS +C NOT EQUAL TO 1 +C + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DY(IY) = DY(IY) + DA*DX(IX) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN +C +C CODE FOR BOTH INCREMENTS EQUAL TO 1 +C +C +C CLEAN-UP LOOP +C + 20 M = MOD(N,4) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DY(I) = DY(I) + DA*DX(I) + 30 CONTINUE + IF( N .LT. 4 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,4 + DY(I) = DY(I) + DA*DX(I) + DY(I + 1) = DY(I + 1) + DA*DX(I + 1) + DY(I + 2) = DY(I + 2) + DA*DX(I + 2) + DY(I + 3) = DY(I + 3) + DA*DX(I + 3) + 50 CONTINUE + RETURN + END +C*MODULE BLAS1 *DECK DCOPY + SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + DIMENSION DX(*),DY(*) +C +C COPIES A VECTOR. +C DY(I) <== DX(I) +C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. +C JACK DONGARRA, LINPACK, 3/11/78. +C + IF(N.LE.0)RETURN + IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 +C +C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS +C NOT EQUAL TO 1 +C + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DY(IY) = DX(IX) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN +C +C CODE FOR BOTH INCREMENTS EQUAL TO 1 +C +C +C CLEAN-UP LOOP +C + 20 M = MOD(N,7) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DY(I) = DX(I) + 30 CONTINUE + IF( N .LT. 7 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,7 + DY(I) = DX(I) + DY(I + 1) = DX(I + 1) + DY(I + 2) = DX(I + 2) + DY(I + 3) = DX(I + 3) + DY(I + 4) = DX(I + 4) + DY(I + 5) = DX(I + 5) + DY(I + 6) = DX(I + 6) + 50 CONTINUE + RETURN + END +C*MODULE BLAS1 *DECK DDOT + DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + DIMENSION DX(1),DY(1) +C +C FORMS THE DOT PRODUCT OF TWO VECTORS. +C DOT = DX(I) * DY(I) +C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. +C JACK DONGARRA, LINPACK, 3/11/78. +C + DDOT = 0.0D+00 + DTEMP = 0.0D+00 + IF(N.LE.0)RETURN + IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 +C +C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS +C NOT EQUAL TO 1 +C + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DTEMP = DTEMP + DX(IX)*DY(IY) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + DDOT = DTEMP + RETURN +C +C CODE FOR BOTH INCREMENTS EQUAL TO 1 +C +C +C CLEAN-UP LOOP +C + 20 M = MOD(N,5) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DTEMP = DTEMP + DX(I)*DY(I) + 30 CONTINUE + IF( N .LT. 5 ) GO TO 60 + 40 MP1 = M + 1 + DO 50 I = MP1,N,5 + DTEMP = DTEMP + DX(I)*DY(I) + DX(I + 1)*DY(I + 1) + + * DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4) + 50 CONTINUE + 60 DDOT = DTEMP + RETURN + END +C*MODULE BLAS1 *DECK DNRM2 + DOUBLE PRECISION FUNCTION DNRM2 ( N, DX, INCX) + INTEGER NEXT + DOUBLE PRECISION DX(1), CUTLO, CUTHI, HITEST, SUM, XMAX,ZERO,ONE + DATA ZERO, ONE /0.0D+00, 1.0D+00/ +C +C EUCLIDEAN NORM OF THE N-VECTOR STORED IN DX() WITH STORAGE +C INCREMENT INCX . +C IF N .LE. 0 RETURN WITH RESULT = 0. +C IF N .GE. 1 THEN INCX MUST BE .GE. 1 +C +C C.L.LAWSON, 1978 JAN 08 +C +C FOUR PHASE METHOD USING TWO BUILT-IN CONSTANTS THAT ARE +C HOPEFULLY APPLICABLE TO ALL MACHINES. +C CUTLO = MAXIMUM OF SQRT(U/EPS) OVER ALL KNOWN MACHINES. +C CUTHI = MINIMUM OF SQRT(V) OVER ALL KNOWN MACHINES. +C WHERE +C EPS = SMALLEST NO. SUCH THAT EPS + 1. .GT. 1. +C U = SMALLEST POSITIVE NO. (UNDERFLOW LIMIT) +C V = LARGEST NO. (OVERFLOW LIMIT) +C +C BRIEF OUTLINE OF ALGORITHM.. +C +C PHASE 1 SCANS ZERO COMPONENTS. +C MOVE TO PHASE 2 WHEN A COMPONENT IS NONZERO AND .LE. CUTLO +C MOVE TO PHASE 3 WHEN A COMPONENT IS .GT. CUTLO +C MOVE TO PHASE 4 WHEN A COMPONENT IS .GE. CUTHI/M +C WHERE M = N FOR X() REAL AND M = 2*N FOR COMPLEX. +C +C VALUES FOR CUTLO AND CUTHI.. +C FROM THE ENVIRONMENTAL PARAMETERS LISTED IN THE IMSL CONVERTER +C DOCUMENT THE LIMITING VALUES ARE AS FOLLOWS.. +C CUTLO, S.P. U/EPS = 2**(-102) FOR HONEYWELL. CLOSE SECONDS ARE +C UNIVAC AND DEC AT 2**(-103) +C THUS CUTLO = 2**(-51) = 4.44089E-16 +C CUTHI, S.P. V = 2**127 FOR UNIVAC, HONEYWELL, AND DEC. +C THUS CUTHI = 2**(63.5) = 1.30438E19 +C CUTLO, D.P. U/EPS = 2**(-67) FOR HONEYWELL AND DEC. +C THUS CUTLO = 2**(-33.5) = 8.23181D-11 +C CUTHI, D.P. SAME AS S.P. CUTHI = 1.30438D+19 +C DATA CUTLO, CUTHI / 8.232D-11, 1.304D+19 / +C DATA CUTLO, CUTHI / 4.441E-16, 1.304E19 / + DATA CUTLO, CUTHI / 8.232D-11, 1.304D+19 / +C + J=0 + IF(N .GT. 0) GO TO 10 + DNRM2 = ZERO + GO TO 300 +C + 10 ASSIGN 30 TO NEXT + SUM = ZERO + NN = N * INCX +C BEGIN MAIN LOOP + I = 1 + 20 GO TO NEXT,(30, 50, 70, 110) + 30 IF( ABS(DX(I)) .GT. CUTLO) GO TO 85 + ASSIGN 50 TO NEXT + XMAX = ZERO +C +C PHASE 1. SUM IS ZERO +C + 50 IF( DX(I) .EQ. ZERO) GO TO 200 + IF( ABS(DX(I)) .GT. CUTLO) GO TO 85 +C +C PREPARE FOR PHASE 2. + ASSIGN 70 TO NEXT + GO TO 105 +C +C PREPARE FOR PHASE 4. +C + 100 I = J + ASSIGN 110 TO NEXT + SUM = (SUM / DX(I)) / DX(I) + 105 XMAX = ABS(DX(I)) + GO TO 115 +C +C PHASE 2. SUM IS SMALL. +C SCALE TO AVOID DESTRUCTIVE UNDERFLOW. +C + 70 IF( ABS(DX(I)) .GT. CUTLO ) GO TO 75 +C +C COMMON CODE FOR PHASES 2 AND 4. +C IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. +C + 110 IF( ABS(DX(I)) .LE. XMAX ) GO TO 115 + SUM = ONE + SUM * (XMAX / DX(I))**2 + XMAX = ABS(DX(I)) + GO TO 200 +C + 115 SUM = SUM + (DX(I)/XMAX)**2 + GO TO 200 +C +C +C PREPARE FOR PHASE 3. +C + 75 SUM = (SUM * XMAX) * XMAX +C +C +C FOR REAL OR D.P. SET HITEST = CUTHI/N +C FOR COMPLEX SET HITEST = CUTHI/(2*N) +C + 85 HITEST = CUTHI/N +C +C PHASE 3. SUM IS MID-RANGE. NO SCALING. +C + DO 95 J =I,NN,INCX + IF(ABS(DX(J)) .GE. HITEST) GO TO 100 + 95 SUM = SUM + DX(J)**2 + DNRM2 = SQRT( SUM ) + GO TO 300 +C + 200 CONTINUE + I = I + INCX + IF ( I .LE. NN ) GO TO 20 +C +C END OF MAIN LOOP. +C +C COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. +C + DNRM2 = XMAX * SQRT(SUM) + 300 CONTINUE + RETURN + END +C*MODULE BLAS1 *DECK DROT + SUBROUTINE DROT (N,DX,INCX,DY,INCY,C,S) + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + DIMENSION DX(1),DY(1) +C +C APPLIES A PLANE ROTATION. +C DX(I) = C*DX(I) + S*DY(I) +C DY(I) = -S*DX(I) + C*DY(I) +C JACK DONGARRA, LINPACK, 3/11/78. +C + IF(N.LE.0)RETURN + IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 +C +C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL +C TO 1 +C + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DTEMP = C*DX(IX) + S*DY(IY) + DY(IY) = C*DY(IY) - S*DX(IX) + DX(IX) = DTEMP + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN +C +C CODE FOR BOTH INCREMENTS EQUAL TO 1 +C + 20 DO 30 I = 1,N + DTEMP = C*DX(I) + S*DY(I) + DY(I) = C*DY(I) - S*DX(I) + DX(I) = DTEMP + 30 CONTINUE + RETURN + END +C*MODULE BLAS1 *DECK DROTG + SUBROUTINE DROTG(DA,DB,C,S) +C +C CONSTRUCT GIVENS PLANE ROTATION. +C JACK DONGARRA, LINPACK, 3/11/78. +C + DOUBLE PRECISION DA,DB,C,S,ROE,SCALE,R,Z + DOUBLE PRECISION ZERO, ONE +C + PARAMETER (ZERO=0.0D+00, ONE=1.0D+00) +C +C----------------------------------------------------------------------- +C +C + ROE = DB + IF( ABS(DA) .GT. ABS(DB) ) ROE = DA + SCALE = ABS(DA) + ABS(DB) + IF( SCALE .NE. ZERO ) GO TO 10 + C = ONE + S = ZERO + R = ZERO + GO TO 20 +C + 10 R = SCALE*SQRT((DA/SCALE)**2 + (DB/SCALE)**2) + R = SIGN(ONE,ROE)*R + C = DA/R + S = DB/R + 20 Z = ONE + IF( ABS(DA) .GT. ABS(DB) ) Z = S + IF( ABS(DB) .GE. ABS(DA) .AND. C .NE. ZERO ) Z = ONE/C + DA = R + DB = Z + RETURN + END +C*MODULE BLAS1 *DECK DSCAL + SUBROUTINE DSCAL(N,DA,DX,INCX) + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + DIMENSION DX(1) +C +C SCALES A VECTOR BY A CONSTANT. +C DX(I) = DA * DX(I) +C USES UNROLLED LOOPS FOR INCREMENT EQUAL TO ONE. +C JACK DONGARRA, LINPACK, 3/11/78. +C + IF(N.LE.0)RETURN + IF(INCX.EQ.1)GO TO 20 +C +C CODE FOR INCREMENT NOT EQUAL TO 1 +C + NINCX = N*INCX + DO 10 I = 1,NINCX,INCX + DX(I) = DA*DX(I) + 10 CONTINUE + RETURN +C +C CODE FOR INCREMENT EQUAL TO 1 +C +C +C CLEAN-UP LOOP +C + 20 M = MOD(N,5) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DX(I) = DA*DX(I) + 30 CONTINUE + IF( N .LT. 5 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,5 + DX(I) = DA*DX(I) + DX(I + 1) = DA*DX(I + 1) + DX(I + 2) = DA*DX(I + 2) + DX(I + 3) = DA*DX(I + 3) + DX(I + 4) = DA*DX(I + 4) + 50 CONTINUE + RETURN + END +C*MODULE BLAS1 *DECK DSWAP + SUBROUTINE DSWAP (N,DX,INCX,DY,INCY) + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + DIMENSION DX(1),DY(1) +C +C INTERCHANGES TWO VECTORS. +C DX(I) <==> DY(I) +C USES UNROLLED LOOPS FOR INCREMENTS EQUAL ONE. +C JACK DONGARRA, LINPACK, 3/11/78. +C + IF(N.LE.0)RETURN + IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 +C +C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL +C TO 1 +C + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DTEMP = DX(IX) + DX(IX) = DY(IY) + DY(IY) = DTEMP + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN +C +C CODE FOR BOTH INCREMENTS EQUAL TO 1 +C +C +C CLEAN-UP LOOP +C + 20 M = MOD(N,3) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DTEMP = DX(I) + DX(I) = DY(I) + DY(I) = DTEMP + 30 CONTINUE + IF( N .LT. 3 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,3 + DTEMP = DX(I) + DX(I) = DY(I) + DY(I) = DTEMP + DTEMP = DX(I + 1) + DX(I + 1) = DY(I + 1) + DY(I + 1) = DTEMP + DTEMP = DX(I + 2) + DX(I + 2) = DY(I + 2) + DY(I + 2) = DTEMP + 50 CONTINUE + RETURN + END +C*MODULE BLAS1 *DECK IDAMAX + INTEGER FUNCTION IDAMAX(N,DX,INCX) + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + DIMENSION DX(1) +C +C FINDS THE INDEX OF ELEMENT HAVING MAX. ABSOLUTE VALUE. +C JACK DONGARRA, LINPACK, 3/11/78. +C + IDAMAX = 0 + IF( N .LT. 1 ) RETURN + IDAMAX = 1 + IF(N.EQ.1)RETURN + IF(INCX.EQ.1)GO TO 20 +C +C CODE FOR INCREMENT NOT EQUAL TO 1 +C + IX = 1 + RMAX = ABS(DX(1)) + IX = IX + INCX + DO 10 I = 2,N + IF(ABS(DX(IX)).LE.RMAX) GO TO 5 + IDAMAX = I + RMAX = ABS(DX(IX)) + 5 IX = IX + INCX + 10 CONTINUE + RETURN +C +C CODE FOR INCREMENT EQUAL TO 1 +C + 20 RMAX = ABS(DX(1)) + DO 30 I = 2,N + IF(ABS(DX(I)).LE.RMAX) GO TO 30 + IDAMAX = I + RMAX = ABS(DX(I)) + 30 CONTINUE + RETURN + END +C*MODULE BLAS *DECK DGEMV + SUBROUTINE DGEMV(FORMA,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY) + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + CHARACTER*1 FORMA + DIMENSION A(LDA,*),X(*),Y(*) + PARAMETER (ZERO=0.0D+00, ONE=1.0D+00) +C +C CLONE OF -DGEMV- WRITTEN BY MIKE SCHMIDT +C + LOCY = 1 + IF(FORMA.EQ.'T') GO TO 200 +C +C Y = ALPHA * A * X + BETA * Y +C + IF(ALPHA.EQ.ONE .AND. BETA.EQ.ZERO) THEN + DO 110 I=1,M + Y(LOCY) = DDOT(N,A(I,1),LDA,X,INCX) + LOCY = LOCY+INCY + 110 CONTINUE + ELSE + DO 120 I=1,M + Y(LOCY) = ALPHA*DDOT(N,A(I,1),LDA,X,INCX) + BETA*Y(LOCY) + LOCY = LOCY+INCY + 120 CONTINUE + END IF + RETURN +C +C Y = ALPHA * A-TRANSPOSE * X + BETA * Y +C + 200 CONTINUE + IF(ALPHA.EQ.ONE .AND. BETA.EQ.ZERO) THEN + DO 210 I=1,N + Y(LOCY) = DDOT(M,A(1,I),1,X,INCX) + LOCY = LOCY+INCY + 210 CONTINUE + ELSE + DO 220 I=1,N + Y(LOCY) = ALPHA*DDOT(M,A(1,I),1,X,INCX) + BETA*Y(LOCY) + LOCY = LOCY+INCY + 220 CONTINUE + END IF + RETURN + END diff --git a/source/unres/src_MD-DFA-restraints/bond_move.f b/source/unres/src_MD-DFA-restraints/bond_move.f new file mode 100644 index 0000000..4843f60 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/bond_move.f @@ -0,0 +1,124 @@ + subroutine bond_move(nbond,nstart,psi,lprint,error) +C Move NBOND fragment starting from the CA(nstart) by angle PSI. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + integer nbond,nstart + double precision psi + logical fail,error,lprint + include 'COMMON.GEO' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.MCM' + dimension x(3),e(3,3),e1(3),e2(3),e3(3),rot(3,3),trans(3,3) + error=.false. + nend=nstart+nbond + if (print_mc.gt.2) then + write (iout,*) 'nstart=',nstart,' nend=',nend,' nbond=',nbond + write (iout,*) 'psi=',psi + write (iout,'(a)') 'Original coordinates of the fragment' + do i=nstart,nend + write (iout,'(i5,3f10.5)') i,(c(j,i),j=1,3) + enddo + endif + if (nstart.lt.1 .or. nend .gt.nres .or. nbond.lt.2 .or. + & nbond.ge.nres-1) then + write (iout,'(a)') 'Bad data in BOND_MOVE.' + error=.true. + return + endif +C Generate the reference system. + i2=nend + i3=nstart + i4=nstart+1 + call refsys(i2,i3,i4,e1,e2,e3,error) +C Return, if couldn't define the reference system. + if (error) return +C Compute the transformation matrix. + cospsi=dcos(psi) + sinpsi=dsin(psi) + rot(1,1)=1.0D0 + rot(1,2)=0.0D0 + rot(1,3)=0.0D0 + rot(2,1)=0.0D0 + rot(2,2)=cospsi + rot(2,3)=-sinpsi + rot(3,1)=0.0D0 + rot(3,2)=sinpsi + rot(3,3)=cospsi + do i=1,3 + e(1,i)=e1(i) + e(2,i)=e2(i) + e(3,i)=e3(i) + enddo + + if (print_mc.gt.2) then + write (iout,'(a)') 'Reference system and matrix r:' + do i=1,3 + write(iout,'(i5,2(3f10.5,5x))')i,(e(i,j),j=1,3),(rot(i,j),j=1,3) + enddo + endif + + call matmult(rot,e,trans) + do i=1,3 + do j=1,3 + e(i,1)=e1(i) + e(i,2)=e2(i) + e(i,3)=e3(i) + enddo + enddo + call matmult(e,trans,trans) + + if (lprint) then + write (iout,'(a)') 'The trans matrix:' + do i=1,3 + write (iout,'(i5,3f10.5)') i,(trans(i,j),j=1,3) + enddo + endif + + do i=nstart,nend + do j=1,3 + rij=c(j,nstart) + do k=1,3 + rij=rij+trans(j,k)*(c(k,i)-c(k,nstart)) + enddo + x(j)=rij + enddo + do j=1,3 + c(j,i)=x(j) + enddo + enddo + + if (lprint) then + write (iout,'(a)') 'Rotated coordinates of the fragment' + do i=nstart,nend + write (iout,'(i5,3f10.5)') i,(c(j,i),j=1,3) + enddo + endif + +c call int_from_cart(.false.,lprint) + if (nstart.gt.1) then + theta(nstart+1)=alpha(nstart-1,nstart,nstart+1) + phi(nstart+2)=beta(nstart-1,nstart,nstart+1,nstart+2) + if (nstart.gt.2) phi(nstart+1)= + & beta(nstart-2,nstart-1,nstart,nstart+1) + endif + if (nend.lt.nres) then + theta(nend+1)=alpha(nend-1,nend,nend+1) + phi(nend+1)=beta(nend-2,nend-1,nend,nend+1) + if (nend.lt.nres-1) phi(nend+2)= + & beta(nend-1,nend,nend+1,nend+2) + endif + if (print_mc.gt.2) then + write (iout,'(/a,i3,a,i3,a/)') + & 'Moved internal coordinates of the ',nstart,'-',nend, + & ' fragment:' + do i=nstart+1,nstart+2 + write (iout,'(i5,2f10.5)') i,rad2deg*theta(i),rad2deg*phi(i) + enddo + do i=nend+1,nend+2 + write (iout,'(i5,2f10.5)') i,rad2deg*theta(i),rad2deg*phi(i) + enddo + endif + return + end diff --git a/source/unres/src_MD-DFA-restraints/build.txt b/source/unres/src_MD-DFA-restraints/build.txt new file mode 100644 index 0000000..a5eba7c --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/build.txt @@ -0,0 +1 @@ +cmake /users/czarek/UNRES/GIT/unres/ -DMPIF_LOCAL_DIR=/users/software/mpich-1.2.7p1_intel-10.1_em64_ssh \ No newline at end of file diff --git a/source/unres/src_MD-DFA-restraints/cartder.F b/source/unres/src_MD-DFA-restraints/cartder.F new file mode 100644 index 0000000..e2e8c1a --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/cartder.F @@ -0,0 +1,314 @@ + subroutine cartder +*********************************************************************** +* This subroutine calculates the derivatives of the consecutive virtual +* bond vectors and the SC vectors in the virtual-bond angles theta and +* virtual-torsional angles phi, as well as the derivatives of SC vectors +* in the angles alpha and omega, describing the location of a side chain +* in its local coordinate system. +* +* The derivatives are stored in the following arrays: +* +* DDCDV - the derivatives of virtual-bond vectors DC in theta and phi. +* The structure is as follows: +* +* dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0, 0, 0 +* dDC(x,3)/dT(4),...,dDC(z,3)/dT(4),dDC(x,3)/dP(4),dDC(y,4)/dP(4),dDC(z,4)/dP(4) +* . . . . . . . . . . . . . . . . . . +* dDC(x,N-1)/dT(4),...,dDC(z,N-1)/dT(4),dDC(x,N-1)/dP(4),dDC(y,N-1)/dP(4),dDC(z,N-1)/dP(4) +* . +* . +* . +* dDC(x,N-1)/dT(N),...,dDC(z,N-1)/dT(N),dDC(x,N-1)/dP(N),dDC(y,N-1)/dP(N),dDC(z,N-1)/dP(N) +* +* DXDV - the derivatives of the side-chain vectors in theta and phi. +* The structure is same as above. +* +* DCDS - the derivatives of the side chain vectors in the local spherical +* andgles alph and omega: +* +* dX(x,2)/dA(2),dX(y,2)/dA(2),dX(z,2)/dA(2),dX(x,2)/dO(2),dX(y,2)/dO(2),dX(z,2)/dO(2) +* dX(x,3)/dA(3),dX(y,3)/dA(3),dX(z,3)/dA(3),dX(x,3)/dO(3),dX(y,3)/dO(3),dX(z,3)/dO(3) +* . +* . +* . +* dX(x,N-1)/dA(N-1),dX(y,N-1)/dA(N-1),dX(z,N-1)/dA(N-1),dX(x,N-1)/dO(N-1),dX(y,N-1)/dO(N-1),dX(z,N-1)/dO(N-1) +* +* Version of March '95, based on an early version of November '91. +* +*********************************************************************** + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + dimension drt(3,3,maxres),rdt(3,3,maxres),dp(3,3),temp(3,3), + & fromto(3,3,maxdim),prordt(3,3,maxres),prodrt(3,3,maxres) + dimension xx(3),xx1(3) +c common /przechowalnia/ fromto +* get the position of the jth ijth fragment of the chain coordinate system +* in the fromto array. + indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1 +* +* calculate the derivatives of transformation matrix elements in theta +* + do i=1,nres-2 + rdt(1,1,i)=-rt(1,2,i) + rdt(1,2,i)= rt(1,1,i) + rdt(1,3,i)= 0.0d0 + rdt(2,1,i)=-rt(2,2,i) + rdt(2,2,i)= rt(2,1,i) + rdt(2,3,i)= 0.0d0 + rdt(3,1,i)=-rt(3,2,i) + rdt(3,2,i)= rt(3,1,i) + rdt(3,3,i)= 0.0d0 + enddo +* +* derivatives in phi +* + do i=2,nres-2 + drt(1,1,i)= 0.0d0 + drt(1,2,i)= 0.0d0 + drt(1,3,i)= 0.0d0 + drt(2,1,i)= rt(3,1,i) + drt(2,2,i)= rt(3,2,i) + drt(2,3,i)= rt(3,3,i) + drt(3,1,i)=-rt(2,1,i) + drt(3,2,i)=-rt(2,2,i) + drt(3,3,i)=-rt(2,3,i) + enddo +* +* generate the matrix products of type r(i)t(i)...r(j)t(j) +* + do i=2,nres-2 + ind=indmat(i,i+1) + do k=1,3 + do l=1,3 + temp(k,l)=rt(k,l,i) + enddo + enddo + do k=1,3 + do l=1,3 + fromto(k,l,ind)=temp(k,l) + enddo + enddo + do j=i+1,nres-2 + ind=indmat(i,j+1) + do k=1,3 + do l=1,3 + dpkl=0.0d0 + do m=1,3 + dpkl=dpkl+temp(k,m)*rt(m,l,j) + enddo + dp(k,l)=dpkl + fromto(k,l,ind)=dpkl + enddo + enddo + do k=1,3 + do l=1,3 + temp(k,l)=dp(k,l) + enddo + enddo + enddo + enddo +* +* Calculate derivatives. +* + ind1=0 + do i=1,nres-2 + ind1=ind1+1 +* +* Derivatives of DC(i+1) in theta(i+2) +* + do j=1,3 + do k=1,2 + dpjk=0.0D0 + do l=1,3 + dpjk=dpjk+prod(j,l,i)*rdt(l,k,i) + enddo + dp(j,k)=dpjk + prordt(j,k,i)=dp(j,k) + enddo + dp(j,3)=0.0D0 + dcdv(j,ind1)=vbld(i+1)*dp(j,1) + enddo +* +* Derivatives of SC(i+1) in theta(i+2) +* + xx1(1)=-0.5D0*xloc(2,i+1) + xx1(2)= 0.5D0*xloc(1,i+1) + do j=1,3 + xj=0.0D0 + do k=1,2 + xj=xj+r(j,k,i)*xx1(k) + enddo + xx(j)=xj + enddo + do j=1,3 + rj=0.0D0 + do k=1,3 + rj=rj+prod(j,k,i)*xx(k) + enddo + dxdv(j,ind1)=rj + enddo +* +* Derivatives of SC(i+1) in theta(i+3). The have to be handled differently +* than the other off-diagonal derivatives. +* + do j=1,3 + dxoiij=0.0D0 + do k=1,3 + dxoiij=dxoiij+dp(j,k)*xrot(k,i+2) + enddo + dxdv(j,ind1+1)=dxoiij + enddo +cd print *,ind1+1,(dxdv(j,ind1+1),j=1,3) +* +* Derivatives of DC(i+1) in phi(i+2) +* + do j=1,3 + do k=1,3 + dpjk=0.0 + do l=2,3 + dpjk=dpjk+prod(j,l,i)*drt(l,k,i) + enddo + dp(j,k)=dpjk + prodrt(j,k,i)=dp(j,k) + enddo + dcdv(j+3,ind1)=vbld(i+1)*dp(j,1) + enddo +* +* Derivatives of SC(i+1) in phi(i+2) +* + xx(1)= 0.0D0 + xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i) + xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i) + do j=1,3 + rj=0.0D0 + do k=2,3 + rj=rj+prod(j,k,i)*xx(k) + enddo + dxdv(j+3,ind1)=-rj + enddo +* +* Derivatives of SC(i+1) in phi(i+3). +* + do j=1,3 + dxoiij=0.0D0 + do k=1,3 + dxoiij=dxoiij+dp(j,k)*xrot(k,i+2) + enddo + dxdv(j+3,ind1+1)=dxoiij + enddo +* +* Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru +* theta(nres) and phi(i+3) thru phi(nres). +* + do j=i+1,nres-2 + ind1=ind1+1 + ind=indmat(i+1,j+1) +cd print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1 + do k=1,3 + do l=1,3 + tempkl=0.0D0 + do m=1,2 + tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind) + enddo + temp(k,l)=tempkl + enddo + enddo +cd print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3) +cd print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3) +cd print '(9f8.3)',((temp(k,l),l=1,3),k=1,3) +* Derivatives of virtual-bond vectors in theta + do k=1,3 + dcdv(k,ind1)=vbld(i+1)*temp(k,1) + enddo +cd print '(3f8.3)',(dcdv(k,ind1),k=1,3) +* Derivatives of SC vectors in theta + do k=1,3 + dxoijk=0.0D0 + do l=1,3 + dxoijk=dxoijk+temp(k,l)*xrot(l,j+2) + enddo + dxdv(k,ind1+1)=dxoijk + enddo +* +*--- Calculate the derivatives in phi +* + do k=1,3 + do l=1,3 + tempkl=0.0D0 + do m=1,3 + tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind) + enddo + temp(k,l)=tempkl + enddo + enddo + do k=1,3 + dcdv(k+3,ind1)=vbld(i+1)*temp(k,1) + enddo + do k=1,3 + dxoijk=0.0D0 + do l=1,3 + dxoijk=dxoijk+temp(k,l)*xrot(l,j+2) + enddo + dxdv(k+3,ind1+1)=dxoijk + enddo + enddo + enddo +* +* Derivatives in alpha and omega: +* + do i=2,nres-1 +c dsci=dsc(itype(i)) + dsci=vbld(i+nres) +#ifdef OSF + alphi=alph(i) + omegi=omeg(i) + if(alphi.ne.alphi) alphi=100.0 + if(omegi.ne.omegi) omegi=-100.0 +#else + alphi=alph(i) + omegi=omeg(i) +#endif +cd print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi + cosalphi=dcos(alphi) + sinalphi=dsin(alphi) + cosomegi=dcos(omegi) + sinomegi=dsin(omegi) + temp(1,1)=-dsci*sinalphi + temp(2,1)= dsci*cosalphi*cosomegi + temp(3,1)=-dsci*cosalphi*sinomegi + temp(1,2)=0.0D0 + temp(2,2)=-dsci*sinalphi*sinomegi + temp(3,2)=-dsci*sinalphi*cosomegi + theta2=pi-0.5D0*theta(i+1) + cost2=dcos(theta2) + sint2=dsin(theta2) + jjj=0 +cd print *,((temp(l,k),l=1,3),k=1,2) + do j=1,2 + xp=temp(1,j) + yp=temp(2,j) + xxp= xp*cost2+yp*sint2 + yyp=-xp*sint2+yp*cost2 + zzp=temp(3,j) + xx(1)=xxp + xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1) + xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1) + do k=1,3 + dj=0.0D0 + do l=1,3 + dj=dj+prod(k,l,i-1)*xx(l) + enddo + dxds(jjj+k,i)=dj + enddo + jjj=jjj+3 + enddo + enddo + return + end + diff --git a/source/unres/src_MD-DFA-restraints/cartprint.f b/source/unres/src_MD-DFA-restraints/cartprint.f new file mode 100644 index 0000000..d79409e --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/cartprint.f @@ -0,0 +1,19 @@ + subroutine cartprint + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + write (iout,100) + do i=1,nres + write (iout,110) restyp(itype(i)),i,c(1,i),c(2,i), + & c(3,i),c(1,nres+i),c(2,nres+i),c(3,nres+i) + enddo + 100 format (//' alpha-carbon coordinates ', + & ' centroid coordinates'/ + 1 ' ', 6X,'X',11X,'Y',11X,'Z', + & 10X,'X',11X,'Y',11X,'Z') + 110 format (a,'(',i3,')',6f12.5) + return + end diff --git a/source/unres/src_MD-DFA-restraints/chainbuild.F b/source/unres/src_MD-DFA-restraints/chainbuild.F new file mode 100644 index 0000000..45a1a53 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/chainbuild.F @@ -0,0 +1,274 @@ + subroutine chainbuild +C +C Build the virtual polypeptide chain. Side-chain centroids are moveable. +C As of 2/17/95. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.INTERACT' + logical lprn +C Set lprn=.true. for debugging + lprn = .false. +C +C Define the origin and orientation of the coordinate system and locate the +C first three CA's and SC(2). +C + call orig_frame +* +* Build the alpha-carbon chain. +* + do i=4,nres + call locate_next_res(i) + enddo +C +C First and last SC must coincide with the corresponding CA. +C + do j=1,3 + dc(j,nres+1)=0.0D0 + dc_norm(j,nres+1)=0.0D0 + dc(j,nres+nres)=0.0D0 + dc_norm(j,nres+nres)=0.0D0 + c(j,nres+1)=c(j,1) + c(j,nres+nres)=c(j,nres) + enddo +* +* Temporary diagnosis +* + if (lprn) then + + call cartprint + write (iout,'(/a)') 'Recalculated internal coordinates' + do i=2,nres-1 + do j=1,3 + c(j,maxres2)=0.5D0*(c(j,i-1)+c(j,i+1)) + enddo + be=0.0D0 + if (i.gt.3) be=rad2deg*beta(i-3,i-2,i-1,i) + be1=rad2deg*beta(nres+i,i,maxres2,i+1) + alfai=0.0D0 + if (i.gt.2) alfai=rad2deg*alpha(i-2,i-1,i) + write (iout,1212) restyp(itype(i)),i,dist(i-1,i), + & alfai,be,dist(nres+i,i),rad2deg*alpha(nres+i,i,maxres2),be1 + enddo + 1212 format (a3,'(',i3,')',2(f10.5,2f10.2)) + + endif + + return + end +c------------------------------------------------------------------------- + subroutine orig_frame +C +C Define the origin and orientation of the coordinate system and locate +C the first three atoms. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + include 'COMMON.VAR' + cost=dcos(theta(3)) + sint=dsin(theta(3)) + t(1,1,1)=-cost + t(1,2,1)=-sint + t(1,3,1)= 0.0D0 + t(2,1,1)=-sint + t(2,2,1)= cost + t(2,3,1)= 0.0D0 + t(3,1,1)= 0.0D0 + t(3,2,1)= 0.0D0 + t(3,3,1)= 1.0D0 + r(1,1,1)= 1.0D0 + r(1,2,1)= 0.0D0 + r(1,3,1)= 0.0D0 + r(2,1,1)= 0.0D0 + r(2,2,1)= 1.0D0 + r(2,3,1)= 0.0D0 + r(3,1,1)= 0.0D0 + r(3,2,1)= 0.0D0 + r(3,3,1)= 1.0D0 + do i=1,3 + do j=1,3 + rt(i,j,1)=t(i,j,1) + enddo + enddo + do i=1,3 + do j=1,3 + prod(i,j,1)=0.0D0 + prod(i,j,2)=t(i,j,1) + enddo + prod(i,i,1)=1.0D0 + enddo + c(1,1)=0.0D0 + c(2,1)=0.0D0 + c(3,1)=0.0D0 + c(1,2)=vbld(2) + c(2,2)=0.0D0 + c(3,2)=0.0D0 + dc(1,0)=0.0d0 + dc(2,0)=0.0D0 + dc(3,0)=0.0D0 + dc(1,1)=vbld(2) + dc(2,1)=0.0D0 + dc(3,1)=0.0D0 + dc_norm(1,0)=0.0D0 + dc_norm(2,0)=0.0D0 + dc_norm(3,0)=0.0D0 + dc_norm(1,1)=1.0D0 + dc_norm(2,1)=0.0D0 + dc_norm(3,1)=0.0D0 + do j=1,3 + dc_norm(j,2)=prod(j,1,2) + dc(j,2)=vbld(3)*prod(j,1,2) + c(j,3)=c(j,2)+dc(j,2) + enddo + call locate_side_chain(2) + return + end +c----------------------------------------------------------------------------- + subroutine locate_next_res(i) +C +C Locate CA(i) and SC(i-1) +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.INTERACT' +C +C Define the rotation matrices corresponding to CA(i) +C +#ifdef OSF + theti=theta(i) + if (theti.ne.theti) theti=100.0 + phii=phi(i) + if (phii.ne.phii) phii=180.0 +#else + theti=theta(i) + phii=phi(i) +#endif + cost=dcos(theti) + sint=dsin(theti) + cosphi=dcos(phii) + sinphi=dsin(phii) +* Define the matrices of the rotation about the virtual-bond valence angles +* theta, T(i,j,k), virtual-bond dihedral angles gamma (miscalled PHI in this +* program), R(i,j,k), and, the cumulative matrices of rotation RT + t(1,1,i-2)=-cost + t(1,2,i-2)=-sint + t(1,3,i-2)= 0.0D0 + t(2,1,i-2)=-sint + t(2,2,i-2)= cost + t(2,3,i-2)= 0.0D0 + t(3,1,i-2)= 0.0D0 + t(3,2,i-2)= 0.0D0 + t(3,3,i-2)= 1.0D0 + r(1,1,i-2)= 1.0D0 + r(1,2,i-2)= 0.0D0 + r(1,3,i-2)= 0.0D0 + r(2,1,i-2)= 0.0D0 + r(2,2,i-2)=-cosphi + r(2,3,i-2)= sinphi + r(3,1,i-2)= 0.0D0 + r(3,2,i-2)= sinphi + r(3,3,i-2)= cosphi + rt(1,1,i-2)=-cost + rt(1,2,i-2)=-sint + rt(1,3,i-2)=0.0D0 + rt(2,1,i-2)=sint*cosphi + rt(2,2,i-2)=-cost*cosphi + rt(2,3,i-2)=sinphi + rt(3,1,i-2)=-sint*sinphi + rt(3,2,i-2)=cost*sinphi + rt(3,3,i-2)=cosphi + call matmult(prod(1,1,i-2),rt(1,1,i-2),prod(1,1,i-1)) + do j=1,3 + dc_norm(j,i-1)=prod(j,1,i-1) + dc(j,i-1)=vbld(i)*prod(j,1,i-1) + c(j,i)=c(j,i-1)+dc(j,i-1) + enddo +cd print '(2i3,2(3f10.5,5x))', i-1,i,(dc(j,i-1),j=1,3),(c(j,i),j=1,3) +C +C Now calculate the coordinates of SC(i-1) +C + call locate_side_chain(i-1) + return + end +c----------------------------------------------------------------------------- + subroutine locate_side_chain(i) +C +C Locate the side-chain centroid i, 1 < i < NRES. Put in C(*,NRES+i). +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.INTERACT' + dimension xx(3) + +c dsci=dsc(itype(i)) +c dsci_inv=dsc_inv(itype(i)) + dsci=vbld(i+nres) + dsci_inv=vbld_inv(i+nres) +#ifdef OSF + alphi=alph(i) + omegi=omeg(i) + if (alphi.ne.alphi) alphi=100.0 + if (omegi.ne.omegi) omegi=-100.0 +#else + alphi=alph(i) + omegi=omeg(i) +#endif + cosalphi=dcos(alphi) + sinalphi=dsin(alphi) + cosomegi=dcos(omegi) + sinomegi=dsin(omegi) + xp= dsci*cosalphi + yp= dsci*sinalphi*cosomegi + zp=-dsci*sinalphi*sinomegi +* Now we have to rotate the coordinate system by 180-theta(i)/2 so as to get its +* X-axis aligned with the vector DC(*,i) + theta2=pi-0.5D0*theta(i+1) + cost2=dcos(theta2) + sint2=dsin(theta2) + xx(1)= xp*cost2+yp*sint2 + xx(2)=-xp*sint2+yp*cost2 + xx(3)= zp +cd print '(a3,i3,3f10.5,5x,3f10.5)',restyp(itype(i)),i, +cd & xp,yp,zp,(xx(k),k=1,3) + do j=1,3 + xloc(j,i)=xx(j) + enddo +* Bring the SC vectors to the common coordinate system. + xx(1)=xloc(1,i) + xx(2)=xloc(2,i)*r(2,2,i-1)+xloc(3,i)*r(2,3,i-1) + xx(3)=xloc(2,i)*r(3,2,i-1)+xloc(3,i)*r(3,3,i-1) + do j=1,3 + xrot(j,i)=xx(j) + enddo + do j=1,3 + rj=0.0D0 + do k=1,3 + rj=rj+prod(j,k,i-1)*xx(k) + enddo + dc(j,nres+i)=rj + dc_norm(j,nres+i)=rj*dsci_inv + c(j,nres+i)=c(j,i)+rj + enddo + return + end diff --git a/source/unres/src_MD-DFA-restraints/change.awk b/source/unres/src_MD-DFA-restraints/change.awk new file mode 100644 index 0000000..d192a6e --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/change.awk @@ -0,0 +1,11 @@ +{ + if($0==" include 'COMMON.LANGEVIN'") { + print "#ifndef LANG0" + print " include 'COMMON.LANGEVIN'" + print "#else" + print " include 'COMMON.LANGEVIN.lang0'" + print "#endif" + }else{ + print $0 + } +} diff --git a/source/unres/src_MD-DFA-restraints/check_bond.f b/source/unres/src_MD-DFA-restraints/check_bond.f new file mode 100644 index 0000000..c8a4ad1 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/check_bond.f @@ -0,0 +1,20 @@ + subroutine check_bond +C Subroutine is checking if the fitted function which describs sc_rot_pot +C is correct, printing, alpha,beta, energy, data - for some known theta. +C theta angle is read from the input file. Sc_rot_pot are printed +C for the second residue in sequance. + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.INTERACT' + include 'COMMON.CHAIN' + double precision energia(0:n_ene) + it=itype(2) + do i=1,101 + vbld(nres+2)=0.5d0+0.05d0*(i-1) + call chainbuild + call etotal(energia) + write (2,*) vbld(nres+2),energia(17) + enddo + return + end diff --git a/source/unres/src_MD-DFA-restraints/check_sc_distr.f b/source/unres/src_MD-DFA-restraints/check_sc_distr.f new file mode 100644 index 0000000..db2ed1b --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/check_sc_distr.f @@ -0,0 +1,43 @@ + subroutine check_sc_distr + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.TIME1' + include 'COMMON.INTERACT' + include 'COMMON.NAMES' + include 'COMMON.GEO' + include 'COMMON.HEADER' + include 'COMMON.CONTROL' + logical fail + double precision varia(maxvar) + double precision hrtime,mintime,sectime + parameter (MaxSample=10000000,delt=1.0D0/MaxSample) + dimension prob(0:72,0:90) + dV=2.0D0*5.0D0*deg2rad*deg2rad + print *,'dv=',dv + do 10 it=1,1 + if (it.eq.10) goto 10 + open (20,file=restyp(it)//'_distr.sdc',status='unknown') + call gen_side(it,90.0D0*deg2rad,al,om,fail) + close (20) + goto 10 + open (20,file=restyp(it)//'_distr1.sdc',status='unknown') + do i=0,90 + do j=0,72 + prob(j,i)=0.0D0 + enddo + enddo + do isample=1,MaxSample + call gen_side(it,90.0D0*deg2rad,al,om) + indal=rad2deg*al/2 + indom=(rad2deg*om+180.0D0)/5 + prob(indom,indal)=prob(indom,indal)+delt + enddo + do i=45,90 + do j=0,72 + write (20,'(2f10.3,1pd15.5)') 2*i+0.0D0,5*j-180.0D0, + & prob(j,i)/dV + enddo + enddo + 10 continue + return + end diff --git a/source/unres/src_MD-DFA-restraints/checkder_p.F b/source/unres/src_MD-DFA-restraints/checkder_p.F new file mode 100644 index 0000000..4d0379e --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/checkder_p.F @@ -0,0 +1,713 @@ + subroutine check_cartgrad +C Check the gradient of Cartesian coordinates in internal coordinates. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.DERIV' + include 'COMMON.SCCOR' + dimension temp(6,maxres),xx(3),gg(3) + indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1 +* +* Check the gradient of the virtual-bond and SC vectors in the internal +* coordinates. +* + aincr=1.0d-7 + aincr2=5.0d-8 + call cartder + write (iout,'(a)') '**************** dx/dalpha' + write (iout,'(a)') + do i=2,nres-1 + alphi=alph(i) + alph(i)=alph(i)+aincr + do k=1,3 + temp(k,i)=dc(k,nres+i) + enddo + call chainbuild + do k=1,3 + gg(k)=(dc(k,nres+i)-temp(k,i))/aincr + xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr)) + enddo + write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') + & i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3) + write (iout,'(a)') + alph(i)=alphi + call chainbuild + enddo + write (iout,'(a)') + write (iout,'(a)') '**************** dx/domega' + write (iout,'(a)') + do i=2,nres-1 + omegi=omeg(i) + omeg(i)=omeg(i)+aincr + do k=1,3 + temp(k,i)=dc(k,nres+i) + enddo + call chainbuild + do k=1,3 + gg(k)=(dc(k,nres+i)-temp(k,i))/aincr + xx(k)=dabs((gg(k)-dxds(k+3,i))/ + & (aincr*dabs(dxds(k+3,i))+aincr)) + enddo + write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') + & i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3) + write (iout,'(a)') + omeg(i)=omegi + call chainbuild + enddo + write (iout,'(a)') + write (iout,'(a)') '**************** dx/dtheta' + write (iout,'(a)') + do i=3,nres + theti=theta(i) + theta(i)=theta(i)+aincr + do j=i-1,nres-1 + do k=1,3 + temp(k,j)=dc(k,nres+j) + enddo + enddo + call chainbuild + do j=i-1,nres-1 + ii = indmat(i-2,j) +c print *,'i=',i-2,' j=',j-1,' ii=',ii + do k=1,3 + gg(k)=(dc(k,nres+j)-temp(k,j))/aincr + xx(k)=dabs((gg(k)-dxdv(k,ii))/ + & (aincr*dabs(dxdv(k,ii))+aincr)) + enddo + write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') + & i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3) + write(iout,'(a)') + enddo + write (iout,'(a)') + theta(i)=theti + call chainbuild + enddo + write (iout,'(a)') '***************** dx/dphi' + write (iout,'(a)') + do i=4,nres + phi(i)=phi(i)+aincr + do j=i-1,nres-1 + do k=1,3 + temp(k,j)=dc(k,nres+j) + enddo + enddo + call chainbuild + do j=i-1,nres-1 + ii = indmat(i-2,j) +c print *,'ii=',ii + do k=1,3 + gg(k)=(dc(k,nres+j)-temp(k,j))/aincr + xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ + & (aincr*dabs(dxdv(k+3,ii))+aincr)) + enddo + write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') + & i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3) + write(iout,'(a)') + enddo + phi(i)=phi(i)-aincr + call chainbuild + enddo + write (iout,'(a)') '****************** ddc/dtheta' + do i=1,nres-2 + thet=theta(i+2) + theta(i+2)=thet+aincr + do j=i,nres + do k=1,3 + temp(k,j)=dc(k,j) + enddo + enddo + call chainbuild + do j=i+1,nres-1 + ii = indmat(i,j) +c print *,'ii=',ii + do k=1,3 + gg(k)=(dc(k,j)-temp(k,j))/aincr + xx(k)=dabs((gg(k)-dcdv(k,ii))/ + & (aincr*dabs(dcdv(k,ii))+aincr)) + enddo + write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') + & i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3) + write (iout,'(a)') + enddo + do j=1,nres + do k=1,3 + dc(k,j)=temp(k,j) + enddo + enddo + theta(i+2)=thet + enddo + write (iout,'(a)') '******************* ddc/dphi' + do i=1,nres-3 + phii=phi(i+3) + phi(i+3)=phii+aincr + do j=1,nres + do k=1,3 + temp(k,j)=dc(k,j) + enddo + enddo + call chainbuild + do j=i+2,nres-1 + ii = indmat(i+1,j) +c print *,'ii=',ii + do k=1,3 + gg(k)=(dc(k,j)-temp(k,j))/aincr + xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ + & (aincr*dabs(dcdv(k+3,ii))+aincr)) + enddo + write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') + & i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3) + write (iout,'(a)') + enddo + do j=1,nres + do k=1,3 + dc(k,j)=temp(k,j) + enddo + enddo + phi(i+3)=phii + enddo + return + end +C---------------------------------------------------------------------------- + subroutine check_ecart +C Check the gradient of the energy in Cartesian coordinates. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.IOUNITS' + include 'COMMON.VAR' + include 'COMMON.CONTACTS' + include 'COMMON.SCCOR' + common /srutu/ icall + dimension ggg(6),cc(3),xx(3),ddc(3),ddx(3),x(maxvar),g(maxvar) + dimension grad_s(6,maxres) + double precision energia(0:n_ene),energia1(0:n_ene) + integer uiparm(1) + double precision urparm(1) + external fdum + icg=1 + nf=0 + nfl=0 + call zerograd + aincr=1.0D-7 + print '(a)','CG processor',me,' calling CHECK_CART.' + nf=0 + icall=0 + call geom_to_var(nvar,x) + call etotal(energia(0)) + etot=energia(0) + call enerprint(energia(0)) + call gradient(nvar,x,nf,g,uiparm,urparm,fdum) + icall =1 + do i=1,nres + write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3) + enddo + do i=1,nres + do j=1,3 + grad_s(j,i)=gradc(j,i,icg) + grad_s(j+3,i)=gradx(j,i,icg) + enddo + enddo + call flush(iout) + write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors' + do i=1,nres + do j=1,3 + xx(j)=c(j,i+nres) + ddc(j)=dc(j,i) + ddx(j)=dc(j,i+nres) + enddo + do j=1,3 + dc(j,i)=dc(j,i)+aincr + do k=i+1,nres + c(j,k)=c(j,k)+aincr + c(j,k+nres)=c(j,k+nres)+aincr + enddo + call etotal(energia1(0)) + etot1=energia1(0) + ggg(j)=(etot1-etot)/aincr + dc(j,i)=ddc(j) + do k=i+1,nres + c(j,k)=c(j,k)-aincr + c(j,k+nres)=c(j,k+nres)-aincr + enddo + enddo + do j=1,3 + c(j,i+nres)=c(j,i+nres)+aincr + dc(j,i+nres)=dc(j,i+nres)+aincr + call etotal(energia1(0)) + etot1=energia1(0) + ggg(j+3)=(etot1-etot)/aincr + c(j,i+nres)=xx(j) + dc(j,i+nres)=ddx(j) + enddo + write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') + & i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6) + enddo + return + end +c---------------------------------------------------------------------------- + subroutine check_ecartint +C Check the gradient of the energy in Cartesian coordinates. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.IOUNITS' + include 'COMMON.VAR' + include 'COMMON.CONTACTS' + include 'COMMON.MD' + include 'COMMON.LOCAL' + include 'COMMON.SPLITELE' + include 'COMMON.SCCOR' + common /srutu/ icall + dimension ggg(6),ggg1(6),cc(3),xx(3),ddc(3),ddx(3),x(maxvar), + & g(maxvar) + dimension dcnorm_safe(3),dxnorm_safe(3) + dimension grad_s(6,0:maxres),grad_s1(6,0:maxres) + double precision phi_temp(maxres),theta_temp(maxres), + & alph_temp(maxres),omeg_temp(maxres) + double precision energia(0:n_ene),energia1(0:n_ene) + integer uiparm(1) + double precision urparm(1) + external fdum + r_cut=2.0d0 + rlambd=0.3d0 + icg=1 + nf=0 + nfl=0 + call intout +c call intcartderiv +c call checkintcartgrad + call zerograd + aincr=1.0D-5 + write(iout,*) 'Calling CHECK_ECARTINT.' + nf=0 + icall=0 + call geom_to_var(nvar,x) + if (.not.split_ene) then + call etotal(energia(0)) +c do i=1,nres +c write (iout,*) "atu?", gloc_sc(1,i,icg),gloc(i,icg) +c enddo + etot=energia(0) + call enerprint(energia(0)) + call flush(iout) + write (iout,*) "enter cartgrad" +c do i=1,nres +c write (iout,*) gloc_sc(1,i,icg) +c enddo + call flush(iout) + call cartgrad + write (iout,*) "exit cartgrad" + call flush(iout) + icall =1 + do i=1,nres + write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3) + enddo + do j=1,3 + grad_s(j,0)=gcart(j,0) + enddo + do i=1,nres + do j=1,3 + grad_s(j,i)=gcart(j,i) + grad_s(j+3,i)=gxcart(j,i) + enddo + enddo + else +!- split gradient check + call zerograd + call etotal_long(energia(0)) + call enerprint(energia(0)) + call flush(iout) + write (iout,*) "enter cartgrad" + call flush(iout) + call cartgrad + write (iout,*) "exit cartgrad" + call flush(iout) + icall =1 + write (iout,*) "longrange grad" + do i=1,nres + write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), + & (gxcart(j,i),j=1,3) + enddo + do j=1,3 + grad_s(j,0)=gcart(j,0) + enddo + do i=1,nres + do j=1,3 + grad_s(j,i)=gcart(j,i) + grad_s(j+3,i)=gxcart(j,i) + enddo + enddo + call zerograd + call etotal_short(energia(0)) + call enerprint(energia(0)) +c do i=1,nres +c write (iout,*) gloc_sc(1,i,icg) +c enddo + call flush(iout) + write (iout,*) "enter cartgrad" + call flush(iout) + call cartgrad + write (iout,*) "exit cartgrad" + call flush(iout) + icall =1 + write (iout,*) "shortrange grad" + do i=1,nres + write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), + & (gxcart(j,i),j=1,3) + enddo + do j=1,3 + grad_s1(j,0)=gcart(j,0) + enddo + do i=1,nres + do j=1,3 + grad_s1(j,i)=gcart(j,i) + grad_s1(j+3,i)=gxcart(j,i) + enddo + enddo + endif + write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors' + do i=0,nres + do j=1,3 + xx(j)=c(j,i+nres) + ddc(j)=dc(j,i) + ddx(j)=dc(j,i+nres) + do k=1,3 + dcnorm_safe(k)=dc_norm(k,i) + dxnorm_safe(k)=dc_norm(k,i+nres) + enddo + enddo + do j=1,3 + dc(j,i)=ddc(j)+aincr + call chainbuild_cart +#ifdef MPI +c Broadcast the order to compute internal coordinates to the slaves. +c if (nfgtasks.gt.1) +c & call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR) +#endif +c call int_from_cart1(.false.) + if (.not.split_ene) then + call etotal(energia1(0)) + etot1=energia1(0) + else +!- split gradient + call etotal_long(energia1(0)) + etot11=energia1(0) + call etotal_short(energia1(0)) + etot12=energia1(0) +c write (iout,*) "etot11",etot11," etot12",etot12 + endif +!- end split gradient +c write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1 + dc(j,i)=ddc(j)-aincr + call chainbuild_cart +c call int_from_cart1(.false.) + if (.not.split_ene) then + call etotal(energia1(0)) + etot2=energia1(0) + ggg(j)=(etot1-etot2)/(2*aincr) + else +!- split gradient + call etotal_long(energia1(0)) + etot21=energia1(0) + ggg(j)=(etot11-etot21)/(2*aincr) + call etotal_short(energia1(0)) + etot22=energia1(0) + ggg1(j)=(etot12-etot22)/(2*aincr) +!- end split gradient +c write (iout,*) "etot21",etot21," etot22",etot22 + endif +c write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2 + dc(j,i)=ddc(j) + call chainbuild_cart + enddo + do j=1,3 + dc(j,i+nres)=ddx(j)+aincr + call chainbuild_cart +c write (iout,*) "i",i," j",j," dxnorm+ and dxnorm" +c write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3) +c write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3) +c write (iout,*) "dxnormnorm",dsqrt( +c & dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2) +c write (iout,*) "dxnormnormsafe",dsqrt( +c & dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2) +c write (iout,*) + if (.not.split_ene) then + call etotal(energia1(0)) + etot1=energia1(0) + else +!- split gradient + call etotal_long(energia1(0)) + etot11=energia1(0) + call etotal_short(energia1(0)) + etot12=energia1(0) + endif +!- end split gradient +c write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1 + dc(j,i+nres)=ddx(j)-aincr + call chainbuild_cart +c write (iout,*) "i",i," j",j," dxnorm- and dxnorm" +c write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3) +c write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3) +c write (iout,*) +c write (iout,*) "dxnormnorm",dsqrt( +c & dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2) +c write (iout,*) "dxnormnormsafe",dsqrt( +c & dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2) + if (.not.split_ene) then + call etotal(energia1(0)) + etot2=energia1(0) + ggg(j+3)=(etot1-etot2)/(2*aincr) + else +!- split gradient + call etotal_long(energia1(0)) + etot21=energia1(0) + ggg(j+3)=(etot11-etot21)/(2*aincr) + call etotal_short(energia1(0)) + etot22=energia1(0) + ggg1(j+3)=(etot12-etot22)/(2*aincr) +!- end split gradient + endif +c write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2 + dc(j,i+nres)=ddx(j) + call chainbuild_cart + enddo + write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') + & i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6) + if (split_ene) then + write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') + & i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i), + & k=1,6) + write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') + & i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6), + & ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6) + endif + enddo + return + end +c------------------------------------------------------------------------- + subroutine int_from_cart1(lprn) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' + integer ierror +#endif + include 'COMMON.IOUNITS' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + include 'COMMON.INTERACT' + include 'COMMON.LOCAL' + include 'COMMON.NAMES' + include 'COMMON.SETUP' + include 'COMMON.TIME1' + logical lprn + if (lprn) write (iout,'(/a)') 'Recalculated internal coordinates' +#ifdef TIMING + time01=MPI_Wtime() +#endif +#if defined(PARINT) && defined(MPI) + do i=iint_start,iint_end+1 +#else + do i=2,nres +#endif + dnorm1=dist(i-1,i) + dnorm2=dist(i,i+1) + do j=1,3 + c(j,maxres2)=0.5D0*(2*c(j,i)+(c(j,i-1)-c(j,i))/dnorm1 + & +(c(j,i+1)-c(j,i))/dnorm2) + enddo + be=0.0D0 + if (i.gt.2) then + if (i.le.nres) phi(i+1)=beta(i-2,i-1,i,i+1) + if ((itype(i).ne.10).and.(itype(i-1).ne.10)) then + tauangle(3,i+1)=beta(i+nres-1,i-1,i,i+nres) + endif + if (itype(i-1).ne.10) then + tauangle(1,i+1)=beta(i-1+nres,i-1,i,i+1) + omicron(1,i)=alpha(i-2,i-1,i-1+nres) + omicron(2,i)=alpha(i-1+nres,i-1,i) + endif + if (itype(i).ne.10) then + tauangle(2,i+1)=beta(i-2,i-1,i,i+nres) + endif + endif + omeg(i)=beta(nres+i,i,maxres2,i+1) + alph(i)=alpha(nres+i,i,maxres2) + theta(i+1)=alpha(i-1,i,i+1) + vbld(i)=dist(i-1,i) + vbld_inv(i)=1.0d0/vbld(i) + vbld(nres+i)=dist(nres+i,i) + if (itype(i).ne.10) then + vbld_inv(nres+i)=1.0d0/vbld(nres+i) + else + vbld_inv(nres+i)=0.0d0 + endif + enddo + +#if defined(PARINT) && defined(MPI) + if (nfgtasks1.gt.1) then +cd write(iout,*) "iint_start",iint_start," iint_count", +cd & (iint_count(i),i=0,nfgtasks-1)," iint_displ", +cd & (iint_displ(i),i=0,nfgtasks-1) +cd write (iout,*) "Gather vbld backbone" +cd call flush(iout) + time00=MPI_Wtime() + call MPI_Allgatherv(vbld(iint_start),iint_count(fg_rank1), + & MPI_DOUBLE_PRECISION,vbld(1),iint_count(0),iint_displ(0), + & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) +cd write (iout,*) "Gather vbld_inv" +cd call flush(iout) + call MPI_Allgatherv(vbld_inv(iint_start),iint_count(fg_rank1), + & MPI_DOUBLE_PRECISION,vbld_inv(1),iint_count(0),iint_displ(0), + & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) +cd write (iout,*) "Gather vbld side chain" +cd call flush(iout) + call MPI_Allgatherv(vbld(iint_start+nres),iint_count(fg_rank1), + & MPI_DOUBLE_PRECISION,vbld(nres+1),iint_count(0),iint_displ(0), + & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) +cd write (iout,*) "Gather vbld_inv side chain" +cd call flush(iout) + call MPI_Allgatherv(vbld_inv(iint_start+nres), + & iint_count(fg_rank1),MPI_DOUBLE_PRECISION,vbld_inv(nres+1), + & iint_count(0),iint_displ(0),MPI_DOUBLE_PRECISION,FG_COMM1,IERR) +cd write (iout,*) "Gather theta" +cd call flush(iout) + call MPI_Allgatherv(theta(iint_start+1),iint_count(fg_rank1), + & MPI_DOUBLE_PRECISION,theta(2),iint_count(0),iint_displ(0), + & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) +cd write (iout,*) "Gather phi" +cd call flush(iout) + call MPI_Allgatherv(phi(iint_start+1),iint_count(fg_rank1), + & MPI_DOUBLE_PRECISION,phi(2),iint_count(0),iint_displ(0), + & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) +#ifdef CRYST_SC +cd write (iout,*) "Gather alph" +cd call flush(iout) + call MPI_Allgatherv(alph(iint_start),iint_count(fg_rank1), + & MPI_DOUBLE_PRECISION,alph(1),iint_count(0),iint_displ(0), + & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) +cd write (iout,*) "Gather omeg" +cd call flush(iout) + call MPI_Allgatherv(omeg(iint_start),iint_count(fg_rank1), + & MPI_DOUBLE_PRECISION,omeg(1),iint_count(0),iint_displ(0), + & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) +#endif + time_gather=time_gather+MPI_Wtime()-time00 + endif +#endif + do i=1,nres-1 + do j=1,3 + dc_norm(j,i)=dc(j,i)*vbld_inv(i+1) + enddo + enddo + do i=2,nres-1 + do j=1,3 + dc_norm(j,i+nres)=dc(j,i+nres)*vbld_inv(i+nres) + enddo + enddo + if (lprn) then + do i=2,nres + write (iout,1212) restyp(itype(i)),i,vbld(i), + &rad2deg*theta(i),rad2deg*phi(i),vbld(nres+i), + &rad2deg*alph(i),rad2deg*omeg(i) + enddo + endif + 1212 format (a3,'(',i3,')',2(f15.10,2f10.2)) +#ifdef TIMING + time_intfcart=time_intfcart+MPI_Wtime()-time01 +#endif + return + end +c---------------------------------------------------------------------------- + subroutine check_eint +C Check the gradient of energy in internal coordinates. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.IOUNITS' + include 'COMMON.VAR' + include 'COMMON.GEO' + common /srutu/ icall + dimension x(maxvar),gana(maxvar),gg(maxvar) + integer uiparm(1) + double precision urparm(1) + double precision energia(0:n_ene),energia1(0:n_ene), + & energia2(0:n_ene) + character*6 key + external fdum + call zerograd + aincr=1.0D-7 + print '(a)','Calling CHECK_INT.' + nf=0 + nfl=0 + icg=1 + call geom_to_var(nvar,x) + call var_to_geom(nvar,x) + call chainbuild + icall=1 + print *,'ICG=',ICG + call etotal(energia(0)) + etot = energia(0) + call enerprint(energia(0)) + print *,'ICG=',ICG +#ifdef MPL + if (MyID.ne.BossID) then + call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID) + nf=x(nvar+1) + nfl=x(nvar+2) + icg=x(nvar+3) + endif +#endif + nf=1 + nfl=3 +cd write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar) + call gradient(nvar,x,nf,gana,uiparm,urparm,fdum) +cd write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar) + icall=1 + do i=1,nvar + xi=x(i) + x(i)=xi-0.5D0*aincr + call var_to_geom(nvar,x) + call chainbuild + call etotal(energia1(0)) + etot1=energia1(0) + x(i)=xi+0.5D0*aincr + call var_to_geom(nvar,x) + call chainbuild + call etotal(energia2(0)) + etot2=energia2(0) + gg(i)=(etot2-etot1)/aincr + write (iout,*) i,etot1,etot2 + x(i)=xi + enddo + write (iout,'(/2a)')' Variable Numerical Analytical', + & ' RelDiff*100% ' + do i=1,nvar + if (i.le.nphi) then + ii=i + key = ' phi' + else if (i.le.nphi+ntheta) then + ii=i-nphi + key=' theta' + else if (i.le.nphi+ntheta+nside) then + ii=i-(nphi+ntheta) + key=' alpha' + else + ii=i-(nphi+ntheta+nside) + key=' omega' + endif + write (iout,'(i3,a,i3,3(1pd16.6))') + & i,key,ii,gg(i),gana(i), + & 100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr) + enddo + return + end diff --git a/source/unres/src_MD-DFA-restraints/compare_s1.F b/source/unres/src_MD-DFA-restraints/compare_s1.F new file mode 100644 index 0000000..300e7ed --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/compare_s1.F @@ -0,0 +1,188 @@ + subroutine compare_s1(n_thr,num_thread_save,energyx,x, + & icomp,enetbss,coordss,rms_d,modif,iprint) +C This subroutine compares the new conformation, whose variables are in X +C with the previously accumulated conformations whose energies and variables +C are stored in ENETBSS and COORDSS, respectively. The meaning of other +C variables is as follows: +C +C N_THR - on input the previous # of accumulated confs, on output the current +C # of accumulated confs. +C N_REPEAT - an array that indicates how many times the structure has already +C been used to start the reversed-reversing procedure. Addition of +C a new structure replacement of a structure with a similar, but +C lower-energy structure resets the respective entry in N_REPEAT to zero +C I9 - output unit +C ENERGYX,X - the energy and variables of the new conformations. +C ICOMP - comparison result: +C 0 - the new structure is similar to one of the previous ones and does +C not have a remarkably lower energy and is therefore rejected; +C 1 - the new structure is different and is added to the set, because +C there is still room in the COORDSS and ENETBSS arrays; +C 2 - the new structure is different, but higher in energy than any +C previous one and is therefore rejected +C 3 - there is no more room in the COORDSS and ENETBSS arrays, but +C the new structure is lower in energy than at least the highest- +C energy previous structure and therefore replaces it. +C 9 - the new structure is similar to a number of previous structures, +C but has a remarkably lower energy than any of them; therefore +C replaces all these structures; +C MODIF - a logical variable that shows whether to include the new structure +C in the set of accumulated structures + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.VAR' +crc include 'COMMON.DEFORM' + include 'COMMON.IOUNITS' +#ifdef UNRES + include 'COMMON.CHAIN' +#endif + + dimension x(maxvar) + dimension x1(maxvar) + double precision przes(3),obrot(3,3) + integer list(max_thread) + logical non_conv,modif + double precision enetbss(max_threadss) + double precision coordss(maxvar,max_threadss) + + nlist=0 +#ifdef UNRES + call var_to_geom(nvar,x) + call chainbuild + do k=1,2*nres + do kk=1,3 + cref(kk,k)=c(kk,k) + enddo + enddo +#endif +c write(iout,*)'*ene=',energyx + j=0 + enex_jp=-1.0d+99 + do i=1,n_thr + do k=1,nvar + x1(k)=coordss(k,i) + enddo + if (iprint.gt.3) then + write (iout,*) 'Compare_ss, i=',i + write (iout,*) 'New structure Energy:',energyx + write (iout,'(10f8.3)') (rad2deg*x(k),k=1,nvar) + write (iout,*) 'Template structure Energy:',enetbss(i) + write (iout,'(10f8.3)') (rad2deg*x1(k),k=1,nvar) + endif + +#ifdef UNRES + call var_to_geom(nvar,x1) + call chainbuild +cd write(iout,*)'C and CREF' +cd write(iout,'(i5,3f10.5,5x,3f10.5)')(k,(c(j,k),j=1,3), +cd & (cref(j,k),j=1,3),k=1,nres) + call fitsq(roznica,c(1,1),cref(1,1),nres,przes,obrot,non_conv) + if (non_conv) then + print *,'Problems in FITSQ!!!' + print *,'X' + print '(10f8.3)',(x(k),k=1,nvar) + print *,'X1' + print '(10f8.3)',(x1(k),k=1,nvar) + print *,'C and CREF' + print '(i5,3f10.5,5x,3f10.5)',(k,(c(j,k),j=1,3), + & (cref(j,k),j=1,3),k=1,nres) + endif + roznica=dsqrt(dabs(roznica)) + iresult = 1 + if (roznica.lt.rms_d) iresult = 0 +#else + energyy=enetbss(i) + call cmprs(x,x1,roznica,energyx,energyy,iresult) +#endif + if (iprint.gt.1) write(iout,'(i5,f10.6,$)') i,roznica +c print '(i5,f8.3)',i,roznica + if(iresult.eq.0) then + nlist = nlist + 1 + list(nlist)=i + if (iprint.gt.1) write(iout,*) + if(energyx.ge.enetbss(i)) then + if (iprint.gt.1) + & write(iout,*)'s*>> structure rejected - same as nr ',i, + & ' RMS',roznica + minimize_s_flag=0 + icomp=0 + go to 1106 + endif + endif + if(energyx.lt.enetbss(i).and.enex_jp.lt.enetbss(i))then + j=i + enex_jp=enetbss(i) + endif + enddo + if (iprint.gt.1) write(iout,*) + if(nlist.gt.0) then + if (modif) then + if (iprint.gt.1) + & write(iout,'(a,i3,$)')'s*>> structure accepted1 - repl nr ', + & list(1) + else + if (iprint.gt.1) + & write(iout,'(a,i3)') + & 's*>> structure accepted1 - would repl nr ',list(1) + endif + icomp=9 + if (.not. modif) goto 1106 + j=list(1) + enetbss(j)=energyx + do i=1,nvar + coordss(i,j)=x(i) + enddo + do j=2,nlist + if (iprint.gt.1) write(iout,'(i3,$)')list(j) + do kk=list(j)+1,nlist + enetbss(kk-1)=enetbss(kk) + do i=1,nvar + coordss(i,kk-1)=coordss(i,kk) + enddo + enddo + enddo + if (iprint.gt.1) write(iout,*) + go to 1106 + endif + if(n_thr.lt.num_thread_save) then + icomp=1 + if (modif) then + if (iprint.gt.1) + & write(iout,*)'s*>> structure accepted - add with nr ',n_thr+1 + else + if (iprint.gt.1) + & write(iout,*)'s*>> structure accepted - would add with nr ', + & n_thr+1 + goto 1106 + endif + n_thr=n_thr+1 + enetbss(n_thr)=energyx + do i=1,nvar + coordss(i,n_thr)=x(i) + enddo + else + if(j.eq.0) then + if (iprint.gt.1) + & write(iout,*)'s*>> structure rejected - too high energy' + icomp=2 + go to 1106 + end if + icomp=3 + if (modif) then + if (iprint.gt.1) + & write(iout,*)'s*>> structure accepted - repl nr ',j + else + if (iprint.gt.1) + & write(iout,*)'s*>> structure accepted - would repl nr ',j + goto 1106 + endif + enetbss(j)=energyx + do i=1,nvar + coordss(i,j)=x(i) + enddo + end if + +1106 continue + return + end diff --git a/source/unres/src_MD-DFA-restraints/compinfo.c b/source/unres/src_MD-DFA-restraints/compinfo.c new file mode 100644 index 0000000..e28f686 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/compinfo.c @@ -0,0 +1,82 @@ +#include +#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_MD-DFA-restraints/contact.f b/source/unres/src_MD-DFA-restraints/contact.f new file mode 100644 index 0000000..a244d86 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/convert.f b/source/unres/src_MD-DFA-restraints/convert.f new file mode 100644 index 0000000..dc0cccd --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/cored.f b/source/unres/src_MD-DFA-restraints/cored.f new file mode 100644 index 0000000..1cf25e5 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/dfa.F b/source/unres/src_MD-DFA-restraints/dfa.F new file mode 100644 index 0000000..576910c --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/dihed_cons.F b/source/unres/src_MD-DFA-restraints/dihed_cons.F new file mode 100644 index 0000000..e45405f --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/dihed_cons.F @@ -0,0 +1,185 @@ + subroutine secstrp2dihc + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.BOUNDS' + include 'COMMON.CHAIN' + include 'COMMON.TORCNSTR' + include 'COMMON.IOUNITS' + character*1 secstruc(maxres) + COMMON/SECONDARYS/secstruc + character*80 line + logical errflag + external ilen + +cdr call getenv_loc('SECPREDFIL',secpred) + lenpre=ilen(prefix) + secpred=prefix(:lenpre)//'.spred' + +#if defined(WINIFL) || defined(WINPGI) + open(isecpred,file=secpred,status='old',readonly,shared) +#elif (defined CRAY) || (defined AIX) + open(isecpred,file=secpred,status='old',action='read') +#elif (defined G77) + open(isecpred,file=secpred,status='old') +#else + open(isecpred,file=secpred,status='old',action='read') +#endif +C read secondary structure prediction from JPRED here! +! read(isecpred,'(A80)',err=100,end=100) line +! read(line,'(f10.3)',err=110) ftors + read(isecpred,'(f10.3)',err=110) ftors + + write (iout,*) 'FTORS factor =',ftors +! initialize secstruc to any + do i=1,nres + secstruc(i) ='-' + enddo + ndih_constr=0 + ndih_nconstr=0 + + call read_secstr_pred(isecpred,iout,errflag) + if (errflag) then + write(iout,*)'There is a problem with the list of secondary-', + & 'structure prediction' + goto 100 + endif +C 8/13/98 Set limits to generating the dihedral angles + do i=1,nres + phibound(1,i)=-pi + phibound(2,i)=pi + enddo + + ii=0 + do i=1,nres + if ( secstruc(i) .eq. 'H') then +C Helix restraints for this residue + ii=ii+1 + idih_constr(ii)=i + phi0(ii) = 45.0D0*deg2rad + drange(ii)= 5.0D0*deg2rad + phibound(1,i) = phi0(ii)-drange(ii) + phibound(2,i) = phi0(ii)+drange(ii) + else if (secstruc(i) .eq. 'E') then +C strand restraints for this residue + ii=ii+1 + idih_constr(ii)=i + phi0(ii) = 180.0D0*deg2rad + drange(ii)= 5.0D0*deg2rad + phibound(1,i) = phi0(ii)-drange(ii) + phibound(2,i) = phi0(ii)+drange(ii) + else +C no restraints for this residue + ndih_nconstr=ndih_nconstr+1 + idih_nconstr(ndih_nconstr)=i + endif + enddo + ndih_constr=ii + return +100 continue + write(iout,'(A30,A80)')'Error reading file SECPRED',secpred + return + 110 continue + write(iout,'(A20)')'Error reading FTORS' + return + end + + subroutine read_secstr_pred(jin,jout,errors) + + implicit real*8 (a-h,o-z) + INCLUDE 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + character*1 secstruc(maxres) + COMMON/SECONDARYS/secstruc + EXTERNAL ILEN + character*80 line,line1,ucase + logical errflag,errors,blankline + + errors=.false. + read (jin,'(a)') line + write (jout,'(2a)') '> ',line(1:78) + line1=ucase(line) +C Remember that we number full residues starting from 2, then, iseq=1 and iseq=nres +C correspond to the end-groups. ADD to the secondary structure prediction "-" for the +C end-groups in the input file "*.spred" + + iseq=1 + do while (index(line1,'$END').eq.0) +* Override commented lines. + ipos=1 + blankline=.false. + do while (.not.blankline) + line1=' ' + call mykey(line,line1,ipos,blankline,errflag) + if (errflag) write (jout,'(2a)') + & 'Error when reading sequence in line: ',line + errors=errors .or. errflag + if (.not. blankline .and. .not. errflag) then + ipos1=2 + iend=ilen(line1) + if (iseq.le.maxres) then + if (line1(1:1).eq.'-' ) then + secstruc(iseq)=line1(1:1) + else if ( ( ucase(line1(1:1)).eq.'E' ) .or. + & ( ucase(line1(1:1)).eq.'H' ) ) then + secstruc(iseq)=ucase(line1(1:1)) + else + errors=.true. + write (jout,1010) line1(1:1), iseq + goto 80 + endif + else + errors=.true. + write (jout,1000) iseq,maxres + goto 80 + endif + do while (ipos1.le.iend) + + iseq=iseq+1 + il=1 + ipos1=ipos1+1 + if (iseq.le.maxres) then + if (line1(ipos1-1:ipos1-1).eq.'-' ) then + secstruc(iseq)=line1(ipos1-1:ipos1-1) + else if((ucase(line1(ipos1-1:ipos1-1)).eq.'E').or. + & (ucase(line1(ipos1-1:ipos1-1)).eq.'H') ) then + secstruc(iseq)=ucase(line1(ipos1-1:ipos1-1)) + else + errors=.true. + write (jout,1010) line1(ipos1-1:ipos1-1), iseq + goto 80 + endif + else + errors=.true. + write (jout,1000) iseq,maxres + goto 80 + endif + enddo + iseq=iseq+1 + endif + enddo + read (jin,'(a)') line + write (jout,'(2a)') '> ',line(1:78) + line1=ucase(line) + enddo + +cd write (jout,'(10a8)') (sequence(i),i=1,iseq-1) + +cd check whether the found length of the chain is correct. + length_of_chain=iseq-1 + if (length_of_chain .ne. nres) then +! errors=.true. + write (jout,'(a,i4,a,i4,a)') + & 'Error: the number of labels specified in $SEC_STRUC_PRED (' + & ,length_of_chain,') does not match with the number of residues (' + & ,nres,').' + endif + 80 continue + + 1000 format('Error - the number of residues (',i4, + & ') has exceeded maximum (',i4,').') + 1010 format ('Error - unrecognized secondary structure label',a4, + & ' in position',i4) + return + end diff --git a/source/unres/src_MD-DFA-restraints/djacob.f b/source/unres/src_MD-DFA-restraints/djacob.f new file mode 100644 index 0000000..e3f46bc --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/econstr_local.F b/source/unres/src_MD-DFA-restraints/econstr_local.F new file mode 100644 index 0000000..f11acfb --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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' +#ifndef LANG0 + include 'COMMON.LANGEVIN' +#else + include 'COMMON.LANGEVIN.lang0' +#endif + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.TIME1' + Uconst_back=0.0d0 + do i=1,nres + dutheta(i)=0.0d0 + dugamma(i)=0.0d0 + do j=1,3 + duscdiff(j,i)=0.0d0 + duscdiffx(j,i)=0.0d0 + enddo + enddo + do i=1,nfrag_back + ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset) +c +c Deviations from theta angles +c + utheta_i=0.0d0 + do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) + dtheta_i=theta(j)-thetaref(j) + utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i + dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1) + enddo + utheta(i)=utheta_i/(ii-1) +c +c Deviations from gamma angles +c + ugamma_i=0.0d0 + do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset) + dgamma_i=pinorm(phi(j)-phiref(j)) +c write (iout,*) j,phi(j),phi(j)-phiref(j) + ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i + dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2) +c write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3) + enddo + ugamma(i)=ugamma_i/(ii-2) +c +c Deviations from local SC geometry +c + uscdiff(i)=0.0d0 + do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 + dxx=xxtab(j)-xxref(j) + dyy=yytab(j)-yyref(j) + dzz=zztab(j)-zzref(j) + uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz + do k=1,3 + duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* + & (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ + & (ii-1) + duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* + & (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ + & (ii-1) + duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* + & (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) + & /(ii-1) + enddo +c write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j), +c & xxref(j),yyref(j),zzref(j) + enddo + uscdiff(i)=0.5d0*uscdiff(i)/(ii-1) +c write (iout,*) i," uscdiff",uscdiff(i) +c +c Put together deviations from local geometry +c + Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ + & wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i) +c write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i), +c & " uconst_back",uconst_back + utheta(i)=dsqrt(utheta(i)) + ugamma(i)=dsqrt(ugamma(i)) + uscdiff(i)=dsqrt(uscdiff(i)) + enddo + return + end diff --git a/source/unres/src_MD-DFA-restraints/eigen.f b/source/unres/src_MD-DFA-restraints/eigen.f new file mode 100644 index 0000000..e4088ee --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/eigen.f @@ -0,0 +1,2351 @@ +C 10 AUG 94 - MWS - INCREASE NUMBER OF DAF RECORDS +C 31 MAR 94 - MWS - ADD A VARIABLE TO END OF MACHSW COMMON +C 26 JUN 93 - MWS - ETRED3: ADD RETURN FOR SPECIAL CASE N=1 +C 4 JAN 92 - TLW - MAKE WRITES PARALLEL;ADD COMMON PAR +C 30 AUG 91 - MWS - JACDIA: LIMIT ITERATIONS, USE EPSLON IN TEST. +C 14 JUL 91 - MWS - JACOBI DIAGONALIZATION ALLOWS FOR LDVEC.NE.N +C 29 JAN 91 - TLW - GLDIAG: CHANGED COMMON DIAGSW TO MACHSW +C 29 OCT 90 - STE - FIX JACDIA UNDEFINED VARIABLE BUG +C 14 SEP 90 - MK - NEW JACOBI DIAGONALIZATION (KDIAG=3) +C 27 MAR 88 - MWS - ALLOW FOR VECTOR ROUTINE IN GLDIAG +C 11 AUG 87 - MWS - SANITIZE CONSTANTS IN EQLRAT +C 15 FEB 87 - STE - FIX EINVIT SUB-MATRIX LOOP LIMIT +C SCRATCH ARRAYS ARE N*8 REAL AND N INTEGER +C 8 DEC 86 - STE - USE PERF INDEX FROM ESTPI1 TO JUDGE EINVIT FAILURE +C 30 NOV 86 - STE - DELETE LIGENB, MAKE EVVRSP DEFAULT +C (GIVEIS FAILS ON CRAY FOR BENCHMC AND BENCHCI) +C 7 JUL 86 - JAB - SANITIZE FLOATING POINT CONSTANTS +C 11 OCT 85 - STE - LIGENB,TQL2: USE DROT,DSWAP; TINVTB: SCALE VECTOR +C BEFORE NORMALIZING; GENERIC FUNCTIONS +C 24 FEB 84 - STE - INITIALIZE INDEX ARRAY FOR LIGENB IN GLDIAG +C 1 DEC 83 - STE - CHANGE MACHEP FROM 2**-54 TO 2**-50 +C 28 SEP 82 - MWS - CONVERT TO IBM +C +C*MODULE EIGEN *DECK EINVIT + SUBROUTINE EINVIT(NM,N,D,E,E2,M,W,IND,Z,IERR,RV1,RV2,RV3,RV4,RV6) +C* +C* AUTHORS- +C* THIS IS A MODIFICATION OF TINVIT FROM EISPACK EDITION 3 +C* DATED AUGUST 1983. +C* TINVIT IS A TRANSLATION OF THE INVERSE ITERATION TECHNIQUE +C* IN THE ALGOL PROCEDURE TRISTURM BY PETERS AND WILKINSON. +C* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). +C* THIS VERSION IS BY S. T. ELBERT (AMES LABORATORY-USDOE) +C* +C* PURPOSE - +C* THIS ROUTINE FINDS THOSE EIGENVECTORS OF A TRIDIAGONAL +C* SYMMETRIC MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES. +C* +C* METHOD - +C* INVERSE ITERATION. +C* +C* ON ENTRY - +C* NM - INTEGER +C* MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL +C* ARRAY PARAMETERS AS DECLARED IN THE CALLING ROUTINE +C* DIMENSION STATEMENT. +C* N - INTEGER +C* D - W.P. REAL (N) +C* CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. +C* E - W.P. REAL (N) +C* CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX +C* IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. +C* E2 - W.P. REAL (N) +C* CONTAINS THE SQUARES OF CORRESPONDING ELEMENTS OF E, +C* WITH ZEROS CORRESPONDING TO NEGLIGIBLE ELEMENTS OF E. +C* E(I) IS CONSIDERED NEGLIGIBLE IF IT IS NOT LARGER THAN +C* THE PRODUCT OF THE RELATIVE MACHINE PRECISION AND THE +C* SUM OF THE MAGNITUDES OF D(I) AND D(I-1). E2(1) MUST +C* CONTAIN 0.0 IF THE EIGENVALUES ARE IN ASCENDING ORDER, +C* OR 2.0 IF THE EIGENVALUES ARE IN DESCENDING ORDER. +C* IF TQLRAT, BISECT, TRIDIB, OR IMTQLV +C* HAS BEEN USED TO FIND THE EIGENVALUES, THEIR +C* OUTPUT E2 ARRAY IS EXACTLY WHAT IS EXPECTED HERE. +C* M - INTEGER +C* THE NUMBER OF SPECIFIED EIGENVECTORS. +C* W - W.P. REAL (M) +C* CONTAINS THE M EIGENVALUES IN ASCENDING +C* OR DESCENDING ORDER. +C* IND - INTEGER (M) +C* CONTAINS IN FIRST M POSITIONS THE SUBMATRIX INDICES +C* ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W -- +C* 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX +C* FROM THE TOP, 2 FOR THOSE BELONGING TO THE SECOND +C* SUBMATRIX, ETC. +C* IERR - INTEGER (LOGICAL UNIT NUMBER) +C* LOGICAL UNIT FOR ERROR MESSAGES +C* +C* ON EXIT - +C* ALL INPUT ARRAYS ARE UNALTERED. +C* Z - W.P. REAL (NM,M) +C* CONTAINS THE ASSOCIATED SET OF ORTHONORMAL +C* EIGENVECTORS. ANY VECTOR WHICH WHICH FAILS TO CONVERGE +C* IS LEFT AS IS (BUT NORMALIZED) WHEN ITERATING STOPPED. +C* IERR - INTEGER +C* SET TO +C* ZERO FOR NORMAL RETURN, +C* -R IF THE EIGENVECTOR CORRESPONDING TO THE R-TH +C* EIGENVALUE FAILS TO CONVERGE IN 5 ITERATIONS. +C* (ONLY LAST FAILURE TO CONVERGE IS REPORTED) +C* +C* RV1, RV2, RV3, RV4, AND RV6 ARE TEMPORARY STORAGE ARRAYS. +C* +C* RV1 - W.P. REAL (N) +C* DIAGONAL ELEMENTS OF U FROM LU DECOMPOSITION +C* RV2 - W.P. REAL (N) +C* SUPER(1)-DIAGONAL ELEMENTS OF U FROM LU DECOMPOSITION +C* RV3 - W.P. REAL (N) +C* SUPER(2)-DIAGONAL ELEMENTS OF U FROM LU DECOMPOSITION +C* RV4 - W.P. REAL (N) +C* ELEMENTS DEFINING L IN LU DECOMPOSITION +C* RV6 - W.P. REAL (N) +C* APPROXIMATE EIGENVECTOR +C* +C* DIFFERENCES FROM EISPACK 3 - +C* EPS3 IS SCALED BY EPSCAL (ENHANCES CONVERGENCE, BUT +C* LOWERS ACCURACY)! +C* ONE MORE ITERATION (MINIMUM 2) IS PERFORMED AFTER CONVERGENCE +C* (ENHANCES ACCURACY)! +C* REPLACE LOOP WITH PYTHAG WITH SINGLE CALL TO DNRM2! +C* IF NOT CONVERGED, USE PERFORMANCE INDEX TO DECIDE ON ERROR +C* VALUE SETTING, BUT DO NOT STOP! +C* L.U. FOR ERROR MESSAGES PASSED THROUGH IERR +C* USE PARAMETER STATEMENTS AND GENERIC INTRINSIC FUNCTIONS +C* USE LEVEL 1 BLAS +C* USE IF-THEN-ELSE TO CLARIFY LOGIC +C* LOOP OVER SUBSPACES MADE INTO DO LOOP. +C* LOOP OVER INVERSE ITERATIONS MADE INTO DO LOOP +C* ZERO ONLY REQUIRED PORTIONS OF OUTPUT VECTOR +C* +C* NOTE - +C* QUESTIONS AND COMMENTS CONCERNING EISPACK SHOULD BE DIRECTED TO +C* B. S. GARBOW, APPLIED MATH. DIVISION, ARGONNE NATIONAL LAB. +C* +C + LOGICAL CONVGD,GOPARR,DSKWRK,MASWRK +C + INTEGER GROUP,I,IERR,ITS,J,JJ,M,N,NM,P,Q,R,S,SUBMAT,TAG + INTEGER IND(M) +C + DOUBLE PRECISION D(N),E(N),E2(N),W(M),Z(NM,M) + DOUBLE PRECISION RV1(N),RV2(N),RV3(N),RV4(N),RV6(N) + DOUBLE PRECISION ANORM,EPS2,EPS3,EPS4,NORM,ORDER,RHO,U,UK,V + DOUBLE PRECISION X0,X1,XU + DOUBLE PRECISION EPSCAL,GRPTOL,HUNDRD,ONE,TEN,ZERO + DOUBLE PRECISION EPSLON, ESTPI1, DASUM, DDOT, DNRM2 +C + COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK +C + PARAMETER (ZERO = 0.0D+00, ONE = 1.0D+00, GRPTOL = 0.001D+00) + PARAMETER (EPSCAL = 0.5D+00, HUNDRD = 100.0D+00, TEN = 10.0D+00) +C + 001 FORMAT(' EIGENVECTOR ROUTINE EINVIT DID NOT CONVERGE FOR VECTOR' + * ,I5,'. NORM =',1P,E10.2,' PERFORMANCE INDEX =',E10.2/ + * ' (AN ERROR HALT WILL OCCUR IF THE PI IS GREATER THAN 100)') +C +C----------------------------------------------------------------------- +C + LUEMSG = IERR + IERR = 0 + X0 = ZERO + UK = ZERO + NORM = ZERO + EPS2 = ZERO + EPS3 = ZERO + EPS4 = ZERO + GROUP = 0 + TAG = 0 + ORDER = ONE - E2(1) + Q = 0 + DO 930 SUBMAT = 1, N + P = Q + 1 +C +C .......... ESTABLISH AND PROCESS NEXT SUBMATRIX .......... +C + DO 120 Q = P, N-1 + IF (E2(Q+1) .EQ. ZERO) GO TO 140 + 120 CONTINUE + Q = N +C +C .......... FIND VECTORS BY INVERSE ITERATION .......... +C + 140 CONTINUE + TAG = TAG + 1 + ANORM = ZERO + S = 0 +C + DO 920 R = 1, M + IF (IND(R) .NE. TAG) GO TO 920 + ITS = 1 + X1 = W(R) + IF (S .NE. 0) GO TO 510 +C +C .......... CHECK FOR ISOLATED ROOT .......... +C + XU = ONE + IF (P .EQ. Q) THEN + RV6(P) = ONE + CONVGD = .TRUE. + GO TO 860 +C + END IF + NORM = ABS(D(P)) + DO 500 I = P+1, Q + NORM = MAX( NORM, ABS(D(I)) + ABS(E(I)) ) + 500 CONTINUE +C +C .......... EPS2 IS THE CRITERION FOR GROUPING, +C EPS3 REPLACES ZERO PIVOTS AND EQUAL +C ROOTS ARE MODIFIED BY EPS3, +C EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW ......... +C + EPS2 = GRPTOL * NORM + EPS3 = EPSCAL * EPSLON(NORM) + UK = Q - P + 1 + EPS4 = UK * EPS3 + UK = EPS4 / SQRT(UK) + S = P + GROUP = 0 + GO TO 520 +C +C .......... LOOK FOR CLOSE OR COINCIDENT ROOTS .......... +C + 510 IF (ABS(X1-X0) .GE. EPS2) THEN +C +C ROOTS ARE SEPERATE +C + GROUP = 0 + ELSE +C +C ROOTS ARE CLOSE +C + GROUP = GROUP + 1 + IF (ORDER * (X1 - X0) .LE. EPS3) X1 = X0 + ORDER * EPS3 + END IF +C +C .......... ELIMINATION WITH INTERCHANGES AND +C INITIALIZATION OF VECTOR .......... +C + 520 CONTINUE +C + U = D(P) - X1 + V = E(P+1) + RV6(P) = UK + DO 550 I = P+1, Q + RV6(I) = UK + IF (ABS(E(I)) .GT. ABS(U)) THEN +C +C EXCHANGE ROWS BEFORE ELIMINATION +C +C *** WARNING -- A DIVIDE CHECK MAY OCCUR HERE IF +C E2 ARRAY HAS NOT BEEN SPECIFIED CORRECTLY ....... +C + XU = U / E(I) + RV4(I) = XU + RV1(I-1) = E(I) + RV2(I-1) = D(I) - X1 + RV3(I-1) = E(I+1) + U = V - XU * RV2(I-1) + V = -XU * RV3(I-1) +C + ELSE +C +C STRAIGHT ELIMINATION +C + XU = E(I) / U + RV4(I) = XU + RV1(I-1) = U + RV2(I-1) = V + RV3(I-1) = ZERO + U = D(I) - X1 - XU * V + V = E(I+1) + END IF + 550 CONTINUE +C + IF (ABS(U) .LE. EPS3) U = EPS3 + RV1(Q) = U + RV2(Q) = ZERO + RV3(Q) = ZERO +C +C DO INVERSE ITERATIONS +C + CONVGD = .FALSE. + DO 800 ITS = 1, 5 + IF (ITS .EQ. 1) GO TO 600 +C +C .......... FORWARD SUBSTITUTION .......... +C + IF (NORM .EQ. ZERO) THEN + RV6(S) = EPS4 + S = S + 1 + IF (S .GT. Q) S = P + ELSE + XU = EPS4 / NORM + CALL DSCAL (Q-P+1, XU, RV6(P), 1) + END IF +C +C ... ELIMINATION OPERATIONS ON NEXT VECTOR +C + DO 590 I = P+1, Q + U = RV6(I) +C +C IF RV1(I-1) .EQ. E(I), A ROW INTERCHANGE +C WAS PERFORMED EARLIER IN THE +C TRIANGULARIZATION PROCESS .......... +C + IF (RV1(I-1) .EQ. E(I)) THEN + U = RV6(I-1) + RV6(I-1) = RV6(I) + ELSE + U = RV6(I) + END IF + RV6(I) = U - RV4(I) * RV6(I-1) + 590 CONTINUE + 600 CONTINUE +C +C .......... BACK SUBSTITUTION +C + RV6(Q) = RV6(Q) / RV1(Q) + V = U + U = RV6(Q) + NORM = ABS(U) + DO 620 I = Q-1, P, -1 + RV6(I) = (RV6(I) - U * RV2(I) - V * RV3(I)) / RV1(I) + V = U + U = RV6(I) + NORM = NORM + ABS(U) + 620 CONTINUE + IF (GROUP .EQ. 0) GO TO 700 +C +C ....... ORTHOGONALIZE WITH RESPECT TO PREVIOUS +C MEMBERS OF GROUP .......... +C + J = R + DO 680 JJ = 1, GROUP + 630 J = J - 1 + IF (IND(J) .NE. TAG) GO TO 630 + CALL DAXPY(Q-P+1, -DDOT(Q-P+1,RV6(P),1,Z(P,J),1), + * Z(P,J),1,RV6(P),1) + 680 CONTINUE + NORM = DASUM(Q-P+1, RV6(P), 1) + 700 CONTINUE +C + IF (CONVGD) GO TO 840 + IF (NORM .GE. ONE) CONVGD = .TRUE. + 800 CONTINUE +C +C .......... NORMALIZE SO THAT SUM OF SQUARES IS +C 1 AND EXPAND TO FULL ORDER .......... +C + 840 CONTINUE +C + XU = ONE / DNRM2(Q-P+1,RV6(P),1) +C + 860 CONTINUE + DO 870 I = 1, P-1 + Z(I,R) = ZERO + 870 CONTINUE + DO 890 I = P,Q + Z(I,R) = RV6(I) * XU + 890 CONTINUE + DO 900 I = Q+1, N + Z(I,R) = ZERO + 900 CONTINUE +C + IF (.NOT.CONVGD) THEN + RHO = ESTPI1(Q-P+1,X1,D(P),E(P),Z(P,R),ANORM) + IF (RHO .GE. TEN .AND. LUEMSG .GT. 0 .AND. MASWRK) + * WRITE(LUEMSG,001) R,NORM,RHO +C +C *** SET ERROR -- NON-CONVERGED EIGENVECTOR .......... +C + IF (RHO .GT. HUNDRD) IERR = -R + END IF +C + X0 = X1 + 920 CONTINUE +C + IF (Q .EQ. N) GO TO 940 + 930 CONTINUE + 940 CONTINUE + RETURN + END +C*MODULE EIGEN *DECK ELAUM + SUBROUTINE ELAU(HINV,L,D,A,E) +C + DOUBLE PRECISION A(*) + DOUBLE PRECISION D(L) + DOUBLE PRECISION E(L) + DOUBLE PRECISION F + DOUBLE PRECISION G + DOUBLE PRECISION HALF + DOUBLE PRECISION HH + DOUBLE PRECISION HINV + DOUBLE PRECISION ZERO +C + PARAMETER (ZERO = 0.0D+00, HALF = 0.5D+00) +C + JL = L + E(1) = A(1) * D(1) + JK = 2 + DO 210 J = 2, JL + F = D(J) + G = ZERO + JM1 = J - 1 +C + DO 200 K = 1, JM1 + G = G + A(JK) * D(K) + E(K) = E(K) + A(JK) * F + JK = JK + 1 + 200 CONTINUE +C + E(J) = G + A(JK) * F + JK = JK + 1 + 210 CONTINUE +C +C .......... FORM P .......... +C + F = ZERO + DO 245 J = 1, L + E(J) = E(J) * HINV + F = F + E(J) * D(J) + 245 CONTINUE +C +C .......... FORM Q .......... +C + HH = F * HALF * HINV + DO 250 J = 1, L + 250 E(J) = E(J) - HH * D(J) +C + RETURN + END +C*MODULE EIGEN *DECK EPSLON + DOUBLE PRECISION FUNCTION EPSLON (X) +C* +C* AUTHORS - +C* THIS ROUTINE WAS TAKEN FROM EISPACK EDITION 3 DATED 4/6/83 +C* THIS VERSION IS BY S. T. ELBERT, AMES LABORATORY-USDOE NOV 1986 +C* +C* PURPOSE - +C* ESTIMATE UNIT ROUNDOFF IN QUANTITIES OF SIZE X. +C* +C* ON ENTRY - +C* X - WORKING PRECISION REAL +C* VALUES TO FIND EPSLON FOR +C* +C* ON EXIT - +C* EPSLON - WORKING PRECISION REAL +C* SMALLEST POSITIVE VALUE SUCH THAT X+EPSLON .NE. ZERO +C* +C* QUALIFICATIONS - +C* THIS ROUTINE SHOULD PERFORM PROPERLY ON ALL SYSTEMS +C* SATISFYING THE FOLLOWING TWO ASSUMPTIONS, +C* 1. THE BASE USED IN REPRESENTING FLOATING POINT +C* NUMBERS IS NOT A POWER OF THREE. +C* 2. THE QUANTITY A IN STATEMENT 10 IS REPRESENTED TO +C* THE ACCURACY USED IN FLOATING POINT VARIABLES +C* THAT ARE STORED IN MEMORY. +C* THE STATEMENT NUMBER 10 AND THE GO TO 10 ARE INTENDED TO +C* FORCE OPTIMIZING COMPILERS TO GENERATE CODE SATISFYING +C* ASSUMPTION 2. +C* UNDER THESE ASSUMPTIONS, IT SHOULD BE TRUE THAT, +C* A IS NOT EXACTLY EQUAL TO FOUR-THIRDS, +C* B HAS A ZERO FOR ITS LAST BIT OR DIGIT, +C* C IS NOT EXACTLY EQUAL TO ONE, +C* EPS MEASURES THE SEPARATION OF 1.0 FROM +C* THE NEXT LARGER FLOATING POINT NUMBER. +C* THE DEVELOPERS OF EISPACK WOULD APPRECIATE BEING INFORMED +C* ABOUT ANY SYSTEMS WHERE THESE ASSUMPTIONS DO NOT HOLD. +C* +C* DIFFERENCES FROM EISPACK 3 - +C* USE IS MADE OF PARAMETER STATEMENTS AND INTRINSIC FUNCTIONS +C* --NO EXECUTEABLE CODE CHANGES-- +C* +C* NOTE - +C* QUESTIONS AND COMMENTS CONCERNING EISPACK SHOULD BE DIRECTED TO +C* B. S. GARBOW, APPLIED MATH. DIVISION, ARGONNE NATIONAL LAB. +C + DOUBLE PRECISION A,B,C,EPS,X + DOUBLE PRECISION ZERO, ONE, THREE, FOUR +C + PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, THREE=3.0D+00, FOUR=4.0D+00) +C +C----------------------------------------------------------------------- +C + A = FOUR/THREE + 10 B = A - ONE + C = B + B + B + EPS = ABS(C - ONE) + IF (EPS .EQ. ZERO) GO TO 10 + EPSLON = EPS*ABS(X) + RETURN + END +C*MODULE EIGEN *DECK EQLRAT + SUBROUTINE EQLRAT(N,DIAG,E,E2IN,D,IND,IERR,E2) +C* +C* AUTHORS - +C* THIS IS A MODIFICATION OF ROUTINE EQLRAT FROM EISPACK EDITION 3 +C* DATED AUGUST 1983. +C* TQLRAT IS A TRANSLATION OF THE ALGOL PROCEDURE TQLRAT, +C* ALGORITHM 464, COMM. ACM 16, 689(1973) BY REINSCH. +C* THIS VERSION IS BY S. T. ELBERT (AMES LABORATORY-USDOE) +C* +C* PURPOSE - +C* THIS ROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC +C* TRIDIAGONAL MATRIX +C* +C* METHOD - +C* RATIONAL QL +C* +C* ON ENTRY - +C* N - INTEGER +C* THE ORDER OF THE MATRIX. +C* D - W.P. REAL (N) +C* CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. +C* E2 - W.P. REAL (N) +C* CONTAINS THE SQUARES OF THE SUBDIAGONAL ELEMENTS OF +C* THE INPUT MATRIX IN ITS LAST N-1 POSITIONS. +C* E2(1) IS ARBITRARY. +C* +C* ON EXIT - +C* D - W.P. REAL (N) +C* CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN +C* ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND +C* ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE +C* THE SMALLEST EIGENVALUES. +C* E2 - W.P. REAL (N) +C* DESTROYED. +C* IERR - INTEGER +C* SET TO +C* ZERO FOR NORMAL RETURN, +C* J IF THE J-TH EIGENVALUE HAS NOT BEEN +C* DETERMINED AFTER 30 ITERATIONS. +C* +C* DIFFERENCES FROM EISPACK 3 - +C* G=G+B INSTEAD OF IF(G.EQ.0) G=B ; B=B/4 +C* F77 BACKWARD LOOPS INSTEAD OF F66 CONSTRUCT +C* GENERIC INTRINSIC FUNCTIONS +C* ARRARY IND ADDED FOR USE BY EINVIT +C* +C* NOTE - +C* QUESTIONS AND COMMENTS CONCERNING EISPACK SHOULD BE DIRECTED TO +C* B. S. GARBOW, APPLIED MATH. DIVISION, ARGONNE NATIONAL LAB. +C + INTEGER I,J,L,M,N,II,L1,IERR + INTEGER IND(N) +C + DOUBLE PRECISION D(N),E(N),E2(N),DIAG(N),E2IN(N) + DOUBLE PRECISION B,C,F,G,H,P,R,S,T,EPSLON + DOUBLE PRECISION SCALE,ZERO,ONE +C + PARAMETER (ZERO = 0.0D+00, SCALE= 1.0D+00/64.0D+00, ONE = 1.0D+00) +C +C----------------------------------------------------------------------- + IERR = 0 + D(1)=DIAG(1) + IND(1) = 1 + K = 0 + ITAG = 0 + IF (N .EQ. 1) GO TO 1001 +C + DO 100 I = 2, N + D(I)=DIAG(I) + 100 E2(I-1) = E2IN(I) +C + F = ZERO + T = ZERO + B = EPSLON(ONE) + C = B *B + B = B * SCALE + E2(N) = ZERO +C + DO 290 L = 1, N + H = ABS(D(L)) + ABS(E(L)) + IF (T .GE. H) GO TO 105 + T = H + B = EPSLON(T) + C = B * B + B = B * SCALE + 105 CONTINUE +C .......... LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT .......... + M = L - 1 + 110 M = M + 1 + IF (E2(M) .GT. C) GO TO 110 +C .......... E2(N) IS ALWAYS ZERO, SO THERE IS AN EXIT +C FROM THE LOOP .......... +C + IF (M .LE. K) GO TO 125 + IF (M .NE. N) E2IN(M+1) = ZERO + K = M + ITAG = ITAG + 1 + 125 CONTINUE + IF (M .EQ. L) GO TO 210 +C +C ITERATE +C + DO 205 J = 1, 30 +C .......... FORM SHIFT .......... + L1 = L + 1 + S = SQRT(E2(L)) + G = D(L) + P = (D(L1) - G) / (2.0D+00 * S) + R = SQRT(P*P+1.0D+00) + D(L) = S / (P + SIGN(R,P)) + H = G - D(L) +C + DO 140 I = L1, N + 140 D(I) = D(I) - H +C + F = F + H +C .......... RATIONAL QL TRANSFORMATION .......... + G = D(M) + B + H = G + S = ZERO + DO 200 I = M-1,L,-1 + P = G * H + R = P + E2(I) + E2(I+1) = S * R + S = E2(I) / R + D(I+1) = H + S * (H + D(I)) + G = D(I) - E2(I) / G + B + H = G * P / R + 200 CONTINUE +C + E2(L) = S * G + D(L) = H +C .......... GUARD AGAINST UNDERFLOW IN CONVERGENCE TEST + IF (H .EQ. ZERO) GO TO 210 + IF (ABS(E2(L)) .LE. ABS(C/H)) GO TO 210 + E2(L) = H * E2(L) + IF (E2(L) .EQ. ZERO) GO TO 210 + 205 CONTINUE +C .......... SET ERROR -- NO CONVERGENCE TO AN +C EIGENVALUE AFTER 30 ITERATIONS .......... + IERR = L + GO TO 1001 +C +C CONVERGED +C + 210 P = D(L) + F +C .......... ORDER EIGENVALUES .......... + I = 1 + IF (L .EQ. 1) GO TO 250 + IF (P .LT. D(1)) GO TO 230 + I = L +C .......... LOOP TO FIND ORDERED POSITION + 220 I = I - 1 + IF (P .LT. D(I)) GO TO 220 +C + I = I + 1 + IF (I .EQ. L) GO TO 250 + 230 CONTINUE + DO 240 II = L, I+1, -1 + D(II) = D(II-1) + IND(II) = IND(II-1) + 240 CONTINUE +C + 250 CONTINUE + D(I) = P + IND(I) = ITAG + 290 CONTINUE +C + 1001 RETURN + END +C*MODULE EIGEN *DECK ESTPI1 + DOUBLE PRECISION FUNCTION ESTPI1 (N,EVAL,D,E,X,ANORM) +C* +C* AUTHOR - +C* STEPHEN T. ELBERT (AMES LABORATORY-USDOE) DATE: 5 DEC 1986 +C* +C* PURPOSE - +C* EVALUATE SYMMETRIC TRIDIAGONAL MATRIX PERFORMANCE INDEX +C* * * * * * +C* FOR 1 EIGENVECTOR +C* * +C* +C* METHOD - +C* THIS ROUTINE FORMS THE 1-NORM OF THE RESIDUAL MATRIX A*X-X*EVAL +C* WHERE A IS A SYMMETRIC TRIDIAGONAL MATRIX STORED +C* IN THE DIAGONAL (D) AND SUB-DIAGONAL (E) VECTORS, EVAL IS THE +C* EIGENVALUE OF AN EIGENVECTOR OF A, NAMELY X. +C* THIS NORM IS SCALED BY MACHINE ACCURACY FOR THE PROBLEM SIZE. +C* ALL NORMS APPEARING IN THE COMMENTS BELOW ARE 1-NORMS. +C* +C* ON ENTRY - +C* N - INTEGER +C* THE ORDER OF THE MATRIX A. +C* EVAL - W.P. REAL +C* THE EIGENVALUE CORRESPONDING TO VECTOR X. +C* D - W.P. REAL (N) +C* THE DIAGONAL VECTOR OF A. +C* E - W.P. REAL (N) +C* THE SUB-DIAGONAL VECTOR OF A. +C* X - W.P. REAL (N) +C* AN EIGENVECTOR OF A. +C* ANORM - W.P. REAL +C* THE NORM OF A IF IT HAS BEEN PREVIOUSLY COMPUTED. +C* +C* ON EXIT - +C* ANORM - W.P. REAL +C* THE NORM OF A, COMPUTED IF INITIALLY ZERO. +C* ESTPI1 - W.P. REAL +C* !!A*X-X*EVAL!! / (EPSLON(10*N)*!!A!!*!!X!!); +C* WHERE EPSLON(X) IS THE SMALLEST NUMBER SUCH THAT +C* X + EPSLON(X) .NE. X +C* +C* ESTPI1 .LT. 1 == SATISFACTORY PERFORMANCE +C* .GE. 1 AND .LE. 100 == MARGINAL PERFORMANCE +C* .GT. 100 == POOR PERFORMANCE +C* (SEE LECT. NOTES IN COMP. SCI. VOL.6 PP 124-125) +C + DOUBLE PRECISION ANORM,EVAL,RNORM,SIZE,XNORM + DOUBLE PRECISION D(N), E(N), X(N) + DOUBLE PRECISION EPSLON, ONE, ZERO +C + PARAMETER (ZERO = 0.0D+00, ONE = 1.0D+00) +C +C----------------------------------------------------------------------- +C + ESTPI1 = ZERO + IF( N .LE. 1 ) RETURN + SIZE = 10 * N + IF (ANORM .EQ. ZERO) THEN +C +C COMPUTE NORM OF A +C + ANORM = MAX( ABS(D(1)) + ABS(E(2)) + * ,ABS(D(N)) + ABS(E(N))) + DO 110 I = 2, N-1 + ANORM = MAX( ANORM, ABS(E(I))+ABS(D(I))+ABS(E(I+1))) + 110 CONTINUE + IF(ANORM .EQ. ZERO) ANORM = ONE + END IF +C +C COMPUTE NORMS OF RESIDUAL AND EIGENVECTOR +C + XNORM = ABS(X(1)) + ABS(X(N)) + RNORM = ABS( (D(1)-EVAL)*X(1) + E(2)*X(2)) + * +ABS( (D(N)-EVAL)*X(N) + E(N)*X(N-1)) + DO 120 I = 2, N-1 + XNORM = XNORM + ABS(X(I)) + RNORM = RNORM + ABS(E(I)*X(I-1) + (D(I)-EVAL)*X(I) + * + E(I+1)*X(I+1)) + 120 CONTINUE +C + ESTPI1 = RNORM / (EPSLON(SIZE)*ANORM*XNORM) + RETURN + END +C*MODULE EIGEN *DECK ETRBK3 + SUBROUTINE ETRBK3(NM,N,NV,A,M,Z) +C* +C* AUTHORS- +C* THIS IS A MODIFICATION OF ROUTINE TRBAK3 FROM EISPACK EDITION 3 +C* DATED AUGUST 1983. +C* EISPACK TRBAK3 IS A TRANSLATION OF THE ALGOL PROCEDURE TRBAK3, +C* NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. +C* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). +C* THIS VERSION IS BY S. T. ELBERT (AMES LABORATORY-USDOE) +C* +C* PURPOSE - +C* THIS ROUTINE FORMS THE EIGENVECTORS OF A REAL SYMMETRIC +C* MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING +C* SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY ETRED3. +C* +C* METHOD - +C* THE CALCULATION IS CARRIED OUT BY FORMING THE MATRIX PRODUCT +C* Q*Z +C* WHERE Q IS A PRODUCT OF THE ORTHOGONAL SYMMETRIC MATRICES +C* Q = PROD(I)[1 - U(I)*.TRANSPOSE.U(I)*H(I)] +C* U IS THE AUGMENTED SUB-DIAGONAL ROWS OF A AND +C* Z IS THE SET OF EIGENVECTORS OF THE TRIDIAGONAL +C* MATRIX F WHICH WAS FORMED FROM THE ORIGINAL SYMMETRIC +C* MATRIX C BY THE SIMILARITY TRANSFORMATION +C* F = Q(TRANSPOSE) C Q +C* NOTE THAT ETRBK3 PRESERVES VECTOR EUCLIDEAN NORMS. +C* +C* +C* COMPLEXITY - +C* M*N**2 +C* +C* ON ENTRY- +C* NM - INTEGER +C* MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL +C* ARRAY PARAMETERS AS DECLARED IN THE CALLING ROUTINE +C* DIMENSION STATEMENT. +C* N - INTEGER +C* THE ORDER OF THE MATRIX A. +C* NV - INTEGER +C* MUST BE SET TO THE DIMENSION OF THE ARRAY A AS +C* DECLARED IN THE CALLING ROUTINE DIMENSION STATEMENT. +C* A - W.P. REAL (NV) +C* CONTAINS INFORMATION ABOUT THE ORTHOGONAL +C* TRANSFORMATIONS USED IN THE REDUCTION BY ETRED3 IN +C* ITS FIRST NV = N*(N+1)/2 POSITIONS. +C* M - INTEGER +C* THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. +C* Z - W.P REAL (NM,M) +C* CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED +C* IN ITS FIRST M COLUMNS. +C* +C* ON EXIT- +C* Z - W.P. REAL (NM,M) +C* CONTAINS THE TRANSFORMED EIGENVECTORS +C* IN ITS FIRST M COLUMNS. +C* +C* DIFFERENCES WITH EISPACK 3 - +C* THE TWO INNER LOOPS ARE REPLACED BY DDOT AND DAXPY. +C* MULTIPLICATION USED INSTEAD OF DIVISION TO FIND S. +C* OUTER LOOP RANGE CHANGED FROM 2,N TO 3,N. +C* ADDRESS POINTERS FOR A SIMPLIFIED. +C* +C* NOTE - +C* QUESTIONS AND COMMENTS CONCERNING EISPACK SHOULD BE DIRECTED TO +C* B. S. GARBOW, APPLIED MATH. DIVISION, ARGONNE NATIONAL LAB. +C + INTEGER I,II,IM1,IZ,J,M,N,NM,NV +C + DOUBLE PRECISION A(NV),Z(NM,M) + DOUBLE PRECISION H,S,DDOT,ZERO +C + PARAMETER (ZERO = 0.0D+00) +C +C----------------------------------------------------------------------- +C + IF (M .EQ. 0) RETURN + IF (N .LE. 2) RETURN +C + II=3 + DO 140 I = 3, N + IZ=II+1 + II=II+I + H = A(II) + IF (H .EQ. ZERO) GO TO 140 + IM1 = I - 1 + DO 130 J = 1, M + S = -( DDOT(IM1,A(IZ),1,Z(1,J),1) * H) * H + CALL DAXPY(IM1,S,A(IZ),1,Z(1,J),1) + 130 CONTINUE + 140 CONTINUE + RETURN + END +C*MODULE EIGEN *DECK ETRED3 + SUBROUTINE ETRED3(N,NV,A,D,E,E2) +C* +C* AUTHORS - +C* THIS IS A MODIFICATION OF ROUTINE TRED3 FROM EISPACK EDITION 3 +C* DATED AUGUST 1983. +C* EISPACK TRED3 IS A TRANSLATION OF THE ALGOL PROCEDURE TRED3, +C* NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. +C* HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). +C* THIS VERSION IS BY S. T. ELBERT, AMES LABORATORY-USDOE JUN 1986 +C* +C* PURPOSE - +C* THIS ROUTINE REDUCES A REAL SYMMETRIC (PACKED) MATRIX, STORED +C* AS A ONE-DIMENSIONAL ARRAY, TO A SYMMETRIC TRIDIAGONAL MATRIX +C* USING ORTHOGONAL SIMILARITY TRANSFORMATIONS, PRESERVING THE +C* INFORMATION ABOUT THE TRANSFORMATIONS IN A. +C* +C* METHOD - +C* THE TRIDIAGONAL REDUCTION IS PERFORMED IN THE FOLLOWING WAY. +C* STARTING WITH J=N, THE ELEMENTS IN THE J-TH ROW TO THE +C* LEFT OF THE DIAGONAL ARE FIRST SCALED, TO AVOID POSSIBLE +C* UNDERFLOW IN THE TRANSFORMATION THAT MIGHT RESULT IN SEVERE +C* DEPARTURE FROM ORTHOGONALITY. THE SUM OF SQUARES SIGMA OF +C* THESE SCALED ELEMENTS IS NEXT FORMED. THEN, A VECTOR U AND +C* A SCALAR +C* H = U(TRANSPOSE) * U / 2 +C* DEFINE A REFLECTION OPERATOR +C* P = I - U * U(TRANSPOSE) / H +C* WHICH IS ORTHOGONAL AND SYMMETRIC AND FOR WHICH THE +C* SIMILIARITY TRANSFORMATION PAP ELIMINATES THE ELEMENTS IN +C* THE J-TH ROW OF A TO THE LEFT OF THE SUBDIAGONAL AND THE +C* SYMMETRICAL ELEMENTS IN THE J-TH COLUMN. +C* +C* THE NON-ZERO COMPONENTS OF U ARE THE ELEMENTS OF THE J-TH +C* ROW TO THE LEFT OF THE DIAGONAL WITH THE LAST OF THEM +C* AUGMENTED BY THE SQUARE ROOT OF SIGMA PREFIXED BY THE SIGN +C* OF THE SUBDIAGONAL ELEMENT. BY STORING THE TRANSFORMED SUB- +C* DIAGONAL ELEMENT IN E(J) AND NOT OVERWRITING THE ROW +C* ELEMENTS ELIMINATED IN THE TRANSFORMATION, FULL INFORMATION +C* ABOUT P IS SAVE FOR LATER USE IN ETRBK3. +C* +C* THE TRANSFORMATION SETS E2(J) EQUAL TO SIGMA AND E(J) +C* EQUAL TO THE SQUARE ROOT OF SIGMA PREFIXED BY THE SIGN +C* OF THE REPLACED SUBDIAGONAL ELEMENT. +C* +C* THE ABOVE STEPS ARE REPEATED ON FURTHER ROWS OF THE +C* TRANSFORMED A IN REVERSE ORDER UNTIL A IS REDUCED TO TRI- +C* DIAGONAL FORM, THAT IS, REPEATED FOR J = N-1,N-2,...,3. +C* +C* COMPLEXITY - +C* 2/3 N**3 +C* +C* ON ENTRY- +C* N - INTEGER +C* THE ORDER OF THE MATRIX. +C* NV - INTEGER +C* MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A +C* AS DECLARED IN THE CALLING ROUTINE DIMENSION STATEMENT +C* A - W.P. REAL (NV) +C* CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC +C* INPUT MATRIX, STORED ROW-WISE AS A ONE-DIMENSIONAL +C* ARRAY, IN ITS FIRST N*(N+1)/2 POSITIONS. +C* +C* ON EXIT- +C* A - W.P. REAL (NV) +C* CONTAINS INFORMATION ABOUT THE ORTHOGONAL +C* TRANSFORMATIONS USED IN THE REDUCTION. +C* D - W.P. REAL (N) +C* CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL +C* MATRIX. +C* E - W.P. REAL (N) +C* CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL +C* MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO +C* E2 - W.P. REAL (N) +C* CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF +C* E. MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. +C* +C* DIFFERENCES FROM EISPACK 3 - +C* OUTER LOOP CHANGED FROM II=1,N TO I=N,3,-1 +C* PARAMETER STATEMENT AND GENERIC INTRINSIC FUNCTIONS USED +C* SCALE.NE.0 TEST NOW SPOTS TRI-DIAGONAL FORM +C* VALUES LESS THAN EPSLON CLEARED TO ZERO +C* USE BLAS(1) +C* U NOT COPIED TO D, LEFT IN A +C* E2 COMPUTED FROM E +C* INNER LOOPS SPLIT INTO ROUTINES ELAU AND FREDA +C* INVERSE OF H STORED INSTEAD OF H +C* +C* NOTE - +C* QUESTIONS AND COMMENTS CONCERNING EISPACK SHOULD BE DIRECTED TO +C* B. S. GARBOW, APPLIED MATH. DIVISION, ARGONNE NATIONAL LAB. +C + INTEGER I,IIA,IZ0,L,N,NV +C + DOUBLE PRECISION A(NV),D(N),E(N),E2(N) + DOUBLE PRECISION AIIMAX,F,G,H,HROOT,SCALE,SCALEI + DOUBLE PRECISION DASUM, DNRM2 + DOUBLE PRECISION ONE, ZERO +C + PARAMETER (ZERO = 0.0D+00, ONE = 1.0D+00) +C +C----------------------------------------------------------------------- +C + IF (N .LE. 2) GO TO 310 + IZ0 = (N*N+N)/2 + AIIMAX = ABS(A(IZ0)) + DO 300 I = N, 3, -1 + L = I - 1 + IIA = IZ0 + IZ0 = IZ0 - I + AIIMAX = MAX(AIIMAX, ABS(A(IIA))) + SCALE = DASUM (L, A(IZ0+1), 1) + IF(SCALE .EQ. ABS(A(IIA-1)) .OR. AIIMAX+SCALE .EQ. AIIMAX) THEN +C +C THIS ROW IS ALREADY IN TRI-DIAGONAL FORM +C + D(I) = A(IIA) + IF (AIIMAX+D(I) .EQ. AIIMAX) D(I) = ZERO + E(I) = A(IIA-1) + IF (AIIMAX+E(I) .EQ. AIIMAX) E(I) = ZERO + E2(I) = E(I)*E(I) + A(IIA) = ZERO + GO TO 300 +C + END IF +C + SCALEI = ONE / SCALE + CALL DSCAL(L,SCALEI,A(IZ0+1),1) + HROOT = DNRM2(L,A(IZ0+1),1) +C + F = A(IZ0+L) + G = -SIGN(HROOT,F) + E(I) = SCALE * G + E2(I) = E(I)*E(I) + H = HROOT*HROOT - F * G + A(IZ0+L) = F - G + D(I) = A(IIA) + A(IIA) = ONE / SQRT(H) +C .......... FORM P THEN Q IN E(1:L) .......... + CALL ELAU(ONE/H,L,A(IZ0+1),A,E) +C .......... FORM REDUCED A .......... + CALL FREDA(L,A(IZ0+1),A,E) +C + 300 CONTINUE + 310 CONTINUE + E(1) = ZERO + E2(1)= ZERO + D(1) = A(1) + IF(N.EQ.1) RETURN +C + E(2) = A(2) + E2(2)= A(2)*A(2) + D(2) = A(3) + RETURN + END +C*MODULE EIGEN *DECK EVVRSP + SUBROUTINE EVVRSP(MSGFL,N,NVECT,LENA,NV,A,B,IND,ROOT, + * VECT,IORDER,IERR) +C* +C* AUTHOR: S. T. ELBERT, AMES LABORATORY-USDOE, JUNE 1985 +C* +C* PURPOSE - +C* FINDS (ALL) EIGENVALUES AND (SOME OR ALL) EIGENVECTORS +C* * * * +C* OF A REAL SYMMETRIC PACKED MATRIX. +C* * * * +C* +C* METHOD - +C* THE METHOD AS PRESENTED IN THIS ROUTINE CONSISTS OF FOUR STEPS: +C* FIRST, THE INPUT MATRIX IS REDUCED TO TRIDIAGONAL FORM BY THE +C* HOUSEHOLDER TECHNIQUE (ORTHOGONAL SIMILARITY TRANSFORMATIONS). +C* SECOND, THE ROOTS ARE LOCATED USING THE RATIONAL QL METHOD. +C* THIRD, THE VECTORS OF THE TRIDIAGONAL FORM ARE EVALUATED BY THE +C* INVERSE ITERATION TECHNIQUE. VECTORS FOR DEGENERATE OR NEAR- +C* DEGENERATE ROOTS ARE FORCED TO BE ORTHOGONAL. +C* FOURTH, THE TRIDIAGONAL VECTORS ARE ROTATED TO VECTORS OF THE +C* ORIGINAL ARRAY. +C* +C* THESE ROUTINES ARE MODIFICATIONS OF THE EISPACK 3 +C* ROUTINES TRED3, TQLRAT, TINVIT AND TRBAK3 +C* +C* FOR FURTHER DETAILS, SEE EISPACK USERS GUIDE, B. T. SMITH +C* ET AL, SPRINGER-VERLAG, LECTURE NOTES IN COMPUTER SCIENCE, +C* VOL. 6, 2-ND EDITION, 1976. ANOTHER GOOD REFERENCE IS +C* THE SYMMETRIC EIGENVALUE PROBLEM BY B. N. PARLETT +C* PUBLISHED BY PRENTICE-HALL, INC., ENGLEWOOD CLIFFS, N.J. (1980) +C* +C* ON ENTRY - +C* MSGFL - INTEGER (LOGICAL UNIT NO.) +C* FILE WHERE ERROR MESSAGES WILL BE PRINTED. +C* IF MSGFL IS 0, ERROR MESSAGES WILL BE PRINTED ON LU 6. +C* IF MSGFL IS NEGATIVE, NO ERROR MESSAGES PRINTED. +C* N - INTEGER +C* ORDER OF MATRIX A. +C* NVECT - INTEGER +C* NUMBER OF VECTORS DESIRED. 0 .LE. NVECT .LE. N. +C* LENA - INTEGER +C* DIMENSION OF A IN CALLING ROUTINE. MUST NOT BE LESS +C* THAN (N*N+N)/2. +C* NV - INTEGER +C* ROW DIMENSION OF VECT IN CALLING ROUTINE. N .LE. NV. +C* A - WORKING PRECISION REAL (LENA) +C* INPUT MATRIX, ROWS OF THE LOWER TRIANGLE PACKED INTO +C* LINEAR ARRAY OF DIMENSION N*(N+1)/2. THE PACKED ORDER +C* IS A(1,1), A(2,1), A(2,2), A(3,1), A(3,2), ... +C* B - WORKING PRECISION REAL (N,8) +C* SCRATCH ARRAY, 8*N ELEMENTS +C* IND - INTEGER (N) +C* SCRATCH ARRAY OF LENGTH N. +C* IORDER - INTEGER +C* ROOT ORDERING FLAG. +C* = 0, ROOTS WILL BE PUT IN ASCENDING ORDER. +C* = 2, ROOTS WILL BE PUT IN DESCENDING ORDER. +C* +C* ON EXIT - +C* A - DESTORYED. NOW HOLDS REFLECTION OPERATORS. +C* ROOT - WORKING PRECISION REAL (N) +C* ALL EIGENVALUES IN ASCENDING OR DESCENDING ORDER. +C* IF IORDER = 0, ROOT(1) .LE. ... .LE. ROOT(N) +C* IF IORDER = 2, ROOT(1) .GE. ... .GE. ROOT(N) +C* VECT - WORKING PRECISION REAL (NV,NVECT) +C* EIGENVECTORS FOR ROOT(1), ..., ROOT(NVECT). +C* IERR - INTEGER +C* = 0 IF NO ERROR DETECTED, +C* = K IF ITERATION FOR K-TH EIGENVALUE FAILED, +C* = -K IF ITERATION FOR K-TH EIGENVECTOR FAILED. +C* (FAILURES SHOULD BE VERY RARE. CONTACT C. MOLER.) +C* +C + LOGICAL GOPARR,DSKWRK,MASWRK +C + DOUBLE PRECISION A(LENA) + DOUBLE PRECISION B(N,8) + DOUBLE PRECISION ROOT(N) + DOUBLE PRECISION T + DOUBLE PRECISION VECT(NV,*) +C + INTEGER IND(N) +C + COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK +C + 900 FORMAT(26H0*** EVVRSP PARAMETERS ***/ + + 14H *** N = ,I8,4H ***/ + + 14H *** NVECT = ,I8,4H ***/ + + 14H *** LENA = ,I8,4H ***/ + + 14H *** NV = ,I8,4H ***/ + + 14H *** IORDER = ,I8,4H ***/ + + 14H *** IERR = ,I8,4H ***) + 901 FORMAT(37H VALUE OF LENA IS LESS THAN (N*N+N)/2) + 902 FORMAT(39H EQLRAT HAS FAILED TO CONVERGE FOR ROOT,I5) + 903 FORMAT(18H NV IS LESS THAN N) + 904 FORMAT(41H EINVIT HAS FAILED TO CONVERGE FOR VECTOR,I5) + 905 FORMAT(51H VALUE OF IORDER MUST BE 0 (SMALLEST ROOT FIRST) OR + * ,23H 2 (LARGEST ROOT FIRST)) + 906 FORMAT(' VALUE OF N IS LESS THAN OR EQUAL ZERO') +C +C----------------------------------------------------------------------- +C + LMSGFL=MSGFL + IF (MSGFL .EQ. 0) LMSGFL=6 + IERR = N - 1 + IF (N .LE. 0) GO TO 800 + IERR = N + 1 + IF ( (N*N+N)/2 .GT. LENA) GO TO 810 +C +C REDUCE REAL SYMMETRIC MATRIX A TO TRIDIAGONAL FORM +C + CALL ETRED3(N,LENA,A,B(1,1),B(1,2),B(1,3)) +C +C FIND ALL EIGENVALUES OF TRIDIAGONAL MATRIX +C + CALL EQLRAT(N,B(1,1),B(1,2),B(1,3),ROOT,IND,IERR,B(1,4)) + IF (IERR .NE. 0) GO TO 820 +C +C CHECK THE DESIRED ORDER OF THE EIGENVALUES +C + B(1,3) = IORDER + IF (IORDER .EQ. 0) GO TO 300 + IF (IORDER .NE. 2) GO TO 850 +C +C ORDER ROOTS IN DESCENDING ORDER (LARGEST FIRST)... +C TURN ROOT AND IND ARRAYS END FOR END +C + DO 210 I = 1, N/2 + J = N+1-I + T = ROOT(I) + ROOT(I) = ROOT(J) + ROOT(J) = T + L = IND(I) + IND(I) = IND(J) + IND(J) = L + 210 CONTINUE +C +C FIND I AND J MARKING THE START AND END OF A SEQUENCE +C OF DEGENERATE ROOTS +C + I=0 + 220 CONTINUE + I = I+1 + IF (I .GT. N) GO TO 300 + DO 230 J=I,N + IF (ROOT(J) .NE. ROOT(I)) GO TO 240 + 230 CONTINUE + J = N+1 + 240 CONTINUE + J = J-1 + IF (J .EQ. I) GO TO 220 +C +C TURN AROUND IND BETWEEN I AND J +C + JSV = J + KLIM = (J-I+1)/2 + DO 250 K=1,KLIM + L = IND(J) + IND(J) = IND(I) + IND(I) = L + I = I+1 + J = J-1 + 250 CONTINUE + I = JSV + GO TO 220 +C + 300 CONTINUE +C + IF (NVECT .LE. 0) RETURN + IF (NV .LT. N) GO TO 830 +C +C FIND EIGENVECTORS OF TRI-DIAGONAL MATRIX VIA INVERSE ITERATION +C + IERR = LMSGFL + CALL EINVIT(NV,N,B(1,1),B(1,2),B(1,3),NVECT,ROOT,IND, + + VECT,IERR,B(1,4),B(1,5),B(1,6),B(1,7),B(1,8)) + IF (IERR .NE. 0) GO TO 840 +C +C FIND EIGENVECTORS OF SYMMETRIC MATRIX VIA BACK TRANSFORMATION +C + 400 CONTINUE + CALL ETRBK3(NV,N,LENA,A,NVECT,VECT) + RETURN +C +C ERROR MESSAGE SECTION +C + 800 IF (LMSGFL .LT. 0) RETURN + IF (MASWRK) WRITE(LMSGFL,906) + GO TO 890 +C + 810 IF (LMSGFL .LT. 0) RETURN + IF (MASWRK) WRITE(LMSGFL,901) + GO TO 890 +C + 820 IF (LMSGFL .LT. 0) RETURN + IF (MASWRK) WRITE(LMSGFL,902) IERR + GO TO 890 +C + 830 IF (LMSGFL .LT. 0) RETURN + IF (MASWRK) WRITE(LMSGFL,903) + GO TO 890 +C + 840 CONTINUE + IF ((LMSGFL .GT. 0).AND.MASWRK) WRITE(LMSGFL,904) -IERR + GO TO 400 +C + 850 IERR=-1 + IF (LMSGFL .LT. 0) RETURN + IF (MASWRK) WRITE(LMSGFL,905) + GO TO 890 +C + 890 CONTINUE + IF (MASWRK) WRITE(LMSGFL,900) N,NVECT,LENA,NV,IORDER,IERR + RETURN + END +C*MODULE EIGEN *DECK FREDA + SUBROUTINE FREDA(L,D,A,E) +C + DOUBLE PRECISION A(*) + DOUBLE PRECISION D(L) + DOUBLE PRECISION E(L) + DOUBLE PRECISION F + DOUBLE PRECISION G +C + JK = 1 +C +C .......... FORM REDUCED A .......... +C + DO 280 J = 1, L + F = D(J) + G = E(J) +C + DO 260 K = 1, J + A(JK) = A(JK) - F * E(K) - G * D(K) + JK = JK + 1 + 260 CONTINUE +C + 280 CONTINUE + RETURN + END +C*MODULE EIGEN *DECK GIVEIS + SUBROUTINE GIVEIS(N,NVECT,NV,A,B,INDB,ROOT,VECT,IERR) + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + DIMENSION A(*),B(N,8),INDB(N),ROOT(N),VECT(NV,NVECT) +C +C EISPACK-BASED SUBSTITUTE FOR QCPE ROUTINE GIVENS. +C FINDS ALL EIGENVALUES AND SOME EIGENVECTORS OF A REAL SYMMETRIC +C MATRIX. AUTHOR.. C. MOLER AND D. SPANGLER, N.R.C.C., 4/1/79. +C +C INPUT.. +C N = ORDER OF MATRIX . +C NVECT = NUMBER OF VECTORS DESIRED. 0 .LE. NVECT .LE. N . +C NV = LEADING DIMENSION OF VECT . +C A = INPUT MATRIX, COLUMNS OF THE UPPER TRIANGLE PACKED INTO +C LINEAR ARRAY OF DIMENSION N*(N+1)/2 . +C B = SCRATCH ARRAY, 8*N ELEMENTS (NOTE THIS IS MORE THAN +C PREVIOUS VERSIONS OF GIVENS.) +C IND = INDEX ARRAY OF N ELEMENTS +C +C OUTPUT.. +C A DESTROYED . +C ROOT = ALL EIGENVALUES, ROOT(1) .LE. ... .LE. ROOT(N) . +C (FOR OTHER ORDERINGS, SEE BELOW.) +C VECT = EIGENVECTORS FOR ROOT(1),..., ROOT(NVECT) . +C IERR = 0 IF NO ERROR DETECTED, +C = K IF ITERATION FOR K-TH EIGENVALUE FAILED, +C = -K IF ITERATION FOR K-TH EIGENVECTOR FAILED. +C (FAILURES SHOULD BE VERY RARE. CONTACT MOLER.) +C +C CALLS MODIFIED EISPACK ROUTINES TRED3B, IMTQLV, TINVTB, AND +C TRBK3B. THE ROUTINES TRED3B, TINVTB, AND TRBK3B. +C THE ORIGINAL EISPACK ROUTINES TRED3, TINVIT, AND TRBAK3 +C WERE MODIFIED BY THE INTRODUCTION OF TWO ROUTINES FROM THE +C BLAS LIBRARY - DDOT AND DAXPY. +C +C IF TINVIT FAILS TO CONVERGE, TQL2 IS CALLED +C +C SEE EISPACK USERS GUIDE, B. T. SMITH ET AL, SPRINGER-VERLAG +C LECTURE NOTES IN COMPUTER SCIENCE, VOL. 6, 2-ND EDITION, 1976 . +C NOTE THAT IMTQLV AND TINVTB HAVE INTERNAL MACHINE +C DEPENDENT CONSTANTS. +C + DATA ONE, ZERO /1.0D+00, 0.0D+00/ + CALL TRED3B(N,(N*N+N)/2,A,B(1,1),B(1,2),B(1,3)) + CALL IMTQLV(N,B(1,1),B(1,2),B(1,3),ROOT,INDB,IERR,B(1,4)) + IF (IERR .NE. 0) RETURN +C +C TO REORDER ROOTS... +C K = N/2 +C B(1,3) = 2.0D+00 +C DO 50 I = 1, K +C J = N+1-I +C T = ROOT(I) +C ROOT(I) = ROOT(J) +C ROOT(J) = T +C 50 CONTINUE +C + IF (NVECT .LE. 0) RETURN + CALL TINVTB(NV,N,B(1,1),B(1,2),B(1,3),NVECT,ROOT,INDB,VECT,IERR, + + B(1,4),B(1,5),B(1,6),B(1,7),B(1,8)) + IF (IERR .EQ. 0) GO TO 160 +C +C IF INVERSE ITERATION GIVES AN ERROR IN DETERMINING THE +C EIGENVECTORS, TRY THE QL ALGORITHM IF ALL THE EIGENVECTORS +C ARE DESIRED. +C + IF (NVECT .NE. N) RETURN + DO 120 I = 1, NVECT + DO 100 J = 1, N + VECT(I,J) = ZERO + 100 CONTINUE + VECT(I,I) = ONE + 120 CONTINUE + CALL TQL2 (NV,N,B(1,1),B(1,2),VECT,IERR) + DO 140 I = 1, NVECT + ROOT(I) = B(I,1) + 140 CONTINUE + IF (IERR .NE. 0) RETURN + 160 CALL TRBK3B(NV,N,(N*N+N)/2,A,NVECT,VECT) + RETURN + END +C*MODULE EIGEN *DECK GLDIAG + SUBROUTINE GLDIAG(LDVECT,NVECT,N,H,WRK,EIG,VECTOR,IERR,IWRK) +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C + LOGICAL GOPARR,DSKWRK,MASWRK +C + DIMENSION H(*),WRK(N,8),EIG(N),VECTOR(LDVECT,NVECT),IWRK(N) +C + COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(400) + COMMON /MACHSW/ KDIAG,ICORFL,IXDR + COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK +C +C ----- GENERAL ROUTINE TO DIAGONALIZE A SYMMETRIC MATRIX ----- +C IF KDIAG = 0, USE A ROUTINE FROM THE VECTOR LIBRARY, +C IF AVAILABLE (SEE THE SUBROUTINE 'GLDIAG' +C IN VECTOR.SRC), OR EVVRSP OTHERWISE +C = 1, USE EVVRSP +C = 2, USE GIVEIS +C = 3, USE JACOBI +C +C N = DIMENSION (ORDER) OF MATRIX TO BE SOLVED +C LDVECT = LEADING DIMENSION OF VECTOR +C NVECT = NUMBER OF VECTORS DESIRED +C H = MATRIX TO BE DIAGONALIZED +C WRK = N*8 W.P. REAL WORDS OF SCRATCH SPACE +C EIG = EIGENVECTORS (OUTPUT) +C VECTOR = EIGENVECTORS (OUTPUT) +C IERR = ERROR FLAG (OUTPUT) +C IWRK = N INTEGER WORDS OF SCRATCH SPACE +C + IERR = 0 +C +C ----- USE STEVE ELBERT'S ROUTINE ----- +C + IF(KDIAG.LE.1 .OR. KDIAG.GT.3) THEN + LENH = (N*N+N)/2 + KORDER =0 + CALL EVVRSP(IW,N,NVECT,LENH,LDVECT,H,WRK,IWRK,EIG,VECTOR + * ,KORDER,IERR) + END IF +C +C ----- USE MODIFIED EISPAK ROUTINE ----- +C + IF(KDIAG.EQ.2) + * CALL GIVEIS(N,NVECT,LDVECT,H,WRK,IWRK,EIG,VECTOR,IERR) +C +C ----- USE JACOBI ROTATION ROUTINE ----- +C + IF(KDIAG.EQ.3) THEN + IF(NVECT.EQ.N) THEN + CALL JACDG(H,VECTOR,EIG,IWRK,WRK,LDVECT,N) + ELSE + IF (MASWRK) WRITE(IW,9000) N,NVECT,LDVECT + CALL ABRT + END IF + END IF + RETURN +C + 9000 FORMAT(1X,'IN -GLDIAG-, N,NVECT,LDVECT=',3I8/ + * 1X,'THE JACOBI CODE CANNOT COPE WITH N.NE.NVECT!'/ + * 1X,'SO THIS RUN DOES NOT PERMIT KDIAG=3.') + END +C*MODULE EIGEN *DECK IMTQLV + SUBROUTINE IMTQLV(N,D,E,E2,W,IND,IERR,RV1) + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + INTEGER TAG + DOUBLE PRECISION MACHEP + DIMENSION D(N),E(N),E2(N),W(N),RV1(N),IND(N) +C +C THIS ROUTINE IS A VARIANT OF IMTQL1 WHICH IS A TRANSLATION OF +C ALGOL PROCEDURE IMTQL1, NUM. MATH. 12, 377-383(1968) BY MARTIN AND +C WILKINSON, AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE. +C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971). +C +C THIS ROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC TRIDIAGONAL +C MATRIX BY THE IMPLICIT QL METHOD AND ASSOCIATES WITH THEM +C THEIR CORRESPONDING SUBMATRIX INDICES. +C +C ON INPUT- +C +C N IS THE ORDER OF THE MATRIX, +C +C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX, +C +C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX +C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY, +C +C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. +C E2(1) IS ARBITRARY. +C +C ON OUTPUT- +C +C D AND E ARE UNALTERED, +C +C ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED +C AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE +C MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES. +C E2(1) IS ALSO SET TO ZERO, +C +C W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN +C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND +C ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE +C THE SMALLEST EIGENVALUES, +C +C IND CONTAINS THE SUBMATRIX INDICES ASSOCIATED WITH THE +C CORRESPONDING EIGENVALUES IN W -- 1 FOR EIGENVALUES +C BELONGING TO THE FIRST SUBMATRIX FROM THE TOP, +C 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC., +C +C IERR IS SET TO +C ZERO FOR NORMAL RETURN, +C J IF THE J-TH EIGENVALUE HAS NOT BEEN +C DETERMINED AFTER 30 ITERATIONS, +C +C RV1 IS A TEMPORARY STORAGE ARRAY. +C +C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW, +C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY +C +C ------------------------------------------------------------------ +C +C ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING +C THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC. +C +C ********** + MACHEP = 2.0D+00**(-50) +C + IERR = 0 + K = 0 + TAG = 0 +C + DO 100 I = 1, N + W(I) = D(I) + IF (I .NE. 1) RV1(I-1) = E(I) + 100 CONTINUE +C + E2(1) = 0.0D+00 + RV1(N) = 0.0D+00 +C + DO 360 L = 1, N + J = 0 +C ********** LOOK FOR SMALL SUB-DIAGONAL ELEMENT ********** + 120 DO 140 M = L, N + IF (M .EQ. N) GO TO 160 + IF (ABS(RV1(M)) .LE. MACHEP * (ABS(W(M)) + ABS(W(M+1)))) GO TO + + 160 +C ********** GUARD AGAINST UNDERFLOWED ELEMENT OF E2 ********** + IF (E2(M+1) .EQ. 0.0D+00) GO TO 180 + 140 CONTINUE +C + 160 IF (M .LE. K) GO TO 200 + IF (M .NE. N) E2(M+1) = 0.0D+00 + 180 K = M + TAG = TAG + 1 + 200 P = W(L) + IF (M .EQ. L) GO TO 280 + IF (J .EQ. 30) GO TO 380 + J = J + 1 +C ********** FORM SHIFT ********** + G = (W(L+1) - P) / (2.0D+00 * RV1(L)) + R = SQRT(G*G+1.0D+00) + G = W(M) - P + RV1(L) / (G + SIGN(R,G)) + S = 1.0D+00 + C = 1.0D+00 + P = 0.0D+00 + MML = M - L +C ********** FOR I=M-1 STEP -1 UNTIL L DO -- ********** + DO 260 II = 1, MML + I = M - II + F = S * RV1(I) + B = C * RV1(I) + IF (ABS(F) .LT. ABS(G)) GO TO 220 + C = G / F + R = SQRT(C*C+1.0D+00) + RV1(I+1) = F * R + S = 1.0D+00 / R + C = C * S + GO TO 240 + 220 S = F / G + R = SQRT(S*S+1.0D+00) + RV1(I+1) = G * R + C = 1.0D+00 / R + S = S * C + 240 G = W(I+1) - P + R = (W(I) - G) * S + 2.0D+00 * C * B + P = S * R + W(I+1) = G + P + G = C * R - B + 260 CONTINUE +C + W(L) = W(L) - P + RV1(L) = G + RV1(M) = 0.0D+00 + GO TO 120 +C ********** ORDER EIGENVALUES ********** + 280 IF (L .EQ. 1) GO TO 320 +C ********** FOR I=L STEP -1 UNTIL 2 DO -- ********** + DO 300 II = 2, L + I = L + 2 - II + IF (P .GE. W(I-1)) GO TO 340 + W(I) = W(I-1) + IND(I) = IND(I-1) + 300 CONTINUE +C + 320 I = 1 + 340 W(I) = P + IND(I) = TAG + 360 CONTINUE +C + GO TO 400 +C ********** SET ERROR -- NO CONVERGENCE TO AN +C EIGENVALUE AFTER 30 ITERATIONS ********** + 380 IERR = L + 400 RETURN +C ********** LAST CARD OF IMTQLV ********** + END +C*MODULE EIGEN *DECK JACDG + SUBROUTINE JACDG(A,VEC,EIG,JBIG,BIG,LDVEC,N) +C + IMPLICIT DOUBLE PRECISION(A-H,O-Z) +C + DIMENSION A(*),VEC(LDVEC,N),EIG(N),JBIG(N),BIG(N) +C + PARAMETER (ONE=1.0D+00) +C +C ----- JACOBI DIAGONALIZATION OF SYMMETRIC MATRIX ----- +C SYMMETRIC MATRIX -A- OF DIMENSION -N- IS DESTROYED ON EXIT. +C ALL EIGENVECTORS ARE FOUND, SO -VEC- MUST BE SQUARE, +C UNLESS SOMEONE TAKES THE TROUBLE TO LOOK AT -NMAX- BELOW. +C -BIG- AND -JBIG- ARE SCRATCH WORK ARRAYS. +C + CALL VCLR(VEC,1,LDVEC*N) + DO 20 I = 1,N + VEC(I,I) = ONE + 20 CONTINUE +C + NB1 = N + NB2 = (NB1*NB1+NB1)/2 + NMIN = 1 + NMAX = NB1 +C + CALL JACDIA(A,VEC,NB1,NB2,LDVEC,NMIN,NMAX,BIG,JBIG) +C + DO 30 I=1,N + EIG(I) = A((I*I+I)/2) + 30 CONTINUE +C + CALL JACORD(VEC,EIG,NB1,LDVEC) + RETURN + END +C*MODULE EIGEN *DECK JACDIA + SUBROUTINE JACDIA(F,VEC,NB1,NB2,LDVEC,NMIN,NMAX,BIG,JBIG) + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + LOGICAL GOPARR,DSKWRK,MASWRK + DIMENSION F(NB2),VEC(LDVEC,NB1),BIG(NB1),JBIG(NB1) +C + COMMON /PAR / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK +C + PARAMETER (ROOT2=0.707106781186548D+00 ) + PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, D1050=1.05D+00, + * D1500=1.5D+00, D3875=3.875D+00, + * D0500=0.5D+00, D1375=1.375D+00, D0250=0.25D+00 ) + PARAMETER (C2=1.0D-12, C3=4.0D-16, + * C4=2.0D-16, C5=8.0D-09, C6=3.0D-06 ) +C +C F IS THE MATRIX TO BE DIAGONALIZED, F IS STORED TRIANGULAR +C VEC IS THE ARRAY OF EIGENVECTORS, DIMENSION NB1*NB1 +C BIG AND JBIG ARE TEMPORARY SCRATCH AREAS OF DIMENSION NB1 +C THE ROTATIONS AMONG THE FIRST NMIN BASIS FUNCTIONS ARE NOT +C ACCOUNTED FOR. +C THE ROTATIONS AMONG THE LAST NB1-NMAX BASIS FUNCTIONS ARE NOT +C ACCOUNTED FOR. +C + IEAA=0 + IEAB=0 + TT=ZERO + EPS = 64.0D+00*EPSLON(ONE) +C +C LOOP OVER COLUMNS (K) OF TRIANGULAR MATRIX TO DETERMINE +C LARGEST OFF-DIAGONAL ELEMENTS IN ROW(I). +C + DO 20 I=1,NB1 + BIG(I)=ZERO + JBIG(I)=0 + IF(I.LT.NMIN .OR. I.EQ.1) GO TO 20 + II = (I*I-I)/2 + J=MIN(I-1,NMAX) + DO 10 K=1,J + IF(ABS(BIG(I)).GE.ABS(F(II+K))) GO TO 10 + BIG(I)=F(II+K) + JBIG(I)=K + 10 CONTINUE + 20 CONTINUE +C +C ----- 2X2 JACOBI ITERATIONS BEGIN HERE ----- +C + MAXIT=MAX(NB2*20,500) + ITER=0 + 30 CONTINUE + ITER=ITER+1 +C +C FIND SMALLEST DIAGONAL ELEMENT +C + SD=D1050 + JJ=0 + DO 40 J=1,NB1 + JJ=JJ+J + SD= MIN(SD,ABS(F(JJ))) + 40 CONTINUE + TEST = MAX(EPS, C2*MAX(SD,C6)) +C +C FIND LARGEST OFF-DIAGONAL ELEMENT +C + T=ZERO + I1=MAX(2,NMIN) + IB = I1 + DO 50 I=I1,NB1 + IF(T.GE.ABS(BIG(I))) GO TO 50 + T= ABS(BIG(I)) + IB=I + 50 CONTINUE +C +C TEST FOR CONVERGENCE, THEN DETERMINE ROTATION. +C + IF(T.LT.TEST) RETURN +C ****** +C + IF(ITER.GT.MAXIT) THEN + IF (MASWRK) THEN + WRITE(6,*) 'JACOBI DIAGONALIZATION FAILS, DIMENSION=',NB1 + WRITE(6,9020) ITER,T,TEST,SD + ENDIF + CALL ABRT + STOP + END IF +C + IA=JBIG(IB) + IAA=IA*(IA-1)/2 + IBB=IB*(IB-1)/2 + DIF=F(IAA+IA)-F(IBB+IB) + IF(ABS(DIF).GT.C3*T) GO TO 70 + SX=ROOT2 + CX=ROOT2 + GO TO 110 + 70 T2X2=BIG(IB)/DIF + T2X25=T2X2*T2X2 + IF(T2X25 . GT . C4) GO TO 80 + CX=ONE + SX=T2X2 + GO TO 110 + 80 IF(T2X25 . GT . C5) GO TO 90 + SX=T2X2*(ONE-D1500*T2X25) + CX=ONE-D0500*T2X25 + GO TO 110 + 90 IF(T2X25 . GT . C6) GO TO 100 + CX=ONE+T2X25*(T2X25*D1375 - D0500) + SX= T2X2*(ONE + T2X25*(T2X25*D3875 - D1500)) + GO TO 110 + 100 T=D0250 / SQRT(D0250 + T2X25) + CX= SQRT(D0500 + T) + SX= SIGN( SQRT(D0500 - T),T2X2) + 110 IEAR=IAA+1 + IEBR=IBB+1 +C + DO 230 IR=1,NB1 + T=F(IEAR)*SX + F(IEAR)=F(IEAR)*CX+F(IEBR)*SX + F(IEBR)=T-F(IEBR)*CX + IF(IR-IA) 220,120,130 + 120 TT=F(IEBR) + IEAA=IEAR + IEAB=IEBR + F(IEBR)=BIG(IB) + IEAR=IEAR+IR-1 + IF(JBIG(IR)) 200,220,200 + 130 T=F(IEAR) + IT=IA + IEAR=IEAR+IR-1 + IF(IR-IB) 180,150,160 + 150 F(IEAA)=F(IEAA)*CX+F(IEAB)*SX + F(IEAB)=TT*CX+F(IEBR)*SX + F(IEBR)=TT*SX-F(IEBR)*CX + IEBR=IEBR+IR-1 + GO TO 200 + 160 IF( ABS(T) . GE . ABS(F(IEBR))) GO TO 170 + IF(IB.GT.NMAX) GO TO 170 + T=F(IEBR) + IT=IB + 170 IEBR=IEBR+IR-1 + 180 IF( ABS(T) . LT . ABS(BIG(IR))) GO TO 190 + BIG(IR) = T + JBIG(IR) = IT + GO TO 220 + 190 IF(IA . NE . JBIG(IR) . AND . IB . NE . JBIG(IR)) GO TO 220 + 200 KQ=IEAR-IR-IA+1 + BIG(IR)=ZERO + IR1=MIN(IR-1,NMAX) + DO 210 I=1,IR1 + K=KQ+I + IF(ABS(BIG(IR)) . GE . ABS(F(K))) GO TO 210 + BIG(IR) = F(K) + JBIG(IR)=I + 210 CONTINUE + 220 IEAR=IEAR+1 + 230 IEBR=IEBR+1 +C + DO 240 I=1,NB1 + T1=VEC(I,IA)*CX + VEC(I,IB)*SX + T2=VEC(I,IA)*SX - VEC(I,IB)*CX + VEC(I,IA)=T1 + VEC(I,IB)=T2 + 240 CONTINUE + GO TO 30 +C + 9020 FORMAT(1X,'ITER=',I6,' T,TEST,SD=',1P,3E20.10) + END +C*MODULE EIGEN *DECK JACORD + SUBROUTINE JACORD(VEC,EIG,N,LDVEC) + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + DIMENSION VEC(LDVEC,N),EIG(N) +C +C ---- SORT EIGENDATA INTO ASCENDING ORDER ----- +C + DO 290 I = 1, N + JJ = I + DO 270 J = I, N + IF (EIG(J) .LT. EIG(JJ)) JJ = J + 270 CONTINUE + IF (JJ .EQ. I) GO TO 290 + T = EIG(JJ) + EIG(JJ) = EIG(I) + EIG(I) = T + DO 280 J = 1, N + T = VEC(J,JJ) + VEC(J,JJ) = VEC(J,I) + VEC(J,I) = T + 280 CONTINUE + 290 CONTINUE + RETURN + END +C*MODULE EIGEN *DECK TINVTB + SUBROUTINE TINVTB(NM,N,D,E,E2,M,W,IND,Z, + * IERR,RV1,RV2,RV3,RV4,RV6) + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + DIMENSION D(N),E(N),E2(N),W(M),Z(NM,M), + * RV1(N),RV2(N),RV3(N),RV4(N),RV6(N),IND(M) + DOUBLE PRECISION MACHEP,NORM + INTEGER P,Q,R,S,TAG,GROUP +C ------------------------------------------------------------------ +C +C THIS ROUTINE IS A TRANSLATION OF THE INVERSE ITERATION TECH- +C NIQUE IN THE ALGOL PROCEDURE TRISTURM BY PETERS AND WILKINSON. +C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). +C +C THIS ROUTINE FINDS THOSE EIGENVECTORS OF A TRIDIAGONAL +C SYMMETRIC MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES, +C USING INVERSE ITERATION. +C +C ON INPUT- +C +C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL +C ARRAY PARAMETERS AS DECLARED IN THE CALLING ROUTINE +C DIMENSION STATEMENT, +C +C N IS THE ORDER OF THE MATRIX, +C +C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX, +C +C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX +C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY, +C +C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E, +C WITH ZEROS CORRESPONDING TO NEGLIGIBLE ELEMENTS OF E. +C E(I) IS CONSIDERED NEGLIGIBLE IF IT IS NOT LARGER THAN +C THE PRODUCT OF THE RELATIVE MACHINE PRECISION AND THE SUM +C OF THE MAGNITUDES OF D(I) AND D(I-1). E2(1) MUST CONTAIN +C 0.0 IF THE EIGENVALUES ARE IN ASCENDING ORDER, OR 2.0 +C IF THE EIGENVALUES ARE IN DESCENDING ORDER. IF BISECT, +C TRIDIB, OR IMTQLV HAS BEEN USED TO FIND THE EIGENVALUES, +C THEIR OUTPUT E2 ARRAY IS EXACTLY WHAT IS EXPECTED HERE, +C +C M IS THE NUMBER OF SPECIFIED EIGENVALUES, +C +C W CONTAINS THE M EIGENVALUES IN ASCENDING OR DESCENDING ORDER, +C +C IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES +C ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W -- +C 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM +C THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC. +C +C ON OUTPUT- +C +C ALL INPUT ARRAYS ARE UNALTERED, +C +C Z CONTAINS THE ASSOCIATED SET OF ORTHONORMAL EIGENVECTORS. +C ANY VECTOR WHICH FAILS TO CONVERGE IS SET TO ZERO, +C +C IERR IS SET TO +C ZERO FOR NORMAL RETURN, +C -R IF THE EIGENVECTOR CORRESPONDING TO THE R-TH +C EIGENVALUE FAILS TO CONVERGE IN 5 ITERATIONS, +C +C RV1, RV2, RV3, RV4, AND RV6 ARE TEMPORARY STORAGE ARRAYS. +C +C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW, +C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY +C +C ------------------------------------------------------------------ +C +C ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING +C THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC. +C +C ********** + MACHEP = 2.0D+00**(-50) +C + IERR = 0 + IF (M .EQ. 0) GO TO 680 + TAG = 0 + ORDER = 1.0D+00 - E2(1) + XU = 0.0D+00 + UK = 0.0D+00 + X0 = 0.0D+00 + U = 0.0D+00 + EPS2 = 0.0D+00 + EPS3 = 0.0D+00 + EPS4 = 0.0D+00 + GROUP = 0 + Q = 0 +C ********** ESTABLISH AND PROCESS NEXT SUBMATRIX ********** + 100 P = Q + 1 + IP = P + 1 +C + DO 120 Q = P, N + IF (Q .EQ. N) GO TO 140 + IF (E2(Q+1) .EQ. 0.0D+00) GO TO 140 + 120 CONTINUE +C ********** FIND VECTORS BY INVERSE ITERATION ********** + 140 TAG = TAG + 1 + IQMP = Q - P + 1 + S = 0 +C + DO 660 R = 1, M + IF (IND(R) .NE. TAG) GO TO 660 + ITS = 1 + X1 = W(R) + IF (S .NE. 0) GO TO 220 +C ********** CHECK FOR ISOLATED ROOT ********** + XU = 1.0D+00 + IF (P .NE. Q) GO TO 160 + RV6(P) = 1.0D+00 + GO TO 600 + 160 NORM = ABS(D(P)) +C + DO 180 I = IP, Q + 180 NORM = NORM + ABS(D(I)) + ABS(E(I)) +C ********** EPS2 IS THE CRITERION FOR GROUPING, +C EPS3 REPLACES ZERO PIVOTS AND EQUAL +C ROOTS ARE MODIFIED BY EPS3, +C EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW ********** + EPS2 = 1.0D-03 * NORM + EPS3 = MACHEP * NORM + UK = IQMP + EPS4 = UK * EPS3 + UK = EPS4 / SQRT(UK) + S = P + 200 GROUP = 0 + GO TO 240 +C ********** LOOK FOR CLOSE OR COINCIDENT ROOTS ********** + 220 IF (ABS(X1-X0) .GE. EPS2) GO TO 200 + GROUP = GROUP + 1 + IF (ORDER * (X1 - X0) .LE. 0.0D+00) X1 = X0 + ORDER * EPS3 +C ********** ELIMINATION WITH INTERCHANGES AND +C INITIALIZATION OF VECTOR ********** + 240 V = 0.0D+00 +C + DO 300 I = P, Q + RV6(I) = UK + IF (I .EQ. P) GO TO 280 + IF (ABS(E(I)) .LT. ABS(U)) GO TO 260 +C ********** WARNING -- A DIVIDE CHECK MAY OCCUR HERE IF +C E2 ARRAY HAS NOT BEEN SPECIFIED CORRECTLY ********** + XU = U / E(I) + RV4(I) = XU + RV1(I-1) = E(I) + RV2(I-1) = D(I) - X1 + RV3(I-1) = 0.0D+00 + IF (I .NE. Q) RV3(I-1) = E(I+1) + U = V - XU * RV2(I-1) + V = -XU * RV3(I-1) + GO TO 300 + 260 XU = E(I) / U + RV4(I) = XU + RV1(I-1) = U + RV2(I-1) = V + RV3(I-1) = 0.0D+00 + 280 U = D(I) - X1 - XU * V + IF (I .NE. Q) V = E(I+1) + 300 CONTINUE +C + IF (U .EQ. 0.0D+00) U = EPS3 + RV1(Q) = U + RV2(Q) = 0.0D+00 + RV3(Q) = 0.0D+00 +C ********** BACK SUBSTITUTION +C FOR I=Q STEP -1 UNTIL P DO -- ********** + 320 DO 340 II = P, Q + I = P + Q - II + RV6(I) = (RV6(I) - U * RV2(I) - V * RV3(I)) / RV1(I) + V = U + U = RV6(I) + 340 CONTINUE +C ********** ORTHOGONALIZE WITH RESPECT TO PREVIOUS +C MEMBERS OF GROUP ********** + IF (GROUP .EQ. 0) GO TO 400 + J = R +C + DO 380 JJ = 1, GROUP + 360 J = J - 1 + IF (IND(J) .NE. TAG) GO TO 360 + XU = DDOT(IQMP,RV6(P),1,Z(P,J),1) +C + CALL DAXPY(IQMP,-XU,Z(P,J),1,RV6(P),1) +C + 380 CONTINUE +C + 400 NORM = 0.0D+00 +C + DO 420 I = P, Q + 420 NORM = NORM + ABS(RV6(I)) +C + IF (NORM .GE. 1.0D+00) GO TO 560 +C ********** FORWARD SUBSTITUTION ********** + IF (ITS .EQ. 5) GO TO 540 + IF (NORM .NE. 0.0D+00) GO TO 440 + RV6(S) = EPS4 + S = S + 1 + IF (S .GT. Q) S = P + GO TO 480 + 440 XU = EPS4 / NORM +C + DO 460 I = P, Q + 460 RV6(I) = RV6(I) * XU +C ********** ELIMINATION OPERATIONS ON NEXT VECTOR +C ITERATE ********** + 480 DO 520 I = IP, Q + U = RV6(I) +C ********** IF RV1(I-1) .EQ. E(I), A ROW INTERCHANGE +C WAS PERFORMED EARLIER IN THE +C TRIANGULARIZATION PROCESS ********** + IF (RV1(I-1) .NE. E(I)) GO TO 500 + U = RV6(I-1) + RV6(I-1) = RV6(I) + 500 RV6(I) = U - RV4(I) * RV6(I-1) + 520 CONTINUE +C + ITS = ITS + 1 + GO TO 320 +C ********** SET ERROR -- NON-CONVERGED EIGENVECTOR ********** + 540 IERR = -R + XU = 0.0D+00 + GO TO 600 +C ********** NORMALIZE SO THAT SUM OF SQUARES IS +C 1 AND EXPAND TO FULL ORDER ********** + 560 U = 0.0D+00 +C + DO 580 I = P, Q + RV6(I) = RV6(I) / NORM + 580 U = U + RV6(I)**2 +C + XU = 1.0D+00 / SQRT(U) +C + 600 DO 620 I = 1, N + 620 Z(I,R) = 0.0D+00 +C + DO 640 I = P, Q + 640 Z(I,R) = RV6(I) * XU +C + X0 = X1 + 660 CONTINUE +C + IF (Q .LT. N) GO TO 100 + 680 RETURN +C ********** LAST CARD OF TINVIT ********** + END +C*MODULE EIGEN *DECK TQL2 +C +C ------------------------------------------------------------------ +C + SUBROUTINE TQL2(NM,N,D,E,Z,IERR) + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + DOUBLE PRECISION MACHEP + DIMENSION D(N),E(N),Z(NM,N) +C +C THIS ROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQL2, +C NUM. MATH. 11, 293-306(1968) BY BOWDLER, MARTIN, REINSCH, AND +C WILKINSON. +C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971). +C +C THIS ROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS +C OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE QL METHOD. +C THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO +C BE FOUND IF TRED2 HAS BEEN USED TO REDUCE THIS +C FULL MATRIX TO TRIDIAGONAL FORM. +C +C ON INPUT- +C +C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL +C ARRAY PARAMETERS AS DECLARED IN THE CALLING ROUTINE +C DIMENSION STATEMENT, +C +C N IS THE ORDER OF THE MATRIX, +C +C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX, +C +C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX +C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY, +C +C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE +C REDUCTION BY TRED2, IF PERFORMED. IF THE EIGENVECTORS +C OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN +C THE IDENTITY MATRIX. +C +C ON OUTPUT- +C +C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN +C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT +C UNORDERED FOR INDICES 1,2,...,IERR-1, +C +C E HAS BEEN DESTROYED, +C +C Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC +C TRIDIAGONAL (OR FULL) MATRIX. IF AN ERROR EXIT IS MADE, +C Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED +C EIGENVALUES, +C +C IERR IS SET TO +C ZERO FOR NORMAL RETURN, +C J IF THE J-TH EIGENVALUE HAS NOT BEEN +C DETERMINED AFTER 30 ITERATIONS. +C +C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW, +C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY +C +C ------------------------------------------------------------------ +C +C ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING +C THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC. +C +C ********** + MACHEP = 2.0D+00**(-50) +C + IERR = 0 + IF (N .EQ. 1) GO TO 400 +C + DO 100 I = 2, N + 100 E(I-1) = E(I) +C + F = 0.0D+00 + B = 0.0D+00 + E(N) = 0.0D+00 +C + DO 300 L = 1, N + J = 0 + H = MACHEP * (ABS(D(L)) + ABS(E(L))) + IF (B .LT. H) B = H +C ********** LOOK FOR SMALL SUB-DIAGONAL ELEMENT ********** + DO 120 M = L, N + IF (ABS(E(M)) .LE. B) GO TO 140 +C ********** E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT +C THROUGH THE BOTTOM OF THE LOOP ********** + 120 CONTINUE +C + 140 IF (M .EQ. L) GO TO 280 + 160 IF (J .EQ. 30) GO TO 380 + J = J + 1 +C ********** FORM SHIFT ********** + L1 = L + 1 + G = D(L) + P = (D(L1) - G) / (2.0D+00 * E(L)) + R = SQRT(P*P+1.0D+00) + D(L) = E(L) / (P + SIGN(R,P)) + H = G - D(L) +C + DO 180 I = L1, N + 180 D(I) = D(I) - H +C + F = F + H +C ********** QL TRANSFORMATION ********** + P = D(M) + C = 1.0D+00 + S = 0.0D+00 + MML = M - L +C ********** FOR I=M-1 STEP -1 UNTIL L DO -- ********** + DO 260 II = 1, MML + I = M - II + G = C * E(I) + H = C * P + IF (ABS(P) .LT. ABS(E(I))) GO TO 200 + C = E(I) / P + R = SQRT(C*C+1.0D+00) + E(I+1) = S * P * R + S = C / R + C = 1.0D+00 / R + GO TO 220 + 200 C = P / E(I) + R = SQRT(C*C+1.0D+00) + E(I+1) = S * E(I) * R + S = 1.0D+00 / R + C = C * S + 220 P = C * D(I) - S * G + D(I+1) = H + S * (C * G + S * D(I)) +C ********** FORM VECTOR ********** + CALL DROT(N,Z(1,I+1),1,Z(1,I),1,C,S) +C + 260 CONTINUE +C + E(L) = S * P + D(L) = C * P + IF (ABS(E(L)) .GT. B) GO TO 160 + 280 D(L) = D(L) + F + 300 CONTINUE +C ********** ORDER EIGENVALUES AND EIGENVECTORS ********** + DO 360 II = 2, N + I = II - 1 + K = I + P = D(I) +C + DO 320 J = II, N + IF (D(J) .GE. P) GO TO 320 + K = J + P = D(J) + 320 CONTINUE +C + IF (K .EQ. I) GO TO 360 + D(K) = D(I) + D(I) = P +C + CALL DSWAP(N,Z(1,I),1,Z(1,K),1) +C + 360 CONTINUE +C + GO TO 400 +C ********** SET ERROR -- NO CONVERGENCE TO AN +C EIGENVALUE AFTER 30 ITERATIONS ********** + 380 IERR = L + 400 RETURN +C ********** LAST CARD OF TQL2 ********** + END +C*MODULE EIGEN *DECK TRBK3B +C +C ------------------------------------------------------------------ +C + SUBROUTINE TRBK3B(NM,N,NV,A,M,Z) + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + DIMENSION A(NV),Z(NM,M) +C +C THIS ROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRBAK3, +C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. +C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). +C +C THIS ROUTINE FORMS THE EIGENVECTORS OF A REAL SYMMETRIC +C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING +C SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY TRED3B. +C +C ON INPUT- +C +C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL +C ARRAY PARAMETERS AS DECLARED IN THE CALLING ROUTINE +C DIMENSION STATEMENT, +C +C N IS THE ORDER OF THE MATRIX, +C +C NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A +C AS DECLARED IN THE CALLING ROUTINE DIMENSION STATEMENT, +C +C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANSFORMATIONS +C USED IN THE REDUCTION BY TRED3B IN ITS FIRST +C N*(N+1)/2 POSITIONS, +C +C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED, +C +C Z CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED +C IN ITS FIRST M COLUMNS. +C +C ON OUTPUT- +C +C Z CONTAINS THE TRANSFORMED EIGENVECTORS +C IN ITS FIRST M COLUMNS. +C +C NOTE THAT TRBAK3 PRESERVES VECTOR EUCLIDEAN NORMS. +C +C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW, +C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY +C +C ------------------------------------------------------------------ +C + IF (M .EQ. 0) GO TO 140 + IF (N .EQ. 1) GO TO 140 +C + DO 120 I = 2, N + L = I - 1 + IZ = (I * L) / 2 + IK = IZ + I + H = A(IK) + IF (H .EQ. 0.0D+00) GO TO 120 +C + DO 100 J = 1, M + S = -DDOT(L,A(IZ+1),1,Z(1,J),1) +C +C ********** DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ********** + S = (S / H) / H +C + CALL DAXPY(L,S,A(IZ+1),1,Z(1,J),1) +C + 100 CONTINUE +C + 120 CONTINUE +C + 140 RETURN +C ********** LAST CARD OF TRBAK3 ********** + END +C*MODULE EIGEN *DECK TRED3B +C +C ------------------------------------------------------------------ +C + SUBROUTINE TRED3B(N,NV,A,D,E,E2) + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + DIMENSION A(NV),D(N),E(N),E2(N) +C +C THIS ROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED3, +C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. +C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). +C +C THIS ROUTINE REDUCES A REAL SYMMETRIC MATRIX, STORED AS +C A ONE-DIMENSIONAL ARRAY, TO A SYMMETRIC TRIDIAGONAL MATRIX +C USING ORTHOGONAL SIMILARITY TRANSFORMATIONS. +C +C ON INPUT- +C +C N IS THE ORDER OF THE MATRIX, +C +C NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A +C AS DECLARED IN THE CALLING ROUTINE DIMENSION STATEMENT, +C +C A CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC +C INPUT MATRIX, STORED ROW-WISE AS A ONE-DIMENSIONAL +C ARRAY, IN ITS FIRST N*(N+1)/2 POSITIONS. +C +C ON OUTPUT- +C +C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL +C TRANSFORMATIONS USED IN THE REDUCTION, +C +C D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX, +C +C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL +C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO, +C +C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. +C E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. +C +C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW, +C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY +C +C ------------------------------------------------------------------ +C +C ********** FOR I=N STEP -1 UNTIL 1 DO -- ********** + DO 300 II = 1, N + I = N + 1 - II + L = I - 1 + IZ = (I * L) / 2 + H = 0.0D+00 + SCALE = 0.0D+00 + IF (L .LT. 1) GO TO 120 +C ********** SCALE ROW (ALGOL TOL THEN NOT NEEDED) ********** + DO 100 K = 1, L + IZ = IZ + 1 + D(K) = A(IZ) + SCALE = SCALE + ABS(D(K)) + 100 CONTINUE +C + IF (SCALE .NE. 0.0D+00) GO TO 140 + 120 E(I) = 0.0D+00 + E2(I) = 0.0D+00 + GO TO 280 +C + 140 DO 160 K = 1, L + D(K) = D(K) / SCALE + H = H + D(K) * D(K) + 160 CONTINUE +C + E2(I) = SCALE * SCALE * H + F = D(L) + G = -SIGN(SQRT(H),F) + E(I) = SCALE * G + H = H - F * G + D(L) = F - G + A(IZ) = SCALE * D(L) + IF (L .EQ. 1) GO TO 280 + F = 0.0D+00 +C + JK = 1 + DO 220 J = 1, L + JM1 = J - 1 + DT = D(J) + G = 0.0D+00 +C ********** FORM ELEMENT OF A*U ********** + IF (JM1 .EQ. 0) GO TO 200 + DO 180 K = 1, JM1 + E(K) = E(K) + DT * A(JK) + G = G + D(K) * A(JK) + JK = JK + 1 + 180 CONTINUE + 200 E(J) = G + A(JK) * DT + JK = JK + 1 +C ********** FORM ELEMENT OF P ********** + 220 CONTINUE + F = 0.0D+00 + DO 240 J = 1, L + E(J) = E(J) / H + F = F + E(J) * D(J) + 240 CONTINUE +C + HH = F / (H + H) + JK = 0 +C ********** FORM REDUCED A ********** + DO 260 J = 1, L + F = D(J) + G = E(J) - HH * F + E(J) = G +C + DO 260 K = 1, J + JK = JK + 1 + A(JK) = A(JK) - F * E(K) - G * D(K) + 260 CONTINUE +C + 280 D(I) = A(IZ+1) + A(IZ+1) = SCALE * SQRT(H) + 300 CONTINUE +C + RETURN +C ********** LAST CARD OF TRED3 ********** + END diff --git a/source/unres/src_MD-DFA-restraints/elecont.f b/source/unres/src_MD-DFA-restraints/elecont.f new file mode 100644 index 0000000..e9ed067 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/energy_p_new-sep_barrier.F b/source/unres/src_MD-DFA-restraints/energy_p_new-sep_barrier.F new file mode 100644 index 0000000..c89aee2 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/energy_p_new-sep_barrier.F @@ -0,0 +1,2322 @@ +C----------------------------------------------------------------------- + double precision function sscale(r) + double precision r,gamm + include "COMMON.SPLITELE" + if(r.lt.r_cut-rlamb) then + sscale=1.0d0 + else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then + gamm=(r-(r_cut-rlamb))/rlamb + sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0) + else + sscale=0d0 + endif + return + end +C----------------------------------------------------------------------- + subroutine elj_long(evdw) +C +C This subroutine calculates the interaction energy of nonbonded side chains +C assuming the LJ potential of interaction. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + parameter (accur=1.0d-10) + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.TORSION' + include 'COMMON.SBRIDGE' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.CONTACTS' + dimension gg(3) +c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon + evdw=0.0D0 + do i=iatsc_s,iatsc_e + itypi=itype(i) + itypi1=itype(i+1) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) +C +C Calculate SC interaction energy. +C + do iint=1,nint_gr(i) +cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), +cd & 'iend=',iend(i,iint) + do j=istart(i,iint),iend(i,iint) + itypj=itype(j) + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi + rij=xj*xj+yj*yj+zj*zj + sss=sscale(dsqrt(rij)/sigma(itypi,itypj)) + if (sss.lt.1.0d0) then + rrij=1.0D0/rij + eps0ij=eps(itypi,itypj) + fac=rrij**expon2 + e1=fac*fac*aa(itypi,itypj) + e2=fac*bb(itypi,itypj) + evdwij=e1+e2 + evdw=evdw+(1.0d0-sss)*evdwij +C +C Calculate the components of the gradient in DC and X +C + fac=-rrij*(e1+evdwij)*(1.0d0-sss) + gg(1)=xj*fac + gg(2)=yj*fac + gg(3)=zj*fac + do k=1,3 + gvdwx(k,i)=gvdwx(k,i)-gg(k) + gvdwx(k,j)=gvdwx(k,j)+gg(k) + gvdwc(k,i)=gvdwc(k,i)-gg(k) + gvdwc(k,j)=gvdwc(k,j)+gg(k) + enddo + endif + enddo ! j + enddo ! iint + enddo ! i + do i=1,nct + do j=1,3 + gvdwc(j,i)=expon*gvdwc(j,i) + gvdwx(j,i)=expon*gvdwx(j,i) + enddo + enddo +C****************************************************************************** +C +C N O T E !!! +C +C To save time, the factor of EXPON has been extracted from ALL components +C of GVDWC and GRADX. Remember to multiply them by this factor before further +C use! +C +C****************************************************************************** + return + end +C----------------------------------------------------------------------- + subroutine elj_short(evdw) +C +C This subroutine calculates the interaction energy of nonbonded side chains +C assuming the LJ potential of interaction. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + parameter (accur=1.0d-10) + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.TORSION' + include 'COMMON.SBRIDGE' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.CONTACTS' + dimension gg(3) +c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon + evdw=0.0D0 + do i=iatsc_s,iatsc_e + itypi=itype(i) + itypi1=itype(i+1) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) +C Change 12/1/95 + num_conti=0 +C +C Calculate SC interaction energy. +C + do iint=1,nint_gr(i) +cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), +cd & 'iend=',iend(i,iint) + do j=istart(i,iint),iend(i,iint) + itypj=itype(j) + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi +C Change 12/1/95 to calculate four-body interactions + rij=xj*xj+yj*yj+zj*zj + sss=sscale(dsqrt(rij)/sigma(itypi,itypj)) + if (sss.gt.0.0d0) then + rrij=1.0D0/rij + eps0ij=eps(itypi,itypj) + fac=rrij**expon2 + e1=fac*fac*aa(itypi,itypj) + e2=fac*bb(itypi,itypj) + evdwij=e1+e2 + evdw=evdw+sss*evdwij +C +C Calculate the components of the gradient in DC and X +C + fac=-rrij*(e1+evdwij)*sss + gg(1)=xj*fac + gg(2)=yj*fac + gg(3)=zj*fac + do k=1,3 + gvdwx(k,i)=gvdwx(k,i)-gg(k) + gvdwx(k,j)=gvdwx(k,j)+gg(k) + gvdwc(k,i)=gvdwc(k,i)-gg(k) + gvdwc(k,j)=gvdwc(k,j)+gg(k) + enddo + endif + enddo ! j + enddo ! iint + enddo ! i + do i=1,nct + do j=1,3 + gvdwc(j,i)=expon*gvdwc(j,i) + gvdwx(j,i)=expon*gvdwx(j,i) + enddo + enddo +C****************************************************************************** +C +C N O T E !!! +C +C To save time, the factor of EXPON has been extracted from ALL components +C of GVDWC and GRADX. Remember to multiply them by this factor before further +C use! +C +C****************************************************************************** + return + end +C----------------------------------------------------------------------------- + subroutine eljk_long(evdw) +C +C This subroutine calculates the interaction energy of nonbonded side chains +C assuming the LJK potential of interaction. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + dimension gg(3) + logical scheck +c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon + evdw=0.0D0 + do i=iatsc_s,iatsc_e + itypi=itype(i) + itypi1=itype(i+1) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) +C +C Calculate SC interaction energy. +C + do iint=1,nint_gr(i) + do j=istart(i,iint),iend(i,iint) + itypj=itype(j) + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + fac_augm=rrij**expon + e_augm=augm(itypi,itypj)*fac_augm + r_inv_ij=dsqrt(rrij) + rij=1.0D0/r_inv_ij + sss=sscale(rij/sigma(itypi,itypj)) + if (sss.lt.1.0d0) then + r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj)) + fac=r_shift_inv**expon + e1=fac*fac*aa(itypi,itypj) + e2=fac*bb(itypi,itypj) + evdwij=e_augm+e1+e2 +cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) +cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj) +cd write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)') +cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), +cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm, +cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij, +cd & (c(k,i),k=1,3),(c(k,j),k=1,3) + evdw=evdw+(1.0d0-sss)*evdwij +C +C Calculate the components of the gradient in DC and X +C + fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2) + fac=fac*(1.0d0-sss) + gg(1)=xj*fac + gg(2)=yj*fac + gg(3)=zj*fac + do k=1,3 + gvdwx(k,i)=gvdwx(k,i)-gg(k) + gvdwx(k,j)=gvdwx(k,j)+gg(k) + gvdwc(k,i)=gvdwc(k,i)-gg(k) + gvdwc(k,j)=gvdwc(k,j)+gg(k) + enddo + endif + enddo ! j + enddo ! iint + enddo ! i + do i=1,nct + do j=1,3 + gvdwc(j,i)=expon*gvdwc(j,i) + gvdwx(j,i)=expon*gvdwx(j,i) + enddo + enddo + return + end +C----------------------------------------------------------------------------- + subroutine eljk_short(evdw) +C +C This subroutine calculates the interaction energy of nonbonded side chains +C assuming the LJK potential of interaction. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + dimension gg(3) + logical scheck +c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon + evdw=0.0D0 + do i=iatsc_s,iatsc_e + itypi=itype(i) + itypi1=itype(i+1) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) +C +C Calculate SC interaction energy. +C + do iint=1,nint_gr(i) + do j=istart(i,iint),iend(i,iint) + itypj=itype(j) + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + fac_augm=rrij**expon + e_augm=augm(itypi,itypj)*fac_augm + r_inv_ij=dsqrt(rrij) + rij=1.0D0/r_inv_ij + sss=sscale(rij/sigma(itypi,itypj)) + if (sss.gt.0.0d0) then + r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj)) + fac=r_shift_inv**expon + e1=fac*fac*aa(itypi,itypj) + e2=fac*bb(itypi,itypj) + evdwij=e_augm+e1+e2 +cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) +cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj) +cd write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)') +cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), +cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm, +cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij, +cd & (c(k,i),k=1,3),(c(k,j),k=1,3) + evdw=evdw+sss*evdwij +C +C Calculate the components of the gradient in DC and X +C + fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2) + fac=fac*sss + gg(1)=xj*fac + gg(2)=yj*fac + gg(3)=zj*fac + do k=1,3 + gvdwx(k,i)=gvdwx(k,i)-gg(k) + gvdwx(k,j)=gvdwx(k,j)+gg(k) + gvdwc(k,i)=gvdwc(k,i)-gg(k) + gvdwc(k,j)=gvdwc(k,j)+gg(k) + enddo + endif + enddo ! j + enddo ! iint + enddo ! i + do i=1,nct + do j=1,3 + gvdwc(j,i)=expon*gvdwc(j,i) + gvdwx(j,i)=expon*gvdwx(j,i) + enddo + enddo + return + end +C----------------------------------------------------------------------------- + subroutine ebp_long(evdw) +C +C This subroutine calculates the interaction energy of nonbonded side chains +C assuming the Berne-Pechukas potential of interaction. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.NAMES' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.CALC' + common /srutu/ icall +c double precision rrsave(maxdim) + logical lprn + evdw=0.0D0 +c print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon + evdw=0.0D0 +c if (icall.eq.0) then +c lprn=.true. +c else + lprn=.false. +c endif + ind=0 + do i=iatsc_s,iatsc_e + itypi=itype(i) + itypi1=itype(i+1) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) + dxi=dc_norm(1,nres+i) + dyi=dc_norm(2,nres+i) + dzi=dc_norm(3,nres+i) +c dsci_inv=dsc_inv(itypi) + dsci_inv=vbld_inv(i+nres) +C +C Calculate SC interaction energy. +C + do iint=1,nint_gr(i) + do j=istart(i,iint),iend(i,iint) + ind=ind+1 + itypj=itype(j) +c dscj_inv=dsc_inv(itypj) + dscj_inv=vbld_inv(j+nres) + chi1=chi(itypi,itypj) + chi2=chi(itypj,itypi) + chi12=chi1*chi2 + chip1=chip(itypi) + chip2=chip(itypj) + chip12=chip1*chip2 + alf1=alp(itypi) + alf2=alp(itypj) + alf12=0.5D0*(alf1+alf2) + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + rij=dsqrt(rrij) + sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) + + if (sss.lt.1.0d0) then + +C Calculate the angle-dependent terms of energy & contributions to derivatives. + call sc_angular +C Calculate whole angle-dependent part of epsilon and contributions +C to its derivatives + fac=(rrij*sigsq)**expon2 + e1=fac*fac*aa(itypi,itypj) + e2=fac*bb(itypi,itypj) + evdwij=eps1*eps2rt*eps3rt*(e1+e2) + eps2der=evdwij*eps3rt + eps3der=evdwij*eps2rt + evdwij=evdwij*eps2rt*eps3rt + evdw=evdw+evdwij*(1.0d0-sss) + if (lprn) then + sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) + epsi=bb(itypi,itypj)**2/aa(itypi,itypj) +cd write (iout,'(2(a3,i3,2x),15(0pf7.3))') +cd & restyp(itypi),i,restyp(itypj),j, +cd & epsi,sigm,chi1,chi2,chip1,chip2, +cd & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq), +cd & om1,om2,om12,1.0D0/dsqrt(rrij), +cd & evdwij + endif +C Calculate gradient components. + e1=e1*eps1*eps2rt**2*eps3rt**2 + fac=-expon*(e1+evdwij) + sigder=fac/sigsq + fac=rrij*fac +C Calculate radial part of the gradient + gg(1)=xj*fac + gg(2)=yj*fac + gg(3)=zj*fac +C Calculate the angular part of the gradient and sum add the contributions +C to the appropriate components of the Cartesian gradient. + call sc_grad_scale(1.0d0-sss) + endif + enddo ! j + enddo ! iint + enddo ! i +c stop + return + end +C----------------------------------------------------------------------------- + subroutine ebp_short(evdw) +C +C This subroutine calculates the interaction energy of nonbonded side chains +C assuming the Berne-Pechukas potential of interaction. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.NAMES' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.CALC' + common /srutu/ icall +c double precision rrsave(maxdim) + logical lprn + evdw=0.0D0 +c print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon + evdw=0.0D0 +c if (icall.eq.0) then +c lprn=.true. +c else + lprn=.false. +c endif + ind=0 + do i=iatsc_s,iatsc_e + itypi=itype(i) + itypi1=itype(i+1) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) + dxi=dc_norm(1,nres+i) + dyi=dc_norm(2,nres+i) + dzi=dc_norm(3,nres+i) +c dsci_inv=dsc_inv(itypi) + dsci_inv=vbld_inv(i+nres) +C +C Calculate SC interaction energy. +C + do iint=1,nint_gr(i) + do j=istart(i,iint),iend(i,iint) + ind=ind+1 + itypj=itype(j) +c dscj_inv=dsc_inv(itypj) + dscj_inv=vbld_inv(j+nres) + chi1=chi(itypi,itypj) + chi2=chi(itypj,itypi) + chi12=chi1*chi2 + chip1=chip(itypi) + chip2=chip(itypj) + chip12=chip1*chip2 + alf1=alp(itypi) + alf2=alp(itypj) + alf12=0.5D0*(alf1+alf2) + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + rij=dsqrt(rrij) + sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) + + if (sss.gt.0.0d0) then + +C Calculate the angle-dependent terms of energy & contributions to derivatives. + call sc_angular +C Calculate whole angle-dependent part of epsilon and contributions +C to its derivatives + fac=(rrij*sigsq)**expon2 + e1=fac*fac*aa(itypi,itypj) + e2=fac*bb(itypi,itypj) + evdwij=eps1*eps2rt*eps3rt*(e1+e2) + eps2der=evdwij*eps3rt + eps3der=evdwij*eps2rt + evdwij=evdwij*eps2rt*eps3rt + evdw=evdw+evdwij*sss + if (lprn) then + sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) + epsi=bb(itypi,itypj)**2/aa(itypi,itypj) +cd write (iout,'(2(a3,i3,2x),15(0pf7.3))') +cd & restyp(itypi),i,restyp(itypj),j, +cd & epsi,sigm,chi1,chi2,chip1,chip2, +cd & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq), +cd & om1,om2,om12,1.0D0/dsqrt(rrij), +cd & evdwij + endif +C Calculate gradient components. + e1=e1*eps1*eps2rt**2*eps3rt**2 + fac=-expon*(e1+evdwij) + sigder=fac/sigsq + fac=rrij*fac +C Calculate radial part of the gradient + gg(1)=xj*fac + gg(2)=yj*fac + gg(3)=zj*fac +C Calculate the angular part of the gradient and sum add the contributions +C to the appropriate components of the Cartesian gradient. + call sc_grad_scale(sss) + endif + enddo ! j + enddo ! iint + enddo ! i +c stop + return + end +C----------------------------------------------------------------------------- + subroutine egb_long(evdw,evdw_p,evdw_m) +C +C This subroutine calculates the interaction energy of nonbonded side chains +C assuming the Gay-Berne potential of interaction. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.NAMES' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.CALC' + include 'COMMON.CONTROL' + logical lprn +ccccc energy_dec=.false. +c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon + evdw=0.0D0 + evdw_p=0.0D0 + evdw_m=0.0D0 + lprn=.false. +c if (icall.eq.0) lprn=.false. + ind=0 + do i=iatsc_s,iatsc_e + itypi=itype(i) + itypi1=itype(i+1) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) + dxi=dc_norm(1,nres+i) + dyi=dc_norm(2,nres+i) + dzi=dc_norm(3,nres+i) +c dsci_inv=dsc_inv(itypi) + dsci_inv=vbld_inv(i+nres) +c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres) +c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi +C +C Calculate SC interaction energy. +C + do iint=1,nint_gr(i) + do j=istart(i,iint),iend(i,iint) + ind=ind+1 + itypj=itype(j) +c dscj_inv=dsc_inv(itypj) + dscj_inv=vbld_inv(j+nres) +c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv, +c & 1.0d0/vbld(j+nres) +c write (iout,*) "i",i," j", j," itype",itype(i),itype(j) + sig0ij=sigma(itypi,itypj) + chi1=chi(itypi,itypj) + chi2=chi(itypj,itypi) + chi12=chi1*chi2 + chip1=chip(itypi) + chip2=chip(itypj) + chip12=chip1*chip2 + alf1=alp(itypi) + alf2=alp(itypj) + alf12=0.5D0*(alf1+alf2) + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + rij=dsqrt(rrij) + sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) + + if (sss.lt.1.0d0) then + +C Calculate angle-dependent terms of energy and contributions to their +C derivatives. + call sc_angular + sigsq=1.0D0/sigsq + sig=sig0ij*dsqrt(sigsq) + rij_shift=1.0D0/rij-sig+sig0ij +c for diagnostics; uncomment +c rij_shift=1.2*sig0ij +C I hate to put IF's in the loops, but here don't have another choice!!!! + if (rij_shift.le.0.0D0) then + evdw=1.0D20 +cd write (iout,'(2(a3,i3,2x),17(0pf7.3))') +cd & restyp(itypi),i,restyp(itypj),j, +cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq) + return + endif + sigder=-sig*sigsq +c--------------------------------------------------------------- + rij_shift=1.0D0/rij_shift + fac=rij_shift**expon + e1=fac*fac*aa(itypi,itypj) + e2=fac*bb(itypi,itypj) + evdwij=eps1*eps2rt*eps3rt*(e1+e2) + eps2der=evdwij*eps3rt + eps3der=evdwij*eps2rt +c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt, +c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2 + evdwij=evdwij*eps2rt*eps3rt +#ifdef TSCSC + if (bb(itypi,itypj).gt.0) then + evdw_p=evdw_p+evdwij*(1.0d0-sss) + else + evdw_m=evdw_m+evdwij*(1.0d0-sss) + endif +#else + evdw=evdw+evdwij*(1.0d0-sss) +#endif + if (lprn) then + sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) + epsi=bb(itypi,itypj)**2/aa(itypi,itypj) + write (iout,'(2(a3,i3,2x),17(0pf7.3))') + & restyp(itypi),i,restyp(itypj),j, + & epsi,sigm,chi1,chi2,chip1,chip2, + & eps1,eps2rt**2,eps3rt**2,sig,sig0ij, + & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, + & evdwij + endif + + if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') + & 'evdw',i,j,evdwij + +C Calculate gradient components. + e1=e1*eps1*eps2rt**2*eps3rt**2 + fac=-expon*(e1+evdwij)*rij_shift + sigder=fac*sigder + fac=rij*fac +c fac=0.0d0 +C Calculate the radial part of the gradient + gg(1)=xj*fac + gg(2)=yj*fac + gg(3)=zj*fac +C Calculate angular part of the gradient. +#ifdef TSCSC + if (bb(itypi,itypj).gt.0) then + call sc_grad_scale_T(1.0d0-sss) + else + call sc_grad_scale(1.0d0-sss) + endif +#else + call sc_grad_scale(1.0d0-sss) +#endif + endif + enddo ! j + enddo ! iint + enddo ! i +c write (iout,*) "Number of loop steps in EGB:",ind +cccc energy_dec=.false. + return + end +C----------------------------------------------------------------------------- + subroutine egb_short(evdw,evdw_p,evdw_m) +C +C This subroutine calculates the interaction energy of nonbonded side chains +C assuming the Gay-Berne potential of interaction. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.NAMES' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.CALC' + include 'COMMON.CONTROL' + logical lprn + evdw=0.0D0 + evdw_p=0.0D0 + evdw_m=0.0D0 +ccccc energy_dec=.false. +c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon + evdw=0.0D0 + lprn=.false. +c if (icall.eq.0) lprn=.false. + ind=0 + do i=iatsc_s,iatsc_e + itypi=itype(i) + itypi1=itype(i+1) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) + dxi=dc_norm(1,nres+i) + dyi=dc_norm(2,nres+i) + dzi=dc_norm(3,nres+i) +c dsci_inv=dsc_inv(itypi) + dsci_inv=vbld_inv(i+nres) +c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres) +c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi +C +C Calculate SC interaction energy. +C + do iint=1,nint_gr(i) + do j=istart(i,iint),iend(i,iint) + ind=ind+1 + itypj=itype(j) +c dscj_inv=dsc_inv(itypj) + dscj_inv=vbld_inv(j+nres) +c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv, +c & 1.0d0/vbld(j+nres) +c write (iout,*) "i",i," j", j," itype",itype(i),itype(j) + sig0ij=sigma(itypi,itypj) + chi1=chi(itypi,itypj) + chi2=chi(itypj,itypi) + chi12=chi1*chi2 + chip1=chip(itypi) + chip2=chip(itypj) + chip12=chip1*chip2 + alf1=alp(itypi) + alf2=alp(itypj) + alf12=0.5D0*(alf1+alf2) + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + rij=dsqrt(rrij) + sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) + + if (sss.gt.0.0d0) then + +C Calculate angle-dependent terms of energy and contributions to their +C derivatives. + call sc_angular + sigsq=1.0D0/sigsq + sig=sig0ij*dsqrt(sigsq) + rij_shift=1.0D0/rij-sig+sig0ij +c for diagnostics; uncomment +c rij_shift=1.2*sig0ij +C I hate to put IF's in the loops, but here don't have another choice!!!! + if (rij_shift.le.0.0D0) then + evdw=1.0D20 +cd write (iout,'(2(a3,i3,2x),17(0pf7.3))') +cd & restyp(itypi),i,restyp(itypj),j, +cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq) + return + endif + sigder=-sig*sigsq +c--------------------------------------------------------------- + rij_shift=1.0D0/rij_shift + fac=rij_shift**expon + e1=fac*fac*aa(itypi,itypj) + e2=fac*bb(itypi,itypj) + evdwij=eps1*eps2rt*eps3rt*(e1+e2) + eps2der=evdwij*eps3rt + eps3der=evdwij*eps2rt +c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt, +c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2 + evdwij=evdwij*eps2rt*eps3rt +#ifdef TSCSC + if (bb(itypi,itypj).gt.0) then + evdw_p=evdw_p+evdwij*sss + else + evdw_m=evdw_m+evdwij*sss + endif +#else + evdw=evdw+evdwij*sss +#endif + if (lprn) then + sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) + epsi=bb(itypi,itypj)**2/aa(itypi,itypj) + write (iout,'(2(a3,i3,2x),17(0pf7.3))') + & restyp(itypi),i,restyp(itypj),j, + & epsi,sigm,chi1,chi2,chip1,chip2, + & eps1,eps2rt**2,eps3rt**2,sig,sig0ij, + & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, + & evdwij + endif + + if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') + & 'evdw',i,j,evdwij + +C Calculate gradient components. + e1=e1*eps1*eps2rt**2*eps3rt**2 + fac=-expon*(e1+evdwij)*rij_shift + sigder=fac*sigder + fac=rij*fac +c fac=0.0d0 +C Calculate the radial part of the gradient + gg(1)=xj*fac + gg(2)=yj*fac + gg(3)=zj*fac +C Calculate angular part of the gradient. +#ifdef TSCSC + if (bb(itypi,itypj).gt.0) then + call sc_grad_scale_T(sss) + else + call sc_grad_scale(sss) + endif +#else + call sc_grad_scale(sss) +#endif + endif + enddo ! j + enddo ! iint + enddo ! i +c write (iout,*) "Number of loop steps in EGB:",ind +cccc energy_dec=.false. + return + end +C----------------------------------------------------------------------------- + subroutine egbv_long(evdw) +C +C This subroutine calculates the interaction energy of nonbonded side chains +C assuming the Gay-Berne-Vorobjev potential of interaction. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.NAMES' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.CALC' + common /srutu/ icall + logical lprn + evdw=0.0D0 +c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon + evdw=0.0D0 + lprn=.false. +c if (icall.eq.0) lprn=.true. + ind=0 + do i=iatsc_s,iatsc_e + itypi=itype(i) + itypi1=itype(i+1) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) + dxi=dc_norm(1,nres+i) + dyi=dc_norm(2,nres+i) + dzi=dc_norm(3,nres+i) +c dsci_inv=dsc_inv(itypi) + dsci_inv=vbld_inv(i+nres) +C +C Calculate SC interaction energy. +C + do iint=1,nint_gr(i) + do j=istart(i,iint),iend(i,iint) + ind=ind+1 + itypj=itype(j) +c dscj_inv=dsc_inv(itypj) + dscj_inv=vbld_inv(j+nres) + sig0ij=sigma(itypi,itypj) + r0ij=r0(itypi,itypj) + chi1=chi(itypi,itypj) + chi2=chi(itypj,itypi) + chi12=chi1*chi2 + chip1=chip(itypi) + chip2=chip(itypj) + chip12=chip1*chip2 + alf1=alp(itypi) + alf2=alp(itypj) + alf12=0.5D0*(alf1+alf2) + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + rij=dsqrt(rrij) + + sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) + + if (sss.lt.1.0d0) then + +C Calculate angle-dependent terms of energy and contributions to their +C derivatives. + call sc_angular + sigsq=1.0D0/sigsq + sig=sig0ij*dsqrt(sigsq) + rij_shift=1.0D0/rij-sig+r0ij +C I hate to put IF's in the loops, but here don't have another choice!!!! + if (rij_shift.le.0.0D0) then + evdw=1.0D20 + return + endif + sigder=-sig*sigsq +c--------------------------------------------------------------- + rij_shift=1.0D0/rij_shift + fac=rij_shift**expon + e1=fac*fac*aa(itypi,itypj) + e2=fac*bb(itypi,itypj) + evdwij=eps1*eps2rt*eps3rt*(e1+e2) + eps2der=evdwij*eps3rt + eps3der=evdwij*eps2rt + fac_augm=rrij**expon + e_augm=augm(itypi,itypj)*fac_augm + evdwij=evdwij*eps2rt*eps3rt + evdw=evdw+(evdwij+e_augm)*(1.0d0-sss) + if (lprn) then + sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) + epsi=bb(itypi,itypj)**2/aa(itypi,itypj) + write (iout,'(2(a3,i3,2x),17(0pf7.3))') + & restyp(itypi),i,restyp(itypj),j, + & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0), + & chi1,chi2,chip1,chip2, + & eps1,eps2rt**2,eps3rt**2, + & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, + & evdwij+e_augm + endif +C Calculate gradient components. + e1=e1*eps1*eps2rt**2*eps3rt**2 + fac=-expon*(e1+evdwij)*rij_shift + sigder=fac*sigder + fac=rij*fac-2*expon*rrij*e_augm +C Calculate the radial part of the gradient + gg(1)=xj*fac + gg(2)=yj*fac + gg(3)=zj*fac +C Calculate angular part of the gradient. + call sc_grad_scale(1.0d0-sss) + endif + enddo ! j + enddo ! iint + enddo ! i + end +C----------------------------------------------------------------------------- + subroutine egbv_short(evdw) +C +C This subroutine calculates the interaction energy of nonbonded side chains +C assuming the Gay-Berne-Vorobjev potential of interaction. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.NAMES' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.CALC' + common /srutu/ icall + logical lprn + evdw=0.0D0 +c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon + evdw=0.0D0 + lprn=.false. +c if (icall.eq.0) lprn=.true. + ind=0 + do i=iatsc_s,iatsc_e + itypi=itype(i) + itypi1=itype(i+1) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) + dxi=dc_norm(1,nres+i) + dyi=dc_norm(2,nres+i) + dzi=dc_norm(3,nres+i) +c dsci_inv=dsc_inv(itypi) + dsci_inv=vbld_inv(i+nres) +C +C Calculate SC interaction energy. +C + do iint=1,nint_gr(i) + do j=istart(i,iint),iend(i,iint) + ind=ind+1 + itypj=itype(j) +c dscj_inv=dsc_inv(itypj) + dscj_inv=vbld_inv(j+nres) + sig0ij=sigma(itypi,itypj) + r0ij=r0(itypi,itypj) + chi1=chi(itypi,itypj) + chi2=chi(itypj,itypi) + chi12=chi1*chi2 + chip1=chip(itypi) + chip2=chip(itypj) + chip12=chip1*chip2 + alf1=alp(itypi) + alf2=alp(itypj) + alf12=0.5D0*(alf1+alf2) + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + rij=dsqrt(rrij) + + sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) + + if (sss.gt.0.0d0) then + +C Calculate angle-dependent terms of energy and contributions to their +C derivatives. + call sc_angular + sigsq=1.0D0/sigsq + sig=sig0ij*dsqrt(sigsq) + rij_shift=1.0D0/rij-sig+r0ij +C I hate to put IF's in the loops, but here don't have another choice!!!! + if (rij_shift.le.0.0D0) then + evdw=1.0D20 + return + endif + sigder=-sig*sigsq +c--------------------------------------------------------------- + rij_shift=1.0D0/rij_shift + fac=rij_shift**expon + e1=fac*fac*aa(itypi,itypj) + e2=fac*bb(itypi,itypj) + evdwij=eps1*eps2rt*eps3rt*(e1+e2) + eps2der=evdwij*eps3rt + eps3der=evdwij*eps2rt + fac_augm=rrij**expon + e_augm=augm(itypi,itypj)*fac_augm + evdwij=evdwij*eps2rt*eps3rt + evdw=evdw+(evdwij+e_augm)*sss + if (lprn) then + sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) + epsi=bb(itypi,itypj)**2/aa(itypi,itypj) + write (iout,'(2(a3,i3,2x),17(0pf7.3))') + & restyp(itypi),i,restyp(itypj),j, + & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0), + & chi1,chi2,chip1,chip2, + & eps1,eps2rt**2,eps3rt**2, + & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, + & evdwij+e_augm + endif +C Calculate gradient components. + e1=e1*eps1*eps2rt**2*eps3rt**2 + fac=-expon*(e1+evdwij)*rij_shift + sigder=fac*sigder + fac=rij*fac-2*expon*rrij*e_augm +C Calculate the radial part of the gradient + gg(1)=xj*fac + gg(2)=yj*fac + gg(3)=zj*fac +C Calculate angular part of the gradient. + call sc_grad_scale(sss) + endif + enddo ! j + enddo ! iint + enddo ! i + end +C---------------------------------------------------------------------------- + subroutine sc_grad_scale(scalfac) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.CALC' + include 'COMMON.IOUNITS' + double precision dcosom1(3),dcosom2(3) + double precision scalfac + eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 + eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 + eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 + & -2.0D0*alf12*eps3der+sigder*sigsq_om12 +c diagnostics only +c eom1=0.0d0 +c eom2=0.0d0 +c eom12=evdwij*eps1_om12 +c end diagnostics +c write (iout,*) "eps2der",eps2der," eps3der",eps3der, +c & " sigder",sigder +c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12 +c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12 + do k=1,3 + dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) + dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k)) + enddo + do k=1,3 + gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac + enddo +c write (iout,*) "gg",(gg(k),k=1,3) + do k=1,3 + gvdwx(k,i)=gvdwx(k,i)-gg(k) + & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) + & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac + gvdwx(k,j)=gvdwx(k,j)+gg(k) + & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) + & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac +c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) +c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv +c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) +c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv + enddo +C +C Calculate the components of the gradient in DC and X +C + do l=1,3 + gvdwc(l,i)=gvdwc(l,i)-gg(l) + gvdwc(l,j)=gvdwc(l,j)+gg(l) + enddo + return + end +C---------------------------------------------------------------------------- + subroutine sc_grad_scale_T(scalfac) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.CALC' + include 'COMMON.IOUNITS' + double precision dcosom1(3),dcosom2(3) + double precision scalfac + eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 + eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 + eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 + & -2.0D0*alf12*eps3der+sigder*sigsq_om12 +c diagnostics only +c eom1=0.0d0 +c eom2=0.0d0 +c eom12=evdwij*eps1_om12 +c end diagnostics +c write (iout,*) "eps2der",eps2der," eps3der",eps3der, +c & " sigder",sigder +c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12 +c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12 + do k=1,3 + dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) + dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k)) + enddo + do k=1,3 + gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac + enddo +c write (iout,*) "gg",(gg(k),k=1,3) + do k=1,3 + gvdwxT(k,i)=gvdwxT(k,i)-gg(k) + & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) + & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac + gvdwxT(k,j)=gvdwxT(k,j)+gg(k) + & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) + & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac +c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) +c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv +c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) +c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv + enddo +C +C Calculate the components of the gradient in DC and X +C + do l=1,3 + gvdwcT(l,i)=gvdwcT(l,i)-gg(l) + gvdwcT(l,j)=gvdwcT(l,j)+gg(l) + enddo + return + end + +C-------------------------------------------------------------------------- + subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4) +C +C This subroutine calculates the average interaction energy and its gradient +C in the virtual-bond vectors between non-adjacent peptide groups, based on +C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715. +C The potential depends both on the distance of peptide-group centers and on +C the orientation of the CA-CA virtual bonds. +C + implicit real*8 (a-h,o-z) +#ifdef MPI + include 'mpif.h' +#endif + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.SETUP' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VECTORS' + include 'COMMON.FFIELD' + include 'COMMON.TIME1' + dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3), + & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3) + double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4), + & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4) + common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33, + & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi, + & num_conti,j1,j2 +c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions +#ifdef MOMENT + double precision scal_el /1.0d0/ +#else + double precision scal_el /0.5d0/ +#endif +C 12/13/98 +C 13-go grudnia roku pamietnego... + double precision unmat(3,3) /1.0d0,0.0d0,0.0d0, + & 0.0d0,1.0d0,0.0d0, + & 0.0d0,0.0d0,1.0d0/ +cd write(iout,*) 'In EELEC' +cd do i=1,nloctyp +cd write(iout,*) 'Type',i +cd write(iout,*) 'B1',B1(:,i) +cd write(iout,*) 'B2',B2(:,i) +cd write(iout,*) 'CC',CC(:,:,i) +cd write(iout,*) 'DD',DD(:,:,i) +cd write(iout,*) 'EE',EE(:,:,i) +cd enddo +cd call check_vecgrad +cd stop + if (icheckgrad.eq.1) then + do i=1,nres-1 + fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i))) + do k=1,3 + dc_norm(k,i)=dc(k,i)*fac + enddo +c write (iout,*) 'i',i,' fac',fac + enddo + endif + if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 + & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. + & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then +c call vec_and_deriv +#ifdef TIMING + time01=MPI_Wtime() +#endif + call set_matrices +#ifdef TIMING + time_mat=time_mat+MPI_Wtime()-time01 +#endif + endif +cd do i=1,nres-1 +cd write (iout,*) 'i=',i +cd do k=1,3 +cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i) +cd enddo +cd do k=1,3 +cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)') +cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3) +cd enddo +cd enddo + t_eelecij=0.0d0 + ees=0.0D0 + evdw1=0.0D0 + eel_loc=0.0d0 + eello_turn3=0.0d0 + eello_turn4=0.0d0 + ind=0 + do i=1,nres + num_cont_hb(i)=0 + enddo +cd print '(a)','Enter EELEC' +cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e + do i=1,nres + gel_loc_loc(i)=0.0d0 + gcorr_loc(i)=0.0d0 + enddo +c +c +c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms +C +C Loop over i,i+2 and i,i+3 pairs of the peptide groups +C + do i=iturn3_start,iturn3_end + dxi=dc(1,i) + dyi=dc(2,i) + dzi=dc(3,i) + dx_normi=dc_norm(1,i) + dy_normi=dc_norm(2,i) + dz_normi=dc_norm(3,i) + xmedi=c(1,i)+0.5d0*dxi + ymedi=c(2,i)+0.5d0*dyi + zmedi=c(3,i)+0.5d0*dzi + num_conti=0 + call eelecij_scale(i,i+2,ees,evdw1,eel_loc) + if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3) + num_cont_hb(i)=num_conti + enddo + do i=iturn4_start,iturn4_end + dxi=dc(1,i) + dyi=dc(2,i) + dzi=dc(3,i) + dx_normi=dc_norm(1,i) + dy_normi=dc_norm(2,i) + dz_normi=dc_norm(3,i) + xmedi=c(1,i)+0.5d0*dxi + ymedi=c(2,i)+0.5d0*dyi + zmedi=c(3,i)+0.5d0*dzi + num_conti=num_cont_hb(i) + call eelecij_scale(i,i+3,ees,evdw1,eel_loc) + if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4) + num_cont_hb(i)=num_conti + enddo ! i +c +c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3 +c + do i=iatel_s,iatel_e + dxi=dc(1,i) + dyi=dc(2,i) + dzi=dc(3,i) + dx_normi=dc_norm(1,i) + dy_normi=dc_norm(2,i) + dz_normi=dc_norm(3,i) + xmedi=c(1,i)+0.5d0*dxi + ymedi=c(2,i)+0.5d0*dyi + zmedi=c(3,i)+0.5d0*dzi +c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i) + num_conti=num_cont_hb(i) + do j=ielstart(i),ielend(i) + call eelecij_scale(i,j,ees,evdw1,eel_loc) + enddo ! j + num_cont_hb(i)=num_conti + enddo ! i +c write (iout,*) "Number of loop steps in EELEC:",ind +cd do i=1,nres +cd write (iout,'(i3,3f10.5,5x,3f10.5)') +cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i) +cd enddo +c 12/7/99 Adam eello_turn3 will be considered as a separate energy term +ccc eel_loc=eel_loc+eello_turn3 +cd print *,"Processor",fg_rank," t_eelecij",t_eelecij + return + end +C------------------------------------------------------------------------------- + subroutine eelecij_scale(i,j,ees,evdw1,eel_loc) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include "mpif.h" +#endif + include 'COMMON.CONTROL' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VECTORS' + include 'COMMON.FFIELD' + include 'COMMON.TIME1' + dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3), + & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3) + double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4), + & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4) + common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33, + & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi, + & num_conti,j1,j2 +c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions +#ifdef MOMENT + double precision scal_el /1.0d0/ +#else + double precision scal_el /0.5d0/ +#endif +C 12/13/98 +C 13-go grudnia roku pamietnego... + double precision unmat(3,3) /1.0d0,0.0d0,0.0d0, + & 0.0d0,1.0d0,0.0d0, + & 0.0d0,0.0d0,1.0d0/ +c time00=MPI_Wtime() +cd write (iout,*) "eelecij",i,j + ind=ind+1 + iteli=itel(i) + itelj=itel(j) + if (j.eq.i+2 .and. itelj.eq.2) iteli=2 + aaa=app(iteli,itelj) + bbb=bpp(iteli,itelj) + ael6i=ael6(iteli,itelj) + ael3i=ael3(iteli,itelj) + dxj=dc(1,j) + dyj=dc(2,j) + dzj=dc(3,j) + dx_normj=dc_norm(1,j) + dy_normj=dc_norm(2,j) + dz_normj=dc_norm(3,j) + xj=c(1,j)+0.5D0*dxj-xmedi + yj=c(2,j)+0.5D0*dyj-ymedi + zj=c(3,j)+0.5D0*dzj-zmedi + rij=xj*xj+yj*yj+zj*zj + rrmij=1.0D0/rij + rij=dsqrt(rij) + rmij=1.0D0/rij +c For extracting the short-range part of Evdwpp + sss=sscale(rij/rpp(iteli,itelj)) + + r3ij=rrmij*rmij + r6ij=r3ij*r3ij + cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj + cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij + cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij + fac=cosa-3.0D0*cosb*cosg + ev1=aaa*r6ij*r6ij +c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions + if (j.eq.i+2) ev1=scal_el*ev1 + ev2=bbb*r6ij + fac3=ael6i*r6ij + fac4=ael3i*r3ij + evdwij=ev1+ev2 + el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)) + el2=fac4*fac + eesij=el1+el2 +C 12/26/95 - for the evaluation of multi-body H-bonding interactions + ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg) + ees=ees+eesij + evdw1=evdw1+evdwij*(1.0d0-sss) +cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)') +cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i, +cd & 1.0D0/dsqrt(rrmij),evdwij,eesij, +cd & xmedi,ymedi,zmedi,xj,yj,zj + + if (energy_dec) then + write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss + write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij + endif + +C +C Calculate contributions to the Cartesian gradient. +C +#ifdef SPLITELE + facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss) + facel=-3*rrmij*(el1+eesij) + fac1=fac + erij(1)=xj*rmij + erij(2)=yj*rmij + erij(3)=zj*rmij +* +* Radial derivatives. First process both termini of the fragment (i,j) +* + ggg(1)=facel*xj + ggg(2)=facel*yj + ggg(3)=facel*zj +c do k=1,3 +c ghalf=0.5D0*ggg(k) +c gelc(k,i)=gelc(k,i)+ghalf +c gelc(k,j)=gelc(k,j)+ghalf +c enddo +c 9/28/08 AL Gradient compotents will be summed only at the end + do k=1,3 + gelc_long(k,j)=gelc_long(k,j)+ggg(k) + gelc_long(k,i)=gelc_long(k,i)-ggg(k) + enddo +* +* Loop over residues i+1 thru j-1. +* +cgrad do k=i+1,j-1 +cgrad do l=1,3 +cgrad gelc(l,k)=gelc(l,k)+ggg(l) +cgrad enddo +cgrad enddo + ggg(1)=facvdw*xj + ggg(2)=facvdw*yj + ggg(3)=facvdw*zj +c do k=1,3 +c ghalf=0.5D0*ggg(k) +c gvdwpp(k,i)=gvdwpp(k,i)+ghalf +c gvdwpp(k,j)=gvdwpp(k,j)+ghalf +c enddo +c 9/28/08 AL Gradient compotents will be summed only at the end + do k=1,3 + gvdwpp(k,j)=gvdwpp(k,j)+ggg(k) + gvdwpp(k,i)=gvdwpp(k,i)-ggg(k) + enddo +* +* Loop over residues i+1 thru j-1. +* +cgrad do k=i+1,j-1 +cgrad do l=1,3 +cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l) +cgrad enddo +cgrad enddo +#else + facvdw=ev1+evdwij*(1.0d0-sss) + facel=el1+eesij + fac1=fac + fac=-3*rrmij*(facvdw+facvdw+facel) + erij(1)=xj*rmij + erij(2)=yj*rmij + erij(3)=zj*rmij +* +* Radial derivatives. First process both termini of the fragment (i,j) +* + ggg(1)=fac*xj + ggg(2)=fac*yj + ggg(3)=fac*zj +c do k=1,3 +c ghalf=0.5D0*ggg(k) +c gelc(k,i)=gelc(k,i)+ghalf +c gelc(k,j)=gelc(k,j)+ghalf +c enddo +c 9/28/08 AL Gradient compotents will be summed only at the end + do k=1,3 + gelc_long(k,j)=gelc(k,j)+ggg(k) + gelc_long(k,i)=gelc(k,i)-ggg(k) + enddo +* +* Loop over residues i+1 thru j-1. +* +cgrad do k=i+1,j-1 +cgrad do l=1,3 +cgrad gelc(l,k)=gelc(l,k)+ggg(l) +cgrad enddo +cgrad enddo +c 9/28/08 AL Gradient compotents will be summed only at the end + ggg(1)=facvdw*xj + ggg(2)=facvdw*yj + ggg(3)=facvdw*zj + do k=1,3 + gvdwpp(k,j)=gvdwpp(k,j)+ggg(k) + gvdwpp(k,i)=gvdwpp(k,i)-ggg(k) + enddo +#endif +* +* Angular part +* + ecosa=2.0D0*fac3*fac1+fac4 + fac4=-3.0D0*fac4 + fac3=-6.0D0*fac3 + ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4) + ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4) + do k=1,3 + dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb) + dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg) + enddo +cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3), +cd & (dcosg(k),k=1,3) + do k=1,3 + ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k) + enddo +c do k=1,3 +c ghalf=0.5D0*ggg(k) +c gelc(k,i)=gelc(k,i)+ghalf +c & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) +c & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) +c gelc(k,j)=gelc(k,j)+ghalf +c & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) +c & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) +c enddo +cgrad do k=i+1,j-1 +cgrad do l=1,3 +cgrad gelc(l,k)=gelc(l,k)+ggg(l) +cgrad enddo +cgrad enddo + do k=1,3 + gelc(k,i)=gelc(k,i) + & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) + & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) + gelc(k,j)=gelc(k,j) + & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) + & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) + gelc_long(k,j)=gelc_long(k,j)+ggg(k) + gelc_long(k,i)=gelc_long(k,i)-ggg(k) + enddo + IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 + & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 + & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN +C +C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction +C energy of a peptide unit is assumed in the form of a second-order +C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al. +C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms +C are computed for EVERY pair of non-contiguous peptide groups. +C + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + kkk=0 + do k=1,2 + do l=1,2 + kkk=kkk+1 + muij(kkk)=mu(k,i)*mu(l,j) + enddo + enddo +cd write (iout,*) 'EELEC: i',i,' j',j +cd write (iout,*) 'j',j,' j1',j1,' j2',j2 +cd write(iout,*) 'muij',muij + ury=scalar(uy(1,i),erij) + urz=scalar(uz(1,i),erij) + vry=scalar(uy(1,j),erij) + vrz=scalar(uz(1,j),erij) + a22=scalar(uy(1,i),uy(1,j))-3*ury*vry + a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz + a32=scalar(uz(1,i),uy(1,j))-3*urz*vry + a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz + fac=dsqrt(-ael6i)*r3ij + a22=a22*fac + a23=a23*fac + a32=a32*fac + a33=a33*fac +cd write (iout,'(4i5,4f10.5)') +cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33 +cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij +cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i), +cd & uy(:,j),uz(:,j) +cd write (iout,'(4f10.5)') +cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)), +cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j)) +cd write (iout,'(4f10.5)') ury,urz,vry,vrz +cd write (iout,'(9f10.5/)') +cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij +C Derivatives of the elements of A in virtual-bond vectors + call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1)) + do k=1,3 + uryg(k,1)=scalar(erder(1,k),uy(1,i)) + uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1)) + uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1)) + urzg(k,1)=scalar(erder(1,k),uz(1,i)) + urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1)) + urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1)) + vryg(k,1)=scalar(erder(1,k),uy(1,j)) + vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1)) + vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1)) + vrzg(k,1)=scalar(erder(1,k),uz(1,j)) + vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1)) + vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1)) + enddo +C Compute radial contributions to the gradient + facr=-3.0d0*rrmij + a22der=a22*facr + a23der=a23*facr + a32der=a32*facr + a33der=a33*facr + agg(1,1)=a22der*xj + agg(2,1)=a22der*yj + agg(3,1)=a22der*zj + agg(1,2)=a23der*xj + agg(2,2)=a23der*yj + agg(3,2)=a23der*zj + agg(1,3)=a32der*xj + agg(2,3)=a32der*yj + agg(3,3)=a32der*zj + agg(1,4)=a33der*xj + agg(2,4)=a33der*yj + agg(3,4)=a33der*zj +C Add the contributions coming from er + fac3=-3.0d0*fac + do k=1,3 + agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury) + agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury) + agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz) + agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz) + enddo + do k=1,3 +C Derivatives in DC(i) +cgrad ghalf1=0.5d0*agg(k,1) +cgrad ghalf2=0.5d0*agg(k,2) +cgrad ghalf3=0.5d0*agg(k,3) +cgrad ghalf4=0.5d0*agg(k,4) + aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) + & -3.0d0*uryg(k,2)*vry)!+ghalf1 + aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) + & -3.0d0*uryg(k,2)*vrz)!+ghalf2 + aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) + & -3.0d0*urzg(k,2)*vry)!+ghalf3 + aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) + & -3.0d0*urzg(k,2)*vrz)!+ghalf4 +C Derivatives in DC(i+1) + aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) + & -3.0d0*uryg(k,3)*vry)!+agg(k,1) + aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) + & -3.0d0*uryg(k,3)*vrz)!+agg(k,2) + aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) + & -3.0d0*urzg(k,3)*vry)!+agg(k,3) + aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) + & -3.0d0*urzg(k,3)*vrz)!+agg(k,4) +C Derivatives in DC(j) + aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) + & -3.0d0*vryg(k,2)*ury)!+ghalf1 + aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) + & -3.0d0*vrzg(k,2)*ury)!+ghalf2 + aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) + & -3.0d0*vryg(k,2)*urz)!+ghalf3 + aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) + & -3.0d0*vrzg(k,2)*urz)!+ghalf4 +C Derivatives in DC(j+1) or DC(nres-1) + aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) + & -3.0d0*vryg(k,3)*ury) + aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) + & -3.0d0*vrzg(k,3)*ury) + aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) + & -3.0d0*vryg(k,3)*urz) + aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) + & -3.0d0*vrzg(k,3)*urz) +cgrad if (j.eq.nres-1 .and. i.lt.j-2) then +cgrad do l=1,4 +cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l) +cgrad enddo +cgrad endif + enddo + acipa(1,1)=a22 + acipa(1,2)=a23 + acipa(2,1)=a32 + acipa(2,2)=a33 + a22=-a22 + a23=-a23 + do l=1,2 + do k=1,3 + agg(k,l)=-agg(k,l) + aggi(k,l)=-aggi(k,l) + aggi1(k,l)=-aggi1(k,l) + aggj(k,l)=-aggj(k,l) + aggj1(k,l)=-aggj1(k,l) + enddo + enddo + if (j.lt.nres-1) then + a22=-a22 + a32=-a32 + do l=1,3,2 + do k=1,3 + agg(k,l)=-agg(k,l) + aggi(k,l)=-aggi(k,l) + aggi1(k,l)=-aggi1(k,l) + aggj(k,l)=-aggj(k,l) + aggj1(k,l)=-aggj1(k,l) + enddo + enddo + else + a22=-a22 + a23=-a23 + a32=-a32 + a33=-a33 + do l=1,4 + do k=1,3 + agg(k,l)=-agg(k,l) + aggi(k,l)=-aggi(k,l) + aggi1(k,l)=-aggi1(k,l) + aggj(k,l)=-aggj(k,l) + aggj1(k,l)=-aggj1(k,l) + enddo + enddo + endif + ENDIF ! WCORR + IF (wel_loc.gt.0.0d0) THEN +C Contribution to the local-electrostatic energy coming from the i-j pair + eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) + & +a33*muij(4) +cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij + + if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') + & 'eelloc',i,j,eel_loc_ij + + eel_loc=eel_loc+eel_loc_ij +C Partial derivatives in virtual-bond dihedral angles gamma + if (i.gt.1) + & gel_loc_loc(i-1)=gel_loc_loc(i-1)+ + & a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) + & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j) + gel_loc_loc(j-1)=gel_loc_loc(j-1)+ + & a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) + & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j) +C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2) + do l=1,3 + ggg(l)=agg(l,1)*muij(1)+ + & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4) + gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l) + gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l) +cgrad ghalf=0.5d0*ggg(l) +cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf +cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf + enddo +cgrad do k=i+1,j2 +cgrad do l=1,3 +cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l) +cgrad enddo +cgrad enddo +C Remaining derivatives of eello + do l=1,3 + gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+ + & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4) + gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+ + & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4) + gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+ + & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4) + gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+ + & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4) + enddo + ENDIF +C Change 12/26/95 to calculate four-body contributions to H-bonding energy +c if (j.gt.i+1 .and. num_conti.le.maxconts) then + if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 + & .and. num_conti.le.maxconts) then +c write (iout,*) i,j," entered corr" +C +C Calculate the contact function. The ith column of the array JCONT will +C contain the numbers of atoms that make contacts with the atom I (of numbers +C greater than I). The arrays FACONT and GACONT will contain the values of +C the contact function and its derivative. +c r0ij=1.02D0*rpp(iteli,itelj) +c r0ij=1.11D0*rpp(iteli,itelj) + r0ij=2.20D0*rpp(iteli,itelj) +c r0ij=1.55D0*rpp(iteli,itelj) + call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont) + if (fcont.gt.0.0D0) then + num_conti=num_conti+1 + if (num_conti.gt.maxconts) then + write (iout,*) 'WARNING - max. # of contacts exceeded;', + & ' will skip next contacts for this conf.' + else + jcont_hb(num_conti,i)=j +cd write (iout,*) "i",i," j",j," num_conti",num_conti, +cd & " jcont_hb",jcont_hb(num_conti,i) + IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. + & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN +C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el +C terms. + d_cont(num_conti,i)=rij +cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij +C --- Electrostatic-interaction matrix --- + a_chuj(1,1,num_conti,i)=a22 + a_chuj(1,2,num_conti,i)=a23 + a_chuj(2,1,num_conti,i)=a32 + a_chuj(2,2,num_conti,i)=a33 +C --- Gradient of rij + do kkk=1,3 + grij_hb_cont(kkk,num_conti,i)=erij(kkk) + enddo + kkll=0 + do k=1,2 + do l=1,2 + kkll=kkll+1 + do m=1,3 + a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll) + a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll) + a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll) + a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll) + a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll) + enddo + enddo + enddo + ENDIF + IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN +C Calculate contact energies + cosa4=4.0D0*cosa + wij=cosa-3.0D0*cosb*cosg + cosbg1=cosb+cosg + cosbg2=cosb-cosg +c fac3=dsqrt(-ael6i)/r0ij**3 + fac3=dsqrt(-ael6i)*r3ij +c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1) + ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1 + if (ees0tmp.gt.0) then + ees0pij=dsqrt(ees0tmp) + else + ees0pij=0 + endif +c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2) + ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2 + if (ees0tmp.gt.0) then + ees0mij=dsqrt(ees0tmp) + else + ees0mij=0 + endif +c ees0mij=0.0D0 + ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) + ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) +C Diagnostics. Comment out or remove after debugging! +c ees0p(num_conti,i)=0.5D0*fac3*ees0pij +c ees0m(num_conti,i)=0.5D0*fac3*ees0mij +c ees0m(num_conti,i)=0.0D0 +C End diagnostics. +c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij, +c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont +C Angular derivatives of the contact function + ees0pij1=fac3/ees0pij + ees0mij1=fac3/ees0mij + fac3p=-3.0D0*fac3*rrmij + ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij) + ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij) +c ees0mij1=0.0D0 + ecosa1= ees0pij1*( 1.0D0+0.5D0*wij) + ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1) + ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1) + ecosa2= ees0mij1*(-1.0D0+0.5D0*wij) + ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2) + ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2) + ecosap=ecosa1+ecosa2 + ecosbp=ecosb1+ecosb2 + ecosgp=ecosg1+ecosg2 + ecosam=ecosa1-ecosa2 + ecosbm=ecosb1-ecosb2 + ecosgm=ecosg1-ecosg2 +C Diagnostics +c ecosap=ecosa1 +c ecosbp=ecosb1 +c ecosgp=ecosg1 +c ecosam=0.0D0 +c ecosbm=0.0D0 +c ecosgm=0.0D0 +C End diagnostics + facont_hb(num_conti,i)=fcont + fprimcont=fprimcont/rij +cd facont_hb(num_conti,i)=1.0D0 +C Following line is for diagnostics. +cd fprimcont=0.0D0 + do k=1,3 + dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb) + dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg) + enddo + do k=1,3 + gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k) + gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k) + enddo + gggp(1)=gggp(1)+ees0pijp*xj + gggp(2)=gggp(2)+ees0pijp*yj + gggp(3)=gggp(3)+ees0pijp*zj + gggm(1)=gggm(1)+ees0mijp*xj + gggm(2)=gggm(2)+ees0mijp*yj + gggm(3)=gggm(3)+ees0mijp*zj +C Derivatives due to the contact function + gacont_hbr(1,num_conti,i)=fprimcont*xj + gacont_hbr(2,num_conti,i)=fprimcont*yj + gacont_hbr(3,num_conti,i)=fprimcont*zj + do k=1,3 +c +c 10/24/08 cgrad and ! comments indicate the parts of the code removed +c following the change of gradient-summation algorithm. +c +cgrad ghalfp=0.5D0*gggp(k) +cgrad ghalfm=0.5D0*gggm(k) + gacontp_hb1(k,num_conti,i)=!ghalfp + & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) + & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) + gacontp_hb2(k,num_conti,i)=!ghalfp + & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) + & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) + gacontp_hb3(k,num_conti,i)=gggp(k) + gacontm_hb1(k,num_conti,i)=!ghalfm + & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) + & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) + gacontm_hb2(k,num_conti,i)=!ghalfm + & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) + & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) + gacontm_hb3(k,num_conti,i)=gggm(k) + enddo + ENDIF ! wcorr + endif ! num_conti.le.maxconts + endif ! fcont.gt.0 + endif ! j.gt.i+1 + if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then + do k=1,4 + do l=1,3 + ghalf=0.5d0*agg(l,k) + aggi(l,k)=aggi(l,k)+ghalf + aggi1(l,k)=aggi1(l,k)+agg(l,k) + aggj(l,k)=aggj(l,k)+ghalf + enddo + enddo + if (j.eq.nres-1 .and. i.lt.j-2) then + do k=1,4 + do l=1,3 + aggj1(l,k)=aggj1(l,k)+agg(l,k) + enddo + enddo + endif + endif +c t_eelecij=t_eelecij+MPI_Wtime()-time00 + return + end +C----------------------------------------------------------------------- + subroutine evdwpp_short(evdw1) +C +C Compute Evdwpp +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VECTORS' + include 'COMMON.FFIELD' + dimension ggg(3) +c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions +#ifdef MOMENT + double precision scal_el /1.0d0/ +#else + double precision scal_el /0.5d0/ +#endif + evdw1=0.0D0 +c write (iout,*) "iatel_s_vdw",iatel_s_vdw, +c & " iatel_e_vdw",iatel_e_vdw + call flush(iout) + do i=iatel_s_vdw,iatel_e_vdw + dxi=dc(1,i) + dyi=dc(2,i) + dzi=dc(3,i) + dx_normi=dc_norm(1,i) + dy_normi=dc_norm(2,i) + dz_normi=dc_norm(3,i) + xmedi=c(1,i)+0.5d0*dxi + ymedi=c(2,i)+0.5d0*dyi + zmedi=c(3,i)+0.5d0*dzi + num_conti=0 +c write (iout,*) 'i',i,' ielstart',ielstart_vdw(i), +c & ' ielend',ielend_vdw(i) + call flush(iout) + do j=ielstart_vdw(i),ielend_vdw(i) + ind=ind+1 + iteli=itel(i) + itelj=itel(j) + if (j.eq.i+2 .and. itelj.eq.2) iteli=2 + aaa=app(iteli,itelj) + bbb=bpp(iteli,itelj) + dxj=dc(1,j) + dyj=dc(2,j) + dzj=dc(3,j) + dx_normj=dc_norm(1,j) + dy_normj=dc_norm(2,j) + dz_normj=dc_norm(3,j) + xj=c(1,j)+0.5D0*dxj-xmedi + yj=c(2,j)+0.5D0*dyj-ymedi + zj=c(3,j)+0.5D0*dzj-zmedi + rij=xj*xj+yj*yj+zj*zj + rrmij=1.0D0/rij + rij=dsqrt(rij) + sss=sscale(rij/rpp(iteli,itelj)) + if (sss.gt.0.0d0) then + rmij=1.0D0/rij + r3ij=rrmij*rmij + r6ij=r3ij*r3ij + ev1=aaa*r6ij*r6ij +c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions + if (j.eq.i+2) ev1=scal_el*ev1 + ev2=bbb*r6ij + evdwij=ev1+ev2 + if (energy_dec) then + write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss + endif + evdw1=evdw1+evdwij*sss +C +C Calculate contributions to the Cartesian gradient. +C + facvdw=-6*rrmij*(ev1+evdwij)*sss + ggg(1)=facvdw*xj + ggg(2)=facvdw*yj + ggg(3)=facvdw*zj + do k=1,3 + gvdwpp(k,j)=gvdwpp(k,j)+ggg(k) + gvdwpp(k,i)=gvdwpp(k,i)-ggg(k) + enddo + endif + enddo ! j + enddo ! i + return + end +C----------------------------------------------------------------------------- + subroutine escp_long(evdw2,evdw2_14) +C +C This subroutine calculates the excluded-volume interaction energy between +C peptide-group centers and side chains and its gradient in virtual-bond and +C side-chain vectors. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.IOUNITS' + include 'COMMON.CONTROL' + dimension ggg(3) + evdw2=0.0D0 + evdw2_14=0.0d0 +cd print '(a)','Enter ESCP' +cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e + do i=iatscp_s,iatscp_e + iteli=itel(i) + xi=0.5D0*(c(1,i)+c(1,i+1)) + yi=0.5D0*(c(2,i)+c(2,i+1)) + zi=0.5D0*(c(3,i)+c(3,i+1)) + + do iint=1,nscp_gr(i) + + do j=iscpstart(i,iint),iscpend(i,iint) + itypj=itype(j) +C Uncomment following three lines for SC-p interactions +c xj=c(1,nres+j)-xi +c yj=c(2,nres+j)-yi +c zj=c(3,nres+j)-zi +C Uncomment following three lines for Ca-p interactions + xj=c(1,j)-xi + yj=c(2,j)-yi + zj=c(3,j)-zi + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + + sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli))) + + if (sss.lt.1.0d0) then + + fac=rrij**expon2 + e1=fac*fac*aad(itypj,iteli) + e2=fac*bad(itypj,iteli) + if (iabs(j-i) .le. 2) then + e1=scal14*e1 + e2=scal14*e2 + evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss) + endif + evdwij=e1+e2 + evdw2=evdw2+evdwij*(1.0d0-sss) + if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') + & 'evdw2',i,j,evdwij +C +C Calculate contributions to the gradient in the virtual-bond and SC vectors. +C + fac=-(evdwij+e1)*rrij*(1.0d0-sss) + ggg(1)=xj*fac + ggg(2)=yj*fac + ggg(3)=zj*fac +C Uncomment following three lines for SC-p interactions +c do k=1,3 +c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) +c enddo +C Uncomment following line for SC-p interactions +c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) + do k=1,3 + gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) + gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) + enddo + endif + enddo + + enddo ! iint + enddo ! i + do i=1,nct + do j=1,3 + gvdwc_scp(j,i)=expon*gvdwc_scp(j,i) + gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i) + gradx_scp(j,i)=expon*gradx_scp(j,i) + enddo + enddo +C****************************************************************************** +C +C N O T E !!! +C +C To save time the factor EXPON has been extracted from ALL components +C of GVDWC and GRADX. Remember to multiply them by this factor before further +C use! +C +C****************************************************************************** + return + end +C----------------------------------------------------------------------------- + subroutine escp_short(evdw2,evdw2_14) +C +C This subroutine calculates the excluded-volume interaction energy between +C peptide-group centers and side chains and its gradient in virtual-bond and +C side-chain vectors. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.IOUNITS' + include 'COMMON.CONTROL' + dimension ggg(3) + evdw2=0.0D0 + evdw2_14=0.0d0 +cd print '(a)','Enter ESCP' +cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e + do i=iatscp_s,iatscp_e + iteli=itel(i) + xi=0.5D0*(c(1,i)+c(1,i+1)) + yi=0.5D0*(c(2,i)+c(2,i+1)) + zi=0.5D0*(c(3,i)+c(3,i+1)) + + do iint=1,nscp_gr(i) + + do j=iscpstart(i,iint),iscpend(i,iint) + itypj=itype(j) +C Uncomment following three lines for SC-p interactions +c xj=c(1,nres+j)-xi +c yj=c(2,nres+j)-yi +c zj=c(3,nres+j)-zi +C Uncomment following three lines for Ca-p interactions + xj=c(1,j)-xi + yj=c(2,j)-yi + zj=c(3,j)-zi + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + + sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli))) + + if (sss.gt.0.0d0) then + + fac=rrij**expon2 + e1=fac*fac*aad(itypj,iteli) + e2=fac*bad(itypj,iteli) + if (iabs(j-i) .le. 2) then + e1=scal14*e1 + e2=scal14*e2 + evdw2_14=evdw2_14+(e1+e2)*sss + endif + evdwij=e1+e2 + evdw2=evdw2+evdwij*sss + if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') + & 'evdw2',i,j,evdwij +C +C Calculate contributions to the gradient in the virtual-bond and SC vectors. +C + fac=-(evdwij+e1)*rrij*sss + ggg(1)=xj*fac + ggg(2)=yj*fac + ggg(3)=zj*fac +C Uncomment following three lines for SC-p interactions +c do k=1,3 +c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) +c enddo +C Uncomment following line for SC-p interactions +c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) + do k=1,3 + gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) + gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) + enddo + endif + enddo + + enddo ! iint + enddo ! i + do i=1,nct + do j=1,3 + gvdwc_scp(j,i)=expon*gvdwc_scp(j,i) + gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i) + gradx_scp(j,i)=expon*gradx_scp(j,i) + enddo + enddo +C****************************************************************************** +C +C N O T E !!! +C +C To save time the factor EXPON has been extracted from ALL components +C of GVDWC and GRADX. Remember to multiply them by this factor before further +C use! +C +C****************************************************************************** + return + end diff --git a/source/unres/src_MD-DFA-restraints/energy_p_new_barrier.F b/source/unres/src_MD-DFA-restraints/energy_p_new_barrier.F new file mode 100644 index 0000000..5707b4b --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/energy_p_new_barrier.F @@ -0,0 +1,9496 @@ + 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 + call flush(iout) + if (nfgtasks.gt.1) then +#ifdef MPI + time00=MPI_Wtime() +#else + time00=tcpu() +#endif +C FG slaves call the following matching MPI_Bcast in ERGASTULUM + if (fg_rank.eq.0) then + call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR) +c print *,"Processor",myrank," BROADCAST iorder" +C FG master sets up the WEIGHTS_ array which will be broadcast to the +C FG slaves as WEIGHTS array. + weights_(1)=wsc + weights_(2)=wscp + weights_(3)=welec + weights_(4)=wcorr + weights_(5)=wcorr5 + weights_(6)=wcorr6 + weights_(7)=wel_loc + weights_(8)=wturn3 + weights_(9)=wturn4 + weights_(10)=wturn6 + weights_(11)=wang + weights_(12)=wscloc + weights_(13)=wtor + weights_(14)=wtor_d + weights_(15)=wstrain + weights_(16)=wvdwpp + weights_(17)=wbond + weights_(18)=scal14 + weights_(21)=wsccor + weights_(22)=wsct +C FG Master broadcasts the WEIGHTS_ array + call MPI_Bcast(weights_(1),n_ene, + & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) + else +C FG slaves receive the WEIGHTS array + call MPI_Bcast(weights(1),n_ene, + & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) + wsc=weights(1) + wscp=weights(2) + welec=weights(3) + wcorr=weights(4) + wcorr5=weights(5) + wcorr6=weights(6) + wel_loc=weights(7) + wturn3=weights(8) + wturn4=weights(9) + wturn6=weights(10) + wang=weights(11) + wscloc=weights(12) + wtor=weights(13) + wtor_d=weights(14) + wstrain=weights(15) + wvdwpp=weights(16) + wbond=weights(17) + scal14=weights(18) + wsccor=weights(21) + wsct=weights(22) + endif + time_Bcast=time_Bcast+MPI_Wtime()-time00 + time_Bcastw=time_Bcastw+MPI_Wtime()-time00 +c call chainbuild_cart + endif +c print *,'Processor',myrank,' calling etotal ipot=',ipot +c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct +#else +c if (modecalc.eq.12.or.modecalc.eq.14) then +c call int_from_cart1(.false.) +c endif +#endif +#ifdef TIMING +#ifdef MPI + time00=MPI_Wtime() +#else + time00=tcpu() +#endif +#endif +C +C Compute the side-chain and electrostatic interaction energy +C + goto (101,102,103,104,105,106) ipot +C Lennard-Jones potential. + 101 call elj(evdw,evdw_p,evdw_m) +cd print '(a)','Exit ELJ' + goto 107 +C Lennard-Jones-Kihara potential (shifted). + 102 call eljk(evdw,evdw_p,evdw_m) + goto 107 +C Berne-Pechukas potential (dilated LJ, angular dependence). + 103 call ebp(evdw,evdw_p,evdw_m) + goto 107 +C Gay-Berne potential (shifted LJ, angular dependence). + 104 call egb(evdw,evdw_p,evdw_m) + goto 107 +C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). + 105 call egbv(evdw,evdw_p,evdw_m) + goto 107 +C Soft-sphere potential + 106 call e_softsphere(evdw) +C +C Calculate electrostatic (H-bonding) energy of the main chain. +C + 107 continue +C BARTEK for dfa test! + if (wdfa_dist.gt.0) then + call edfad(edfadis) + else + edfadis=0 + endif +c print*, 'edfad is finished!', edfadis + if (wdfa_tor.gt.0) then + call edfat(edfator) + else + edfator=0 + endif +c print*, 'edfat is finished!', edfator + if (wdfa_nei.gt.0) then + call edfan(edfanei) + else + edfanei=0 + endif +c print*, 'edfan is finished!', edfanei + if (wdfa_beta.gt.0) then + call edfab(edfabet) + else + edfabet=0 + endif +c print*, 'edfab is finished!', edfabet +cmc +cmc Sep-06: egb takes care of dynamic ss bonds too +cmc +c if (dyn_ss) call dyn_set_nss + +c print *,"Processor",myrank," computed USCSC" +#ifdef TIMING +#ifdef MPI + time01=MPI_Wtime() +#else + time00=tcpu() +#endif +#endif + call vec_and_deriv +#ifdef TIMING +#ifdef MPI + time_vec=time_vec+MPI_Wtime()-time01 +#else + time_vec=time_vec+tcpu()-time01 +#endif +#endif +c print *,"Processor",myrank," left VEC_AND_DERIV" + if (ipot.lt.6) then +#ifdef SPLITELE + if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. + & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 + & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 + & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then +#else + if (welec.gt.0d0.or.wel_loc.gt.0d0.or. + & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 + & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 + & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then +#endif + call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4) + else + ees=0.0d0 + evdw1=0.0d0 + eel_loc=0.0d0 + eello_turn3=0.0d0 + eello_turn4=0.0d0 + endif + else +c write (iout,*) "Soft-spheer ELEC potential" + call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3, + & eello_turn4) + endif +c print *,"Processor",myrank," computed UELEC" +C +C Calculate excluded-volume interaction energy between peptide groups +C and side chains. +C + if (ipot.lt.6) then + if(wscp.gt.0d0) then + call escp(evdw2,evdw2_14) + else + evdw2=0 + evdw2_14=0 + endif + else +c write (iout,*) "Soft-sphere SCP potential" + call escp_soft_sphere(evdw2,evdw2_14) + endif +c +c Calculate the bond-stretching energy +c + call ebond(estr) +C +C Calculate the disulfide-bridge and other energy and the contributions +C from other distance constraints. +cd print *,'Calling EHPB' + call edis(ehpb) +cd print *,'EHPB exitted succesfully.' +C +C Calculate the virtual-bond-angle energy. +C + if (wang.gt.0d0) then + call ebend(ebe) + else + ebe=0 + endif +c print *,"Processor",myrank," computed UB" +C +C Calculate the SC local energy. +C + call esc(escloc) +c print *,"Processor",myrank," computed USC" +C +C Calculate the virtual-bond torsional energy. +C +cd print *,'nterm=',nterm + if (wtor.gt.0) then + call etor(etors,edihcnstr) + else + etors=0 + edihcnstr=0 + endif + + if (constr_homology.ge.1) then + call e_modeller(ehomology_constr) + else + ehomology_constr=0.0d0 + endif + + +c write(iout,*) ehomology_constr +c print *,"Processor",myrank," computed Utor" +C +C 6/23/01 Calculate double-torsional energy +C + if (wtor_d.gt.0) then + call etor_d(etors_d) + else + etors_d=0 + endif +c print *,"Processor",myrank," computed Utord" +C +C 21/5/07 Calculate local sicdechain correlation energy +C + if (wsccor.gt.0.0d0) then + call eback_sc_corr(esccor) + else + esccor=0.0d0 + endif +c print *,"Processor",myrank," computed Usccorr" +C +C 12/1/95 Multi-body terms +C + n_corr=0 + n_corr1=0 + if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 + & .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then + call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1) +cd write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1, +cd &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6 + else + ecorr=0.0d0 + ecorr5=0.0d0 + ecorr6=0.0d0 + eturn6=0.0d0 + endif + if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then + call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) +cd write (iout,*) "multibody_hb ecorr",ecorr + endif +c print *,"Processor",myrank," computed Ucorr" +C +C If performing constraint dynamics, call the constraint energy +C after the equilibration time + if(usampl.and.totT.gt.eq_time) then + call EconstrQ + call Econstr_back + else + Uconst=0.0d0 + Uconst_back=0.0d0 + endif +#ifdef TIMING +#ifdef MPI + time_enecalc=time_enecalc+MPI_Wtime()-time00 +#else + time_enecalc=time_enecalc+tcpu()-time00 +#endif +#endif +c print *,"Processor",myrank," computed Uconstr" +#ifdef TIMING +#ifdef MPI + time00=MPI_Wtime() +#else + time00=tcpu() +#endif +#endif +c +C Sum the energies +C + energia(1)=evdw +#ifdef SCP14 + energia(2)=evdw2-evdw2_14 + energia(18)=evdw2_14 +#else + energia(2)=evdw2 + energia(18)=0.0d0 +#endif +#ifdef SPLITELE + energia(3)=ees + energia(16)=evdw1 +#else + energia(3)=ees+evdw1 + energia(16)=0.0d0 +#endif + energia(4)=ecorr + energia(5)=ecorr5 + energia(6)=ecorr6 + energia(7)=eel_loc + energia(8)=eello_turn3 + energia(9)=eello_turn4 + energia(10)=eturn6 + energia(11)=ebe + energia(12)=escloc + energia(13)=etors + energia(14)=etors_d + energia(15)=ehpb + energia(19)=edihcnstr + energia(17)=estr + energia(20)=Uconst+Uconst_back + energia(21)=esccor + energia(22)=evdw_p + energia(23)=evdw_m + energia(24)=ehomology_constr + energia(25)=edfadis + energia(26)=edfator + energia(27)=edfanei + energia(28)=edfabet +c print *," Processor",myrank," calls SUM_ENERGY" + call sum_energy(energia,.true.) + if (dyn_ss) call dyn_set_nss +c print *," Processor",myrank," left SUM_ENERGY" +#ifdef TIMING +#ifdef MPI + time_sumene=time_sumene+MPI_Wtime()-time00 +#else + time_sumene=time_sumene+tcpu()-time00 +#endif +#endif + return + end +c------------------------------------------------------------------------------- + subroutine sum_energy(energia,reduce) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifndef ISNAN + external proc_proc +#ifdef WINPGI +cMS$ATTRIBUTES C :: proc_proc +#endif +#endif +#ifdef MPI + include "mpif.h" +#endif + include 'COMMON.SETUP' + include 'COMMON.IOUNITS' + double precision energia(0:n_ene),enebuff(0:n_ene+1) + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.CONTROL' + include 'COMMON.TIME1' + logical reduce +#ifdef MPI + if (nfgtasks.gt.1 .and. reduce) then +#ifdef DEBUG + write (iout,*) "energies before REDUCE" + call enerprint(energia) + call flush(iout) +#endif + do i=0,n_ene + enebuff(i)=energia(i) + enddo + time00=MPI_Wtime() + call MPI_Barrier(FG_COMM,IERR) + time_barrier_e=time_barrier_e+MPI_Wtime()-time00 + time00=MPI_Wtime() + call MPI_Reduce(enebuff(0),energia(0),n_ene+1, + & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) +#ifdef DEBUG + write (iout,*) "energies after REDUCE" + call enerprint(energia) + call flush(iout) +#endif + time_Reduce=time_Reduce+MPI_Wtime()-time00 + endif + if (fg_rank.eq.0) then +#endif +#ifdef TSCSC + evdw=energia(22)+wsct*energia(23) +#else + evdw=energia(1) +#endif +#ifdef SCP14 + evdw2=energia(2)+energia(18) + evdw2_14=energia(18) +#else + evdw2=energia(2) +#endif +#ifdef SPLITELE + ees=energia(3) + evdw1=energia(16) +#else + ees=energia(3) + evdw1=0.0d0 +#endif + ecorr=energia(4) + ecorr5=energia(5) + ecorr6=energia(6) + eel_loc=energia(7) + eello_turn3=energia(8) + eello_turn4=energia(9) + eturn6=energia(10) + ebe=energia(11) + escloc=energia(12) + etors=energia(13) + etors_d=energia(14) + ehpb=energia(15) + edihcnstr=energia(19) + estr=energia(17) + Uconst=energia(20) + esccor=energia(21) + ehomology_constr=energia(24) + edfadis=energia(25) + edfator=energia(26) + edfanei=energia(27) + edfabet=energia(28) +#ifdef SPLITELE + etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 + & +wang*ebe+wtor*etors+wscloc*escloc + & +wstrain*ehpb+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+ehomology_constr + & +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+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+ehomology_constr + & +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' +#endif + double precision gradbufc(3,maxres),gradbufx(3,maxres), + & glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres) + include 'COMMON.SETUP' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.CONTROL' + include 'COMMON.TIME1' + include 'COMMON.MAXGRAD' + include 'COMMON.SCCOR' +#ifdef TIMING +#ifdef MPI + time01=MPI_Wtime() +#else + time01=tcpu() +#endif +#endif +#ifdef DEBUG + write (iout,*) "sum_gradient gvdwc, gvdwx" + do i=1,nres + write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)') + & i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3), + & (gvdwcT(j,i),j=1,3) + enddo + call flush(iout) +#endif +#ifdef MPI +C FG slaves call the following matching MPI_Bcast in ERGASTULUM + if (nfgtasks.gt.1 .and. fg_rank.eq.0) + & call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR) +#endif +C +C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient +C in virtual-bond-vector coordinates +C +#ifdef DEBUG +c write (iout,*) "gel_loc gel_loc_long and gel_loc_loc" +c do i=1,nres-1 +c write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)') +c & i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i) +c enddo +c write (iout,*) "gel_loc_tur3 gel_loc_turn4" +c do i=1,nres-1 +c write (iout,'(i5,3f10.5,2x,f10.5)') +c & i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i) +c enddo + write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc" + do i=1,nres + write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') + & i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3), + & g_corr5_loc(i) + enddo + call flush(iout) +#endif +#ifdef SPLITELE +#ifdef TSCSC + do i=1,nct + do j=1,3 + gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+ + & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ + & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ + & wel_loc*gel_loc_long(j,i)+ + & wcorr*gradcorr_long(j,i)+ + & wcorr5*gradcorr5_long(j,i)+ + & wcorr6*gradcorr6_long(j,i)+ + & wturn6*gcorr6_turn_long(j,i)+ + & wstrain*ghpbc(j,i)+ + & 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 + do i=1,nres + do j=1,3 + gradbufc_sum(j,i)=gradbufc(j,i) + enddo + enddo +c call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres, +c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR) +c time_reduce=time_reduce+MPI_Wtime()-time00 +#ifdef DEBUG +c write (iout,*) "gradbufc_sum after allreduce" +c do i=1,nres +c write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3) +c enddo +c call flush(iout) +#endif +#ifdef TIMING +c time_allreduce=time_allreduce+MPI_Wtime()-time00 +#endif + do i=nnt,nres + do k=1,3 + gradbufc(k,i)=0.0d0 + enddo + enddo +#ifdef DEBUG + write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end + write (iout,*) (i," jgrad_start",jgrad_start(i), + & " jgrad_end ",jgrad_end(i), + & i=igrad_start,igrad_end) +#endif +c +c Obsolete and inefficient code; we can make the effort O(n) and, therefore, +c do not parallelize this part. +c +c do i=igrad_start,igrad_end +c do j=jgrad_start(i),jgrad_end(i) +c do k=1,3 +c gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j) +c enddo +c enddo +c enddo + do j=1,3 + gradbufc(j,nres-1)=gradbufc_sum(j,nres) + enddo + do i=nres-2,nnt,-1 + do j=1,3 + gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1) + enddo + enddo +#ifdef DEBUG + write (iout,*) "gradbufc after summing" + do i=1,nres + write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) + enddo + call flush(iout) +#endif + else +#endif +#ifdef DEBUG + write (iout,*) "gradbufc" + do i=1,nres + write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) + enddo + call flush(iout) +#endif + do i=1,nres + do j=1,3 + gradbufc_sum(j,i)=gradbufc(j,i) + gradbufc(j,i)=0.0d0 + enddo + enddo + do j=1,3 + gradbufc(j,nres-1)=gradbufc_sum(j,nres) + enddo + do i=nres-2,nnt,-1 + do j=1,3 + gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1) + enddo + enddo +c do i=nnt,nres-1 +c do k=1,3 +c gradbufc(k,i)=0.0d0 +c enddo +c do j=i+1,nres +c do k=1,3 +c gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j) +c enddo +c enddo +c enddo +#ifdef DEBUG + write (iout,*) "gradbufc after summing" + do i=1,nres + write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) + enddo + call flush(iout) +#endif +#ifdef MPI + endif +#endif + do k=1,3 + gradbufc(k,nres)=0.0d0 + enddo + do i=1,nct + do j=1,3 +#ifdef SPLITELE + gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ + & wel_loc*gel_loc(j,i)+ + & 0.5d0*(wscp*gvdwc_scpp(j,i)+ + & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ + & wel_loc*gel_loc_long(j,i)+ + & wcorr*gradcorr_long(j,i)+ + & wcorr5*gradcorr5_long(j,i)+ + & wcorr6*gradcorr6_long(j,i)+ + & wturn6*gcorr6_turn_long(j,i))+ + & wbond*gradb(j,i)+ + & wcorr*gradcorr(j,i)+ + & wturn3*gcorr3_turn(j,i)+ + & wturn4*gcorr4_turn(j,i)+ + & wcorr5*gradcorr5(j,i)+ + & wcorr6*gradcorr6(j,i)+ + & wturn6*gcorr6_turn(j,i)+ + & wsccor*gsccorc(j,i) + & +wscloc*gscloc(j,i) +#else + gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ + & wel_loc*gel_loc(j,i)+ + & 0.5d0*(wscp*gvdwc_scpp(j,i)+ + & welec*gelc_long(j,i)+ + & wel_loc*gel_loc_long(j,i)+ + & wcorr*gcorr_long(j,i)+ + & wcorr5*gradcorr5_long(j,i)+ + & wcorr6*gradcorr6_long(j,i)+ + & wturn6*gcorr6_turn_long(j,i))+ + & wbond*gradb(j,i)+ + & wcorr*gradcorr(j,i)+ + & wturn3*gcorr3_turn(j,i)+ + & wturn4*gcorr4_turn(j,i)+ + & wcorr5*gradcorr5(j,i)+ + & wcorr6*gradcorr6(j,i)+ + & wturn6*gcorr6_turn(j,i)+ + & wsccor*gsccorc(j,i) + & +wscloc*gscloc(j,i) +#endif +#ifdef TSCSC + gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+ + & wscp*gradx_scp(j,i)+ + & wbond*gradbx(j,i)+ + & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ + & wsccor*gsccorx(j,i) + & +wscloc*gsclocx(j,i) +#else + gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ + & wbond*gradbx(j,i)+ + & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ + & wsccor*gsccorx(j,i) + & +wscloc*gsclocx(j,i) +#endif + enddo + enddo +#ifdef DEBUG + write (iout,*) "gloc before adding corr" + do i=1,4*nres + write (iout,*) i,gloc(i,icg) + enddo +#endif + do i=1,nres-3 + gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) + & +wcorr5*g_corr5_loc(i) + & +wcorr6*g_corr6_loc(i) + & +wturn4*gel_loc_turn4(i) + & +wturn3*gel_loc_turn3(i) + & +wturn6*gel_loc_turn6(i) + & +wel_loc*gel_loc_loc(i) + enddo +#ifdef DEBUG + write (iout,*) "gloc after adding corr" + do i=1,4*nres + write (iout,*) i,gloc(i,icg) + enddo +#endif +#ifdef MPI + if (nfgtasks.gt.1) then + do j=1,3 + do i=1,nres + gradbufc(j,i)=gradc(j,i,icg) + gradbufx(j,i)=gradx(j,i,icg) + enddo + enddo + do i=1,4*nres + glocbuf(i)=gloc(i,icg) + enddo +#ifdef DEBUG + write (iout,*) "gloc_sc before reduce" + do i=1,nres + do j=1,3 + write (iout,*) i,j,gloc_sc(j,i,icg) + enddo + enddo +#endif + do i=1,nres + do j=1,3 + gloc_scbuf(j,i)=gloc_sc(j,i,icg) + enddo + enddo + time00=MPI_Wtime() + call MPI_Barrier(FG_COMM,IERR) + time_barrier_g=time_barrier_g+MPI_Wtime()-time00 + time00=MPI_Wtime() + call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres, + & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) + call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres, + & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) + call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres, + & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) + call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres, + & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) + time_reduce=time_reduce+MPI_Wtime()-time00 +#ifdef DEBUG + write (iout,*) "gloc_sc after reduce" + do i=1,nres + do j=1,3 + write (iout,*) i,j,gloc_sc(j,i,icg) + enddo + enddo +#endif +#ifdef DEBUG + write (iout,*) "gloc after reduce" + do i=1,4*nres + write (iout,*) i,gloc(i,icg) + enddo +#endif + endif +#endif + if (gnorm_check) then +c +c Compute the maximum elements of the gradient +c + gvdwc_max=0.0d0 + gvdwc_scp_max=0.0d0 + gelc_max=0.0d0 + gvdwpp_max=0.0d0 + gradb_max=0.0d0 + ghpbc_max=0.0d0 + gradcorr_max=0.0d0 + gel_loc_max=0.0d0 + gcorr3_turn_max=0.0d0 + gcorr4_turn_max=0.0d0 + gradcorr5_max=0.0d0 + gradcorr6_max=0.0d0 + gcorr6_turn_max=0.0d0 + gsccorc_max=0.0d0 + gscloc_max=0.0d0 + gvdwx_max=0.0d0 + gradx_scp_max=0.0d0 + ghpbx_max=0.0d0 + gradxorr_max=0.0d0 + gsccorx_max=0.0d0 + gsclocx_max=0.0d0 + do i=1,nct + gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i))) + if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm +#ifdef TSCSC + gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i))) + if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm +#endif + gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i))) + if (gvdwc_scp_norm.gt.gvdwc_scp_max) + & gvdwc_scp_max=gvdwc_scp_norm + gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i))) + if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm + gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i))) + if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm + gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i))) + if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm + ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i))) + if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm + gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i))) + if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm + gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i))) + if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm + gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i), + & gcorr3_turn(1,i))) + if (gcorr3_turn_norm.gt.gcorr3_turn_max) + & gcorr3_turn_max=gcorr3_turn_norm + gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i), + & gcorr4_turn(1,i))) + if (gcorr4_turn_norm.gt.gcorr4_turn_max) + & gcorr4_turn_max=gcorr4_turn_norm + gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i))) + if (gradcorr5_norm.gt.gradcorr5_max) + & gradcorr5_max=gradcorr5_norm + gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i))) + if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm + gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i), + & gcorr6_turn(1,i))) + if (gcorr6_turn_norm.gt.gcorr6_turn_max) + & gcorr6_turn_max=gcorr6_turn_norm + gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i))) + if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm + gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i))) + if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm + gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i))) + if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm +#ifdef TSCSC + gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i))) + if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm +#endif + gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i))) + if (gradx_scp_norm.gt.gradx_scp_max) + & gradx_scp_max=gradx_scp_norm + ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i))) + if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm + gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i))) + if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm + gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i))) + if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm + gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i))) + if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm + enddo + if (gradout) then +#ifdef AIX + open(istat,file=statname,position="append") +#else + open(istat,file=statname,access="append") +#endif + write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max, + & gelc_max,gvdwpp_max,gradb_max,ghpbc_max, + & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max, + & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max, + & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max, + & gsccorx_max,gsclocx_max + close(istat) + if (gvdwc_max.gt.1.0d4) then + write (iout,*) "gvdwc gvdwx gradb gradbx" + do i=nnt,nct + write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i), + & gradb(j,i),gradbx(j,i),j=1,3) + enddo + call pdbout(0.0d0,'cipiszcze',iout) + call flush(iout) + endif + endif + endif +#ifdef DEBUG + write (iout,*) "gradc gradx gloc" + do i=1,nres + write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') + & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg) + enddo +#endif +#ifdef TIMING +#ifdef MPI + time_sumgradient=time_sumgradient+MPI_Wtime()-time01 +#else + time_sumgradient=time_sumgradient+tcpu()-time01 +#endif +#endif + return + end +c------------------------------------------------------------------------------- + subroutine rescale_weights(t_bath) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + double precision kfac /2.4d0/ + double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/ +c facT=temp0/t_bath +c facT=2*temp0/(t_bath+temp0) + if (rescale_mode.eq.0) then + facT=1.0d0 + facT2=1.0d0 + facT3=1.0d0 + facT4=1.0d0 + facT5=1.0d0 + else if (rescale_mode.eq.1) then + facT=kfac/(kfac-1.0d0+t_bath/temp0) + facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2) + facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3) + facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4) + facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5) + else if (rescale_mode.eq.2) then + x=t_bath/temp0 + x2=x*x + x3=x2*x + x4=x3*x + x5=x4*x + facT=licznik/dlog(dexp(x)+dexp(-x)) + facT2=licznik/dlog(dexp(x2)+dexp(-x2)) + facT3=licznik/dlog(dexp(x3)+dexp(-x3)) + facT4=licznik/dlog(dexp(x4)+dexp(-x4)) + facT5=licznik/dlog(dexp(x5)+dexp(-x5)) + else + write (iout,*) "Wrong RESCALE_MODE",rescale_mode + write (*,*) "Wrong RESCALE_MODE",rescale_mode +#ifdef MPI + call MPI_Finalize(MPI_COMM_WORLD,IERROR) +#endif + stop 555 + endif + welec=weights(3)*fact + wcorr=weights(4)*fact3 + wcorr5=weights(5)*fact4 + wcorr6=weights(6)*fact5 + wel_loc=weights(7)*fact2 + wturn3=weights(8)*fact2 + wturn4=weights(9)*fact3 + wturn6=weights(10)*fact5 + wtor=weights(13)*fact + wtor_d=weights(14)*fact2 + wsccor=weights(21)*fact +#ifdef TSCSC +c wsct=t_bath/temp0 + wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0 +#endif + return + end +C------------------------------------------------------------------------ + subroutine enerprint(energia) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + include 'COMMON.MD' + double precision energia(0:n_ene) + etot=energia(0) +#ifdef TSCSC + evdw=energia(22)+wsct*energia(23) +#else + evdw=energia(1) +#endif + evdw2=energia(2) +#ifdef SCP14 + evdw2=energia(2)+energia(18) +#else + evdw2=energia(2) +#endif + ees=energia(3) +#ifdef SPLITELE + evdw1=energia(16) +#endif + ecorr=energia(4) + ecorr5=energia(5) + ecorr6=energia(6) + eel_loc=energia(7) + eello_turn3=energia(8) + eello_turn4=energia(9) + eello_turn6=energia(10) + ebe=energia(11) + escloc=energia(12) + etors=energia(13) + etors_d=energia(14) + ehpb=energia(15) + edihcnstr=energia(19) + estr=energia(17) + Uconst=energia(20) + esccor=energia(21) + ehomology_constr=energia(24) +C Bartek + edfadis = energia(25) + edfator = energia(26) + edfanei = energia(27) + edfabet = energia(28) + +#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,ehomology_constr, ebr*nss, + & Uconst,edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei, + & edfabet,wdfa_beta,etot + 10 format (/'Virtual-chain energies:'// + & 'EVDW= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/ + & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/ + & 'EES= ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/ + & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/ + & 'ESTR= ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/ + & 'EBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/ + & 'ESC= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/ + & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/ + & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/ + & 'EHPB= ',1pE16.6,' WEIGHT=',1pE16.6, + & ' (SS bridges & dist. cnstr.)'/ + & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ + & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ + & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ + & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/ + & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/ + & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/ + & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/ + & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/ + & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ + & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/ + & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ + & 'UCONST= ',1pE16.6,' (Constraint energy)'/ + & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/ + & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/ + & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/ + & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/ + & 'ETOT= ',1pE16.6,' (total)') +#else + write (iout,10) evdw,wsc,evdw2,wscp,ees,welec, + & 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, + & ehomology_constr,ebr*nss,Uconst,edfadis,wdfa_dist,edfator, + & wdfa_tor,edfanei,wdfa_nei,edfabet,wdfa_beta, + & 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)'/ + & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/ + & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ + & 'UCONST=',1pE16.6,' (Constraint energy)'/ + & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/ + & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/ + & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/ + & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.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' + 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 +c write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj, +c & dhpb(i),dhpb1(i),forcon(i) +C 24/11/03 AL: SS bridges handled separately because of introducing a specific +C distance and angle dependent SS bond potential. +cmc if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then +C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds + if (.not.dyn_ss .and. i.le.nss) then +C 15/02/13 CC dynamic SSbond - additional check + if (ii.gt.nres + & .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then + call ssbond_ene(iii,jjj,eij) + ehpb=ehpb+2*eij + endif +cd write (iout,*) "eij",eij + else if (ii.gt.nres .and. jj.gt.nres) then +c Restraints from contact prediction + dd=dist(ii,jj) + if (dhpb1(i).gt.0.0d0) then + ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) + fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd +c write (iout,*) "beta nmr", +c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) + else + dd=dist(ii,jj) + rdis=dd-dhpb(i) +C Get the force constant corresponding to this distance. + waga=forcon(i) +C Calculate the contribution to energy. + ehpb=ehpb+waga*rdis*rdis +c write (iout,*) "beta reg",dd,waga*rdis*rdis +C +C Evaluate gradient. +C + fac=waga*rdis/dd + endif + do j=1,3 + ggg(j)=fac*(c(j,jj)-c(j,ii)) + enddo + do j=1,3 + ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) + ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) + enddo + do k=1,3 + ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k) + ghpbc(k,iii)=ghpbc(k,iii)-ggg(k) + enddo + else +C Calculate the distance between the two points and its difference from the +C target distance. + dd=dist(ii,jj) + if (dhpb1(i).gt.0.0d0) then + ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) + fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd +c write (iout,*) "alph nmr", +c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) + else + rdis=dd-dhpb(i) +C Get the force constant corresponding to this distance. + waga=forcon(i) +C Calculate the contribution to energy. + ehpb=ehpb+waga*rdis*rdis +c write (iout,*) "alpha reg",dd,waga*rdis*rdis +C +C Evaluate gradient. +C + fac=waga*rdis/dd + endif +cd print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd, +cd & ' waga=',waga,' fac=',fac + do j=1,3 + ggg(j)=fac*(c(j,jj)-c(j,ii)) + enddo +cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3) +C If this is a SC-SC distance, we need to calculate the contributions to the +C Cartesian gradient in the SC vectors (ghpbx). + if (iii.lt.ii) then + do j=1,3 + ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) + ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) + enddo + endif +cgrad do j=iii,jjj-1 +cgrad do k=1,3 +cgrad ghpbc(k,j)=ghpbc(k,j)+ggg(k) +cgrad enddo +cgrad enddo + do k=1,3 + ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k) + ghpbc(k,iii)=ghpbc(k,iii)-ggg(k) + enddo + endif + enddo + ehpb=0.5D0*ehpb + return + end +C-------------------------------------------------------------------------- + subroutine ssbond_ene(i,j,eij) +C +C Calculate the distance and angle dependent SS-bond potential energy +C using a free-energy function derived based on RHF/6-31G** ab initio +C calculations of diethyl disulfide. +C +C A. Liwo and U. Kozlowska, 11/24/03 +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + double precision erij(3),dcosom1(3),dcosom2(3),gg(3) + itypi=itype(i) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) + dxi=dc_norm(1,nres+i) + dyi=dc_norm(2,nres+i) + dzi=dc_norm(3,nres+i) +c dsci_inv=dsc_inv(itypi) + dsci_inv=vbld_inv(nres+i) + itypj=itype(j) +c dscj_inv=dsc_inv(itypj) + dscj_inv=vbld_inv(nres+j) + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + rij=dsqrt(rrij) + erij(1)=xj*rij + erij(2)=yj*rij + erij(3)=zj*rij + om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) + om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) + om12=dxi*dxj+dyi*dyj+dzi*dzj + do k=1,3 + dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) + dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k)) + enddo + rij=1.0d0/rij + deltad=rij-d0cm + deltat1=1.0d0-om1 + deltat2=1.0d0+om2 + deltat12=om2-om1+2.0d0 + cosphi=om12-om1*om2 + eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) + & +akct*deltad*deltat12+ebr + & +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)+gloc(nphi+i-2,icg) + 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 +c lprn1=.true. + if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)') + & 'ebe', i,theta(i)*rad2deg,phii*rad2deg, + & phii1*rad2deg,ethetai +c lprn1=.false. + 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)=gloc(nphi+i-2,icg)+wang*dethetai + enddo + return + end +#endif +#ifdef CRYST_SC +c----------------------------------------------------------------------------- + subroutine esc(escloc) +C Calculate the local energy of a side chain and its derivatives in the +C corresponding virtual-bond valence angles THETA and the spherical angles +C ALPHA and OMEGA. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3), + & ddersc0(3),ddummy(3),xtemp(3),temp(3) + common /sccalc/ time11,time12,time112,theti,it,nlobit + delta=0.02d0*pi + escloc=0.0D0 +c write (iout,'(a)') 'ESC' + do i=loc_start,loc_end + it=itype(i) + if (it.eq.10) goto 1 + nlobit=nlob(it) +c print *,'i=',i,' it=',it,' nlobit=',nlobit +c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad + theti=theta(i+1)-pipol + x(1)=dtan(theti) + x(2)=alph(i) + x(3)=omeg(i) + + if (x(2).gt.pi-delta) then + xtemp(1)=x(1) + xtemp(2)=pi-delta + xtemp(3)=x(3) + call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) + xtemp(2)=pi + call enesc(xtemp,escloci1,dersc1,ddummy,.false.) + call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2), + & escloci,dersc(2)) + call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), + & ddersc0(1),dersc(1)) + call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3), + & ddersc0(3),dersc(3)) + xtemp(2)=pi-delta + call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) + xtemp(2)=pi + call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) + call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1, + & dersc0(2),esclocbi,dersc02) + call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), + & dersc12,dersc01) + call splinthet(x(2),0.5d0*delta,ss,ssd) + dersc0(1)=dersc01 + dersc0(2)=dersc02 + dersc0(3)=0.0d0 + do k=1,3 + dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) + enddo + dersc(2)=dersc(2)+ssd*(escloci-esclocbi) +c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, +c & esclocbi,ss,ssd + escloci=ss*escloci+(1.0d0-ss)*esclocbi +c escloci=esclocbi +c write (iout,*) escloci + else if (x(2).lt.delta) then + xtemp(1)=x(1) + xtemp(2)=delta + xtemp(3)=x(3) + call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) + xtemp(2)=0.0d0 + call enesc(xtemp,escloci1,dersc1,ddummy,.false.) + call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2), + & escloci,dersc(2)) + call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), + & ddersc0(1),dersc(1)) + call spline2(x(2),delta,-delta,dersc0(3),dersc1(3), + & ddersc0(3),dersc(3)) + xtemp(2)=delta + call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) + xtemp(2)=0.0d0 + call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) + call spline1(x(2),delta,-delta,esclocbi0,esclocbi1, + & dersc0(2),esclocbi,dersc02) + call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), + & dersc12,dersc01) + dersc0(1)=dersc01 + dersc0(2)=dersc02 + dersc0(3)=0.0d0 + call splinthet(x(2),0.5d0*delta,ss,ssd) + do k=1,3 + dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) + enddo + dersc(2)=dersc(2)+ssd*(escloci-esclocbi) +c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, +c & esclocbi,ss,ssd + escloci=ss*escloci+(1.0d0-ss)*esclocbi +c write (iout,*) escloci + else + call enesc(x,escloci,dersc,ddummy,.false.) + endif + + escloc=escloc+escloci + if (energy_dec) write (iout,'(a6,i5,0pf7.3)') + & 'escloc',i,escloci +c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc + + gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ + & wscloc*dersc(1) + gloc(ialph(i,1),icg)=wscloc*dersc(2) + gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3) + 1 continue + enddo + return + end +C--------------------------------------------------------------------------- + subroutine enesc(x,escloci,dersc,ddersc,mixed) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /sccalc/ time11,time12,time112,theti,it,nlobit + double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3) + double precision contr(maxlob,-1:1) + logical mixed +c write (iout,*) 'it=',it,' nlobit=',nlobit + escloc_i=0.0D0 + do j=1,3 + dersc(j)=0.0D0 + if (mixed) ddersc(j)=0.0d0 + enddo + x3=x(3) + +C Because of periodicity of the dependence of the SC energy in omega we have +C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi). +C To avoid underflows, first compute & store the exponents. + + do iii=-1,1 + + x(3)=x3+iii*dwapi + + do j=1,nlobit + do k=1,3 + z(k)=x(k)-censc(k,j,it) + enddo + do k=1,3 + Axk=0.0D0 + do l=1,3 + Axk=Axk+gaussc(l,k,j,it)*z(l) + enddo + Ax(k,j,iii)=Axk + enddo + expfac=0.0D0 + do k=1,3 + expfac=expfac+Ax(k,j,iii)*z(k) + enddo + contr(j,iii)=expfac + enddo ! j + + enddo ! iii + + x(3)=x3 +C As in the case of ebend, we want to avoid underflows in exponentiation and +C subsequent NaNs and INFs in energy calculation. +C Find the largest exponent + emin=contr(1,-1) + do iii=-1,1 + do j=1,nlobit + if (emin.gt.contr(j,iii)) emin=contr(j,iii) + enddo + enddo + emin=0.5D0*emin +cd print *,'it=',it,' emin=',emin + +C Compute the contribution to SC energy and derivatives + do iii=-1,1 + + do j=1,nlobit +#ifdef OSF + adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin + if(adexp.ne.adexp) adexp=1.0 + expfac=dexp(adexp) +#else + expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin) +#endif +cd print *,'j=',j,' expfac=',expfac + escloc_i=escloc_i+expfac + do k=1,3 + dersc(k)=dersc(k)+Ax(k,j,iii)*expfac + enddo + if (mixed) then + do k=1,3,2 + ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) + & +gaussc(k,2,j,it))*expfac + enddo + endif + enddo + + enddo ! iii + + dersc(1)=dersc(1)/cos(theti)**2 + ddersc(1)=ddersc(1)/cos(theti)**2 + ddersc(3)=ddersc(3) + + escloci=-(dlog(escloc_i)-emin) + do j=1,3 + dersc(j)=dersc(j)/escloc_i + enddo + if (mixed) then + do j=1,3,2 + ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j)) + enddo + endif + return + end +C------------------------------------------------------------------------------ + subroutine enesc_bound(x,escloci,dersc,dersc12,mixed) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /sccalc/ time11,time12,time112,theti,it,nlobit + double precision x(3),z(3),Ax(3,maxlob),dersc(3) + double precision contr(maxlob) + logical mixed + + escloc_i=0.0D0 + + do j=1,3 + dersc(j)=0.0D0 + enddo + + do j=1,nlobit + do k=1,2 + z(k)=x(k)-censc(k,j,it) + enddo + z(3)=dwapi + do k=1,3 + Axk=0.0D0 + do l=1,3 + Axk=Axk+gaussc(l,k,j,it)*z(l) + enddo + Ax(k,j)=Axk + enddo + expfac=0.0D0 + do k=1,3 + expfac=expfac+Ax(k,j)*z(k) + enddo + contr(j)=expfac + enddo ! j + +C As in the case of ebend, we want to avoid underflows in exponentiation and +C subsequent NaNs and INFs in energy calculation. +C Find the largest exponent + emin=contr(1) + do j=1,nlobit + if (emin.gt.contr(j)) emin=contr(j) + enddo + emin=0.5D0*emin + +C Compute the contribution to SC energy and derivatives + + dersc12=0.0d0 + do j=1,nlobit + expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin) + escloc_i=escloc_i+expfac + do k=1,2 + dersc(k)=dersc(k)+Ax(k,j)*expfac + enddo + if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) + & +gaussc(1,2,j,it))*expfac + dersc(3)=0.0d0 + enddo + + dersc(1)=dersc(1)/cos(theti)**2 + dersc12=dersc12/cos(theti)**2 + escloci=-(dlog(escloc_i)-emin) + do j=1,2 + dersc(j)=dersc(j)/escloc_i + enddo + if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1)) + return + end +#else +c---------------------------------------------------------------------------------- + subroutine esc(escloc) +C Calculate the local energy of a side chain and its derivatives in the +C corresponding virtual-bond valence angles THETA and the spherical angles +C ALPHA and OMEGA derived from AM1 all-atom calculations. +C added by Urszula Kozlowska. 07/11/2007 +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.VAR' + include 'COMMON.SCROT' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + include 'COMMON.VECTORS' + double precision x_prime(3),y_prime(3),z_prime(3) + & , sumene,dsc_i,dp2_i,x(65), + & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6, + & de_dxx,de_dyy,de_dzz,de_dt + double precision s1_t,s1_6_t,s2_t,s2_6_t + double precision + & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3), + & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3), + & dt_dCi(3),dt_dCi1(3) + common /sccalc/ time11,time12,time112,theti,it,nlobit + delta=0.02d0*pi + escloc=0.0D0 + do i=loc_start,loc_end + costtab(i+1) =dcos(theta(i+1)) + sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1)) + cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1))) + sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1))) + cosfac2=0.5d0/(1.0d0+costtab(i+1)) + cosfac=dsqrt(cosfac2) + sinfac2=0.5d0/(1.0d0-costtab(i+1)) + sinfac=dsqrt(sinfac2) + it=itype(i) + if (it.eq.10) goto 1 +c +C Compute the axes of tghe local cartesian coordinates system; store in +c x_prime, y_prime and z_prime +c + do j=1,3 + x_prime(j) = 0.00 + y_prime(j) = 0.00 + z_prime(j) = 0.00 + enddo +C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres), +C & dc_norm(3,i+nres) + do j = 1,3 + x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac + y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac + enddo + do j = 1,3 + z_prime(j) = -uz(j,i-1) + enddo +c write (2,*) "i",i +c write (2,*) "x_prime",(x_prime(j),j=1,3) +c write (2,*) "y_prime",(y_prime(j),j=1,3) +c write (2,*) "z_prime",(z_prime(j),j=1,3) +c write (2,*) "xx",scalar(x_prime(1),x_prime(1)), +c & " xy",scalar(x_prime(1),y_prime(1)), +c & " xz",scalar(x_prime(1),z_prime(1)), +c & " yy",scalar(y_prime(1),y_prime(1)), +c & " yz",scalar(y_prime(1),z_prime(1)), +c & " zz",scalar(z_prime(1),z_prime(1)) +c +C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i), +C to local coordinate system. Store in xx, yy, zz. +c + xx=0.0d0 + yy=0.0d0 + zz=0.0d0 + do j = 1,3 + xx = xx + x_prime(j)*dc_norm(j,i+nres) + yy = yy + y_prime(j)*dc_norm(j,i+nres) + zz = zz + z_prime(j)*dc_norm(j,i+nres) + enddo + + xxtab(i)=xx + yytab(i)=yy + zztab(i)=zz +C +C Compute the energy of the ith side cbain +C +c write (2,*) "xx",xx," yy",yy," zz",zz + it=itype(i) + do j = 1,65 + x(j) = sc_parmin(j,it) + enddo +#ifdef CHECK_COORD +Cc diagnostics - remove later + xx1 = dcos(alph(2)) + yy1 = dsin(alph(2))*dcos(omeg(2)) + zz1 = -dsin(alph(2))*dsin(omeg(2)) + write(2,'(3f8.1,3f9.3,1x,3f9.3)') + & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz, + & xx1,yy1,zz1 +C," --- ", xx_w,yy_w,zz_w +c end diagnostics +#endif + sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2 + & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy + & + x(10)*yy*zz + sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 + & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy + & + x(20)*yy*zz + sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 + & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy + & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 + & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx + & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy + & +x(40)*xx*yy*zz + sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 + & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy + & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 + & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx + & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy + & +x(60)*xx*yy*zz + dsc_i = 0.743d0+x(61) + dp2_i = 1.9d0+x(62) + dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i + & *(xx*cost2tab(i+1)+yy*sint2tab(i+1))) + dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i + & *(xx*cost2tab(i+1)-yy*sint2tab(i+1))) + s1=(1+x(63))/(0.1d0 + dscp1) + s1_6=(1+x(64))/(0.1d0 + dscp1**6) + s2=(1+x(65))/(0.1d0 + dscp2) + s2_6=(1+x(65))/(0.1d0 + dscp2**6) + sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) + & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6) +c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3, +c & sumene4, +c & dscp1,dscp2,sumene +c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + escloc = escloc + sumene +c write (2,*) "i",i," escloc",sumene,escloc +#ifdef DEBUG +C +C This section to check the numerical derivatives of the energy of ith side +C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert +C #define DEBUG in the code to turn it on. +C + write (2,*) "sumene =",sumene + aincr=1.0d-7 + xxsave=xx + xx=xx+aincr + write (2,*) xx,yy,zz + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dxx_num=(sumenep-sumene)/aincr + xx=xxsave + write (2,*) "xx+ sumene from enesc=",sumenep + yysave=yy + yy=yy+aincr + write (2,*) xx,yy,zz + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dyy_num=(sumenep-sumene)/aincr + yy=yysave + write (2,*) "yy+ sumene from enesc=",sumenep + zzsave=zz + zz=zz+aincr + write (2,*) xx,yy,zz + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dzz_num=(sumenep-sumene)/aincr + zz=zzsave + write (2,*) "zz+ sumene from enesc=",sumenep + costsave=cost2tab(i+1) + sintsave=sint2tab(i+1) + cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr)) + sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr)) + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dt_num=(sumenep-sumene)/aincr + write (2,*) " t+ sumene from enesc=",sumenep + cost2tab(i+1)=costsave + sint2tab(i+1)=sintsave +C End of diagnostics section. +#endif +C +C Compute the gradient of esc +C + pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2 + pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2 + pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2 + pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2 + pom_dx=dsc_i*dp2_i*cost2tab(i+1) + pom_dy=dsc_i*dp2_i*sint2tab(i+1) + pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1)) + pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1)) + pom1=(sumene3*sint2tab(i+1)+sumene1) + & *(pom_s1/dscp1+pom_s16*dscp1**4) + pom2=(sumene4*cost2tab(i+1)+sumene2) + & *(pom_s2/dscp2+pom_s26*dscp2**4) + sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy + sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 + & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) + & +x(40)*yy*zz + sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy + sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 + & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) + & +x(60)*yy*zz + de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) + & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) + & +(pom1+pom2)*pom_dx +#ifdef DEBUG + write(2,*), "de_dxx = ", de_dxx,de_dxx_num +#endif +C + sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz + sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 + & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) + & +x(40)*xx*zz + sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz + sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz + & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz + & +x(59)*zz**2 +x(60)*xx*zz + de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) + & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) + & +(pom1-pom2)*pom_dy +#ifdef DEBUG + write(2,*), "de_dyy = ", de_dyy,de_dyy_num +#endif +C + de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy + & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx + & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) + & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6) + & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2 + & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy + & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) + & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6) +#ifdef DEBUG + write(2,*), "de_dzz = ", de_dzz,de_dzz_num +#endif +C + de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) + & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) + & +pom1*pom_dt1+pom2*pom_dt2 +#ifdef DEBUG + write(2,*), "de_dt = ", de_dt,de_dt_num +#endif +c +C + cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres)) + cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres)) + cosfac2xx=cosfac2*xx + sinfac2yy=sinfac2*yy + do k = 1,3 + dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* + & vbld_inv(i+1) + dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* + & vbld_inv(i) + pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1) + pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i) +c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1, +c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k) +c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3), +c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i) + dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx + dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx + dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy + dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy + dZZ_Ci1(k)=0.0d0 + dZZ_Ci(k)=0.0d0 + do j=1,3 + dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres) + dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres) + enddo + + dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres)) + dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres)) + dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres)) +c + dt_dCi(k) = -dt_dCi(k)/sinttab(i+1) + dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1) + enddo + + do k=1,3 + dXX_Ctab(k,i)=dXX_Ci(k) + dXX_C1tab(k,i)=dXX_Ci1(k) + dYY_Ctab(k,i)=dYY_Ci(k) + dYY_C1tab(k,i)=dYY_Ci1(k) + dZZ_Ctab(k,i)=dZZ_Ci(k) + dZZ_C1tab(k,i)=dZZ_Ci1(k) + dXX_XYZtab(k,i)=dXX_XYZ(k) + dYY_XYZtab(k,i)=dYY_XYZ(k) + dZZ_XYZtab(k,i)=dZZ_XYZ(k) + enddo + + do k = 1,3 +c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1", +c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k) +c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci", +c & dyy_ci(k)," dzz_ci",dzz_ci(k) +c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci", +c & dt_dci(k) +c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ", +c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k) + gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) + & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k) + gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) + & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k) + gsclocx(k,i)= de_dxx*dxx_XYZ(k) + & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k) + enddo +c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3), +c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3) + +C to check gradient call subroutine check_grad + + 1 continue + enddo + return + end +c------------------------------------------------------------------------------ + double precision function enesc(x,xx,yy,zz,cost2,sint2) + implicit none + double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2, + & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6 + sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2 + & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy + & + x(10)*yy*zz + sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 + & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy + & + x(20)*yy*zz + sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 + & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy + & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 + & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx + & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy + & +x(40)*xx*yy*zz + sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 + & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy + & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 + & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx + & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy + & +x(60)*xx*yy*zz + dsc_i = 0.743d0+x(61) + dp2_i = 1.9d0+x(62) + dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i + & *(xx*cost2+yy*sint2)) + dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i + & *(xx*cost2-yy*sint2)) + s1=(1+x(63))/(0.1d0 + dscp1) + s1_6=(1+x(64))/(0.1d0 + dscp1**6) + s2=(1+x(65))/(0.1d0 + dscp2) + s2_6=(1+x(65))/(0.1d0 + dscp2**6) + sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) + & + (sumene4*cost2 +sumene2)*(s2+s2_6) + enesc=sumene + return + end +#endif +c------------------------------------------------------------------------------ + subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont) +C +C This procedure calculates two-body contact function g(rij) and its derivative: +C +C eps0ij ! x < -1 +C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1 +C 0 ! x > 1 +C +C where x=(rij-r0ij)/delta +C +C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy +C + implicit none + double precision rij,r0ij,eps0ij,fcont,fprimcont + double precision x,x2,x4,delta +c delta=0.02D0*r0ij +c delta=0.2D0*r0ij + x=(rij-r0ij)/delta + if (x.lt.-1.0D0) then + fcont=eps0ij + fprimcont=0.0D0 + else if (x.le.1.0D0) then + x2=x*x + x4=x2*x2 + fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0) + fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta + else + fcont=0.0D0 + fprimcont=0.0D0 + endif + return + end +c------------------------------------------------------------------------------ + subroutine splinthet(theti,delta,ss,ssder) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.GEO' + thetup=pi-delta + thetlow=delta + if (theti.gt.pipol) then + call gcont(theti,thetup,1.0d0,delta,ss,ssder) + else + call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder) + ssder=-ssder + endif + return + end +c------------------------------------------------------------------------------ + subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim) + implicit none + double precision x,x0,delta,f0,f1,fprim0,f,fprim + double precision ksi,ksi2,ksi3,a1,a2,a3 + a1=fprim0*delta/(f1-f0) + a2=3.0d0-2.0d0*a1 + a3=a1-2.0d0 + ksi=(x-x0)/delta + ksi2=ksi*ksi + ksi3=ksi2*ksi + f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi)) + fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3)) + return + end +c------------------------------------------------------------------------------ + subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx) + implicit none + double precision x,x0,delta,f0x,f1x,fprim0x,fx + double precision ksi,ksi2,ksi3,a1,a2,a3 + ksi=(x-x0)/delta + ksi2=ksi*ksi + ksi3=ksi2*ksi + a1=fprim0x*delta + a2=3*(f1x-f0x)-2*fprim0x*delta + a3=fprim0x*delta-2*(f1x-f0x) + fx=f0x+a1*ksi+a2*ksi2+a3*ksi3 + return + end +C----------------------------------------------------------------------------- +#ifdef CRYST_TOR +C----------------------------------------------------------------------------- + subroutine etor(etors,edihcnstr) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + include 'COMMON.CONTROL' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. + etors=0.0D0 + do i=iphi_start,iphi_end + etors_ii=0.0D0 + itori=itortyp(itype(i-2)) + itori1=itortyp(itype(i-1)) + phii=phi(i) + gloci=0.0D0 +C Proline-Proline pair is a special case... + if (itori.eq.3 .and. itori1.eq.3) then + if (phii.gt.-dwapi3) then + cosphi=dcos(3*phii) + fac=1.0D0/(1.0D0-cosphi) + etorsi=v1(1,3,3)*fac + etorsi=etorsi+etorsi + etors=etors+etorsi-v1(1,3,3) + if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3) + gloci=gloci-3*fac*etorsi*dsin(3*phii) + endif + do j=1,3 + v1ij=v1(j+1,itori,itori1) + v2ij=v2(j+1,itori,itori1) + cosphi=dcos(j*phii) + sinphi=dsin(j*phii) + etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) + if (energy_dec) etors_ii=etors_ii+ + & v2ij*sinphi+dabs(v1ij)+dabs(v2ij) + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo + else + do j=1,nterm_old + v1ij=v1(j,itori,itori1) + v2ij=v2(j,itori,itori1) + cosphi=dcos(j*phii) + sinphi=dsin(j*phii) + etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) + if (energy_dec) etors_ii=etors_ii+ + & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo + endif + if (energy_dec) write (iout,'(a6,i5,0pf7.3)') + & 'etor',i,etors_ii + if (lprn) + & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') + & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, + & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6) + gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci + write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) + enddo +! 6/20/98 - dihedral angle constraints + edihcnstr=0.0d0 + do i=1,ndih_constr + itori=idih_constr(i) + phii=phi(itori) + difi=phii-phi0(i) + if (difi.gt.drange(i)) then + difi=difi-drange(i) + edihcnstr=edihcnstr+0.25d0*ftors*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 + else if (difi.lt.-drange(i)) then + difi=difi+drange(i) + edihcnstr=edihcnstr+0.25d0*ftors*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 + endif +! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii, +! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) + enddo +! write (iout,*) 'edihcnstr',edihcnstr + return + end +c------------------------------------------------------------------------------ +c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA + subroutine e_modeller(ehomology_constr) + ehomology_constr=0.0 + write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!" + return + end +C !!!!!!!! NIE CZYTANE !!!!!!!!!!! + +c------------------------------------------------------------------------------ + subroutine etor_d(etors_d) + etors_d=0.0d0 + return + end +c---------------------------------------------------------------------------- +#else + subroutine etor(etors,edihcnstr) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + include 'COMMON.CONTROL' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. + etors=0.0D0 + do i=iphi_start,iphi_end + etors_ii=0.0D0 + itori=itortyp(itype(i-2)) + itori1=itortyp(itype(i-1)) + phii=phi(i) + gloci=0.0D0 +C Regular cosine and sine terms + do j=1,nterm(itori,itori1) + v1ij=v1(j,itori,itori1) + v2ij=v2(j,itori,itori1) + cosphi=dcos(j*phii) + sinphi=dsin(j*phii) + etors=etors+v1ij*cosphi+v2ij*sinphi + if (energy_dec) etors_ii=etors_ii+ + & v1ij*cosphi+v2ij*sinphi + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo +C Lorentz terms +C v1 +C E = SUM ----------------------------------- - v1 +C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1 +C + cosphi=dcos(0.5d0*phii) + sinphi=dsin(0.5d0*phii) + do j=1,nlor(itori,itori1) + vl1ij=vlor1(j,itori,itori1) + vl2ij=vlor2(j,itori,itori1) + vl3ij=vlor3(j,itori,itori1) + pom=vl2ij*cosphi+vl3ij*sinphi + pom1=1.0d0/(pom*pom+1.0d0) + etors=etors+vl1ij*pom1 + if (energy_dec) etors_ii=etors_ii+ + & vl1ij*pom1 + pom=-pom*pom1*pom1 + gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom + enddo +C Subtract the constant term + etors=etors-v0(itori,itori1) + if (energy_dec) write (iout,'(a6,i5,0pf7.3)') + & 'etor',i,etors_ii-v0(itori,itori1) + if (lprn) + & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') + & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, + & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6) + gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci +c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) + enddo +! 6/20/98 - dihedral angle constraints + edihcnstr=0.0d0 +c do i=1,ndih_constr + do i=idihconstr_start,idihconstr_end + itori=idih_constr(i) + phii=phi(itori) + difi=pinorm(phii-phi0(i)) + if (difi.gt.drange(i)) then + difi=difi-drange(i) + edihcnstr=edihcnstr+0.25d0*ftors*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 + else if (difi.lt.-drange(i)) then + difi=difi+drange(i) + edihcnstr=edihcnstr+0.25d0*ftors*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 + else + difi=0.0 + endif +c write (iout,*) "gloci", gloc(i-3,icg) +cd write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii, +cd & rad2deg*phi0(i), rad2deg*drange(i), +cd & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) + enddo +cd write (iout,*) 'edihcnstr',edihcnstr + return + end +c---------------------------------------------------------------------------- +c MODELLER restraint function + subroutine e_modeller(ehomology_constr) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + + integer nnn, i, j, k, ki, irec, l + integer katy, odleglosci, test7 + real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template) + real*8 distance(max_template),distancek(max_template), + & min_odl,godl(max_template),dih_diff(max_template) + + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + include 'COMMON.DERIV' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.MD' + include 'COMMON.CONTROL' + + + do i=1,19 + distancek(i)=9999999.9 + enddo + + + odleg=0.0d0 + +c Pseudo-energy and gradient from homology restraints (MODELLER-like +c function) +C AL 5/2/14 - Introduce list of restraints + do ii = link_start_homo,link_end_homo + i = ires_homo(ii) + j = jres_homo(ii) + dij=dist(i,j) + do k=1,constr_homology + distance(k)=odl(k,ii)-dij + distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii) + enddo + + min_odl=minval(distancek) +#ifdef DEBUG + write (iout,*) "ij dij",i,j,dij + write (iout,*) "distance",(distance(k),k=1,constr_homology) + write (iout,*) "distancek",(distancek(k),k=1,constr_homology) + write (iout,* )"min_odl",min_odl +#endif + odleg2=0.0d0 + do k=1,constr_homology +c Nie wiem po co to liczycie jeszcze raz! +c odleg3=-waga_dist*((distance(i,j,k)**2)/ +c & (2*(sigma_odl(i,j,k))**2)) + godl(k)=dexp(-distancek(k)+min_odl) + odleg2=odleg2+godl(k) + +ccc write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3, +ccc & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=", +ccc & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1), +ccc & "sigma_odl(i,j,k)=", sigma_odl(i,j,k) + + enddo +#ifdef DEBUG + write (iout,*) "godl",(godl(k),k=1,constr_homology) + write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 +#endif + odleg=odleg-dLOG(odleg2/constr_homology)+min_odl +c Gradient + sum_godl=odleg2 + sum_sgodl=0.0 + do k=1,constr_homology +c godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2)) +c & *waga_dist)+min_odl + sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist + sum_sgodl=sum_sgodl+sgodl + +c sgodl2=sgodl2+sgodl +c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1" +c write(iout,*) "constr_homology=",constr_homology +c write(iout,*) i, j, k, "TEST K" + enddo + + grad_odl3=sum_sgodl/(sum_godl*dij) + + +c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2" +c write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2), +c & (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2)) + +ccc write(iout,*) godl, sgodl, grad_odl3 + +c grad_odl=grad_odl+grad_odl3 + + do jik=1,3 + ggodl=grad_odl3*(c(jik,i)-c(jik,j)) +ccc write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1)) +ccc write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl, +ccc & ghpbc(jik,i+1), ghpbc(jik,j+1) + ghpbc(jik,i)=ghpbc(jik,i)+ggodl + ghpbc(jik,j)=ghpbc(jik,j)-ggodl +ccc write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl, +ccc & ghpbc(jik,i+1), ghpbc(jik,j+1) + + enddo +ccc write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=", +ccc & dLOG(odleg2),"-odleg=", -odleg + + enddo ! ii +c Pseudo-energy and gradient from dihedral-angle restraints from +c homology templates +c write (iout,*) "End of distance loop" +c call flush(iout) + kat=0.0d0 +c write (iout,*) idihconstr_start_homo,idihconstr_end_homo + do i=idihconstr_start_homo,idihconstr_end_homo + kat2=0.0d0 +c betai=beta(i,i+1,i+2,i+3) + betai = phi(i+3) + do k=1,constr_homology + dih_diff(k)=pinorm(dih(k,i)-betai) +c if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)= +c & -(6.28318-dih_diff(i,k)) +c if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)= +c & 6.28318+dih_diff(i,k) + + kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i) + gdih(k)=dexp(kat3) + kat2=kat2+gdih(k) +c write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3) +c write(*,*)"" + enddo +#ifdef DEBUG + write (iout,*) "i",i," betai",betai," kat2",kat2 + write (iout,*) "gdih",(gdih(k),k=1,constr_homology) +#endif + if (kat2.le.1.0d-14) cycle + kat=kat-dLOG(kat2/constr_homology) + +ccc write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=", +ccc & dLOG(kat2), "-kat=", -kat + +c ---------------------------------------------------------------------- +c Gradient +c ---------------------------------------------------------------------- + + sum_gdih=kat2 + sum_sgdih=0.0 + do k=1,constr_homology + sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle + sum_sgdih=sum_sgdih+sgdih + enddo + grad_dih3=sum_sgdih/sum_gdih + +c write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3 +ccc write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3, +ccc & gloc(nphi+i-3,icg) + gloc(i,icg)=gloc(i,icg)+grad_dih3 +ccc write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3, +ccc & gloc(nphi+i-3,icg) + + enddo + + +c Total energy from homology restraints +#ifdef DEBUG + write (iout,*) "odleg",odleg," kat",kat +#endif + ehomology_constr=odleg+kat + return + + 748 format(a8,f12.3,a6,f12.3,a7,f12.3) + 747 format(a12,i4,i4,i4,f8.3,f8.3) + 746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3) + 778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3) + 779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X, + & f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3) + end + +c------------------------------------------------------------------------------ + subroutine etor_d(etors_d) +C 6/23/01 Compute double torsional energy + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. + etors_d=0.0D0 + do i=iphid_start,iphid_end + itori=itortyp(itype(i-2)) + itori1=itortyp(itype(i-1)) + itori2=itortyp(itype(i)) + phii=phi(i) + phii1=phi(i+1) + gloci1=0.0D0 + gloci2=0.0D0 + do j=1,ntermd_1(itori,itori1,itori2) + v1cij=v1c(1,j,itori,itori1,itori2) + v1sij=v1s(1,j,itori,itori1,itori2) + v2cij=v1c(2,j,itori,itori1,itori2) + v2sij=v1s(2,j,itori,itori1,itori2) + cosphi1=dcos(j*phii) + sinphi1=dsin(j*phii) + cosphi2=dcos(j*phii1) + sinphi2=dsin(j*phii1) + etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ + & v2cij*cosphi2+v2sij*sinphi2 + gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1) + gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2) + enddo + do k=2,ntermd_2(itori,itori1,itori2) + do l=1,k-1 + v1cdij = v2c(k,l,itori,itori1,itori2) + v2cdij = v2c(l,k,itori,itori1,itori2) + v1sdij = v2s(k,l,itori,itori1,itori2) + v2sdij = v2s(l,k,itori,itori1,itori2) + cosphi1p2=dcos(l*phii+(k-l)*phii1) + cosphi1m2=dcos(l*phii-(k-l)*phii1) + sinphi1p2=dsin(l*phii+(k-l)*phii1) + sinphi1m2=dsin(l*phii-(k-l)*phii1) + etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ + & v1sdij*sinphi1p2+v2sdij*sinphi1m2 + gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 + & -v1cdij*sinphi1p2-v2cdij*sinphi1m2) + gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 + & -v1cdij*sinphi1p2+v2cdij*sinphi1m2) + enddo + enddo + gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1 + gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2 +c write (iout,*) "gloci", gloc(i-3,icg) + enddo + return + end +#endif +c------------------------------------------------------------------------------ + subroutine eback_sc_corr(esccor) +c 7/21/2007 Correlations between the backbone-local and side-chain-local +c conformational states; temporarily implemented as differences +c between UNRES torsional potentials (dependent on three types of +c residues) and the torsional potentials dependent on all 20 types +c of residues computed from AM1 energy surfaces of terminally-blocked +c amino-acid residues. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.SCCOR' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. +c write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor + esccor=0.0D0 + do i=itau_start,itau_end + esccor_ii=0.0D0 + isccori=isccortyp(itype(i-2)) + isccori1=isccortyp(itype(i-1)) + phii=phi(i) +cccc Added 9 May 2012 +cc Tauangle is torsional engle depending on the value of first digit +c(see comment below) +cc Omicron is flat angle depending on the value of first digit +c(see comment below) + + + do intertyp=1,3 !intertyp +cc Added 09 May 2012 (Adasko) +cc Intertyp means interaction type of backbone mainchain correlation: +c 1 = SC...Ca...Ca...Ca +c 2 = Ca...Ca...Ca...SC +c 3 = SC...Ca...Ca...SCi + gloci=0.0D0 + if (((intertyp.eq.3).and.((itype(i-2).eq.10).or. + & (itype(i-1).eq.10).or.(itype(i-2).eq.21).or. + & (itype(i-1).eq.21))) + & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10) + & .or.(itype(i-2).eq.21))) + & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or. + & (itype(i-1).eq.21)))) cycle + if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle + if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21)) + & cycle + do j=1,nterm_sccor(isccori,isccori1) + v1ij=v1sccor(j,intertyp,isccori,isccori1) + v2ij=v2sccor(j,intertyp,isccori,isccori1) + cosphi=dcos(j*tauangle(intertyp,i)) + sinphi=dsin(j*tauangle(intertyp,i)) + esccor=esccor+v1ij*cosphi+v2ij*sinphi + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo + gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci +c write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi +c &gloc_sc(intertyp,i-3,icg) + if (lprn) + & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') + & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, + & (v1sccor(j,intertyp,itori,itori1),j=1,6) + & ,(v2sccor(j,intertyp,itori,itori1),j=1,6) + gsccor_loc(i-3)=gsccor_loc(i-3)+gloci + enddo !intertyp + enddo +c do i=1,nres +c write (iout,*) "W@T@F", gloc_sc(1,i,icg),gloc(i,icg) +c enddo + return + end +c---------------------------------------------------------------------------- + subroutine multibody(ecorr) +C This subroutine calculates multi-body contributions to energy following +C the idea of Skolnick et al. If side chains I and J make a contact and +C at the same time side chains I+1 and J+1 make a contact, an extra +C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + double precision gx(3),gx1(3) + logical lprn + +C Set lprn=.true. for debugging + lprn=.false. + + if (lprn) then + write (iout,'(a)') 'Contact function values:' + do i=nnt,nct-2 + write (iout,'(i2,20(1x,i2,f10.5))') + & i,(jcont(j,i),facont(j,i),j=1,num_cont(i)) + enddo + endif + ecorr=0.0D0 + do i=nnt,nct + do j=1,3 + gradcorr(j,i)=0.0D0 + gradxorr(j,i)=0.0D0 + enddo + enddo + do i=nnt,nct-2 + + DO ISHIFT = 3,4 + + i1=i+ishift + num_conti=num_cont(i) + num_conti1=num_cont(i1) + do jj=1,num_conti + j=jcont(jj,i) + do kk=1,num_conti1 + j1=jcont(kk,i1) + if (j1.eq.j+ishift .or. j1.eq.j-ishift) then +cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1, +cd & ' ishift=',ishift +C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously. +C The system gains extra energy. + ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk) + endif ! j1==j+-ishift + enddo ! kk + enddo ! jj + + ENDDO ! ISHIFT + + enddo ! i + return + end +c------------------------------------------------------------------------------ + double precision function esccorr(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + double precision gx(3),gx1(3) + logical lprn + lprn=.false. + eij=facont(jj,i) + ekl=facont(kk,k) +cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl +C Calculate the multi-body contribution to energy. +C Calculate multi-body contributions to the gradient. +cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3), +cd & k,l,(gacont(m,kk,k),m=1,3) + do m=1,3 + gx(m) =ekl*gacont(m,jj,i) + gx1(m)=eij*gacont(m,kk,k) + gradxorr(m,i)=gradxorr(m,i)-gx(m) + gradxorr(m,j)=gradxorr(m,j)+gx(m) + gradxorr(m,k)=gradxorr(m,k)-gx1(m) + gradxorr(m,l)=gradxorr(m,l)+gx1(m) + enddo + do m=i,j-1 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+gx(ll) + enddo + enddo + do m=k,l-1 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll) + enddo + enddo + esccorr=-eij*ekl + return + end +c------------------------------------------------------------------------------ + subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) +C This subroutine calculates multi-body contributions to hydrogen-bonding + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' +#ifdef MPI + include "mpif.h" + parameter (max_cont=maxconts) + parameter (max_dim=26) + integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error + double precision zapas(max_dim,maxconts,max_fg_procs), + & zapas_recv(max_dim,maxconts,max_fg_procs) + common /przechowalnia/ zapas + integer status(MPI_STATUS_SIZE),req(maxconts*2), + & status_array(MPI_STATUS_SIZE,maxconts*2) +#endif + include 'COMMON.SETUP' + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTROL' + include 'COMMON.LOCAL' + double precision gx(3),gx1(3),time00 + logical lprn,ldone + +C Set lprn=.true. for debugging + lprn=.false. +#ifdef MPI + n_corr=0 + n_corr1=0 + if (nfgtasks.le.1) goto 30 + if (lprn) then + write (iout,'(a)') 'Contact function values before RECEIVE:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i2,f5.2))') + & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), + & j=1,num_cont_hb(i)) + enddo + endif + call flush(iout) + do i=1,ntask_cont_from + ncont_recv(i)=0 + enddo + do i=1,ntask_cont_to + ncont_sent(i)=0 + enddo +c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to", +c & ntask_cont_to +C Make the list of contacts to send to send to other procesors +c write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end +c call flush(iout) + do i=iturn3_start,iturn3_end +c write (iout,*) "make contact list turn3",i," num_cont", +c & num_cont_hb(i) + call add_hb_contact(i,i+2,iturn3_sent_local(1,i)) + enddo + do i=iturn4_start,iturn4_end +c write (iout,*) "make contact list turn4",i," num_cont", +c & num_cont_hb(i) + call add_hb_contact(i,i+3,iturn4_sent_local(1,i)) + enddo + do ii=1,nat_sent + i=iat_sent(ii) +c write (iout,*) "make contact list longrange",i,ii," num_cont", +c & num_cont_hb(i) + do j=1,num_cont_hb(i) + do k=1,4 + jjc=jcont_hb(j,i) + iproc=iint_sent_local(k,jjc,ii) +c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc + if (iproc.gt.0) then + ncont_sent(iproc)=ncont_sent(iproc)+1 + nn=ncont_sent(iproc) + zapas(1,nn,iproc)=i + zapas(2,nn,iproc)=jjc + zapas(3,nn,iproc)=facont_hb(j,i) + zapas(4,nn,iproc)=ees0p(j,i) + zapas(5,nn,iproc)=ees0m(j,i) + zapas(6,nn,iproc)=gacont_hbr(1,j,i) + zapas(7,nn,iproc)=gacont_hbr(2,j,i) + zapas(8,nn,iproc)=gacont_hbr(3,j,i) + zapas(9,nn,iproc)=gacontm_hb1(1,j,i) + zapas(10,nn,iproc)=gacontm_hb1(2,j,i) + zapas(11,nn,iproc)=gacontm_hb1(3,j,i) + zapas(12,nn,iproc)=gacontp_hb1(1,j,i) + zapas(13,nn,iproc)=gacontp_hb1(2,j,i) + zapas(14,nn,iproc)=gacontp_hb1(3,j,i) + zapas(15,nn,iproc)=gacontm_hb2(1,j,i) + zapas(16,nn,iproc)=gacontm_hb2(2,j,i) + zapas(17,nn,iproc)=gacontm_hb2(3,j,i) + zapas(18,nn,iproc)=gacontp_hb2(1,j,i) + zapas(19,nn,iproc)=gacontp_hb2(2,j,i) + zapas(20,nn,iproc)=gacontp_hb2(3,j,i) + zapas(21,nn,iproc)=gacontm_hb3(1,j,i) + zapas(22,nn,iproc)=gacontm_hb3(2,j,i) + zapas(23,nn,iproc)=gacontm_hb3(3,j,i) + zapas(24,nn,iproc)=gacontp_hb3(1,j,i) + zapas(25,nn,iproc)=gacontp_hb3(2,j,i) + zapas(26,nn,iproc)=gacontp_hb3(3,j,i) + endif + enddo + enddo + enddo + if (lprn) then + write (iout,*) + & "Numbers of contacts to be sent to other processors", + & (ncont_sent(i),i=1,ntask_cont_to) + write (iout,*) "Contacts sent" + do ii=1,ntask_cont_to + nn=ncont_sent(ii) + iproc=itask_cont_to(ii) + write (iout,*) nn," contacts to processor",iproc, + & " of CONT_TO_COMM group" + do i=1,nn + write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) + enddo + enddo + call flush(iout) + endif + CorrelType=477 + CorrelID=fg_rank+1 + CorrelType1=478 + CorrelID1=nfgtasks+fg_rank+1 + ireq=0 +C Receive the numbers of needed contacts from other processors + do ii=1,ntask_cont_from + iproc=itask_cont_from(ii) + ireq=ireq+1 + call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType, + & FG_COMM,req(ireq),IERR) + enddo +c write (iout,*) "IRECV ended" +c call flush(iout) +C Send the number of contacts needed by other processors + do ii=1,ntask_cont_to + iproc=itask_cont_to(ii) + ireq=ireq+1 + call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType, + & FG_COMM,req(ireq),IERR) + enddo +c write (iout,*) "ISEND ended" +c write (iout,*) "number of requests (nn)",ireq + call flush(iout) + if (ireq.gt.0) + & call MPI_Waitall(ireq,req,status_array,ierr) +c write (iout,*) +c & "Numbers of contacts to be received from other processors", +c & (ncont_recv(i),i=1,ntask_cont_from) +c call flush(iout) +C Receive contacts + ireq=0 + do ii=1,ntask_cont_from + iproc=itask_cont_from(ii) + nn=ncont_recv(ii) +c write (iout,*) "Receiving",nn," contacts from processor",iproc, +c & " of CONT_TO_COMM group" + call flush(iout) + if (nn.gt.0) then + ireq=ireq+1 + call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim, + & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR) +c write (iout,*) "ireq,req",ireq,req(ireq) + endif + enddo +C Send the contacts to processors that need them + do ii=1,ntask_cont_to + iproc=itask_cont_to(ii) + nn=ncont_sent(ii) +c write (iout,*) nn," contacts to processor",iproc, +c & " of CONT_TO_COMM group" + if (nn.gt.0) then + ireq=ireq+1 + call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION, + & iproc,CorrelType1,FG_COMM,req(ireq),IERR) +c write (iout,*) "ireq,req",ireq,req(ireq) +c do i=1,nn +c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) +c enddo + endif + enddo +c write (iout,*) "number of requests (contacts)",ireq +c write (iout,*) "req",(req(i),i=1,4) +c call flush(iout) + if (ireq.gt.0) + & call MPI_Waitall(ireq,req,status_array,ierr) + do iii=1,ntask_cont_from + iproc=itask_cont_from(iii) + nn=ncont_recv(iii) + if (lprn) then + write (iout,*) "Received",nn," contacts from processor",iproc, + & " of CONT_FROM_COMM group" + call flush(iout) + do i=1,nn + write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5) + enddo + call flush(iout) + endif + do i=1,nn + ii=zapas_recv(1,i,iii) +c Flag the received contacts to prevent double-counting + jj=-zapas_recv(2,i,iii) +c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj +c call flush(iout) + nnn=num_cont_hb(ii)+1 + num_cont_hb(ii)=nnn + jcont_hb(nnn,ii)=jj + facont_hb(nnn,ii)=zapas_recv(3,i,iii) + ees0p(nnn,ii)=zapas_recv(4,i,iii) + ees0m(nnn,ii)=zapas_recv(5,i,iii) + gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii) + gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii) + gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii) + gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii) + gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii) + gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii) + gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii) + gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii) + gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii) + gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii) + gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii) + gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii) + gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii) + gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii) + gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii) + gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii) + gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii) + gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii) + gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii) + gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii) + gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii) + enddo + enddo + call flush(iout) + if (lprn) then + write (iout,'(a)') 'Contact function values after receive:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i3,f5.2))') + & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), + & j=1,num_cont_hb(i)) + enddo + call flush(iout) + endif + 30 continue +#endif + if (lprn) then + write (iout,'(a)') 'Contact function values:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i3,f5.2))') + & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), + & j=1,num_cont_hb(i)) + enddo + endif + ecorr=0.0D0 +C Remove the loop below after debugging !!! + do i=nnt,nct + do j=1,3 + gradcorr(j,i)=0.0D0 + gradxorr(j,i)=0.0D0 + enddo + enddo +C Calculate the local-electrostatic correlation terms + do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end) + i1=i+1 + num_conti=num_cont_hb(i) + num_conti1=num_cont_hb(i+1) + do jj=1,num_conti + j=jcont_hb(jj,i) + jp=iabs(j) + do kk=1,num_conti1 + j1=jcont_hb(kk,i1) + jp1=iabs(j1) +c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk + if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 + & .or. j.lt.0 .and. j1.gt.0) .and. + & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then +C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. +C The system gains extra energy. + ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0) + if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') + & 'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0) + n_corr=n_corr+1 + else if (j1.eq.j) then +C Contacts I-J and I-(J+1) occur simultaneously. +C The system loses extra energy. +c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0) + endif + enddo ! kk + do kk=1,num_conti + j1=jcont_hb(kk,i) +c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk + if (j1.eq.j+1) then +C Contacts I-J and (I+1)-J occur simultaneously. +C The system loses extra energy. +c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0) + endif ! j1==j+1 + enddo ! kk + enddo ! jj + enddo ! i + return + end +c------------------------------------------------------------------------------ + subroutine add_hb_contact(ii,jj,itask) + implicit real*8 (a-h,o-z) + include "DIMENSIONS" + include "COMMON.IOUNITS" + integer max_cont + integer max_dim + parameter (max_cont=maxconts) + parameter (max_dim=26) + include "COMMON.CONTACTS" + double precision zapas(max_dim,maxconts,max_fg_procs), + & zapas_recv(max_dim,maxconts,max_fg_procs) + common /przechowalnia/ zapas + integer i,j,ii,jj,iproc,itask(4),nn +c write (iout,*) "itask",itask + do i=1,2 + iproc=itask(i) + if (iproc.gt.0) then + do j=1,num_cont_hb(ii) + jjc=jcont_hb(j,ii) +c write (iout,*) "i",ii," j",jj," jjc",jjc + if (jjc.eq.jj) then + ncont_sent(iproc)=ncont_sent(iproc)+1 + nn=ncont_sent(iproc) + zapas(1,nn,iproc)=ii + zapas(2,nn,iproc)=jjc + zapas(3,nn,iproc)=facont_hb(j,ii) + zapas(4,nn,iproc)=ees0p(j,ii) + zapas(5,nn,iproc)=ees0m(j,ii) + zapas(6,nn,iproc)=gacont_hbr(1,j,ii) + zapas(7,nn,iproc)=gacont_hbr(2,j,ii) + zapas(8,nn,iproc)=gacont_hbr(3,j,ii) + zapas(9,nn,iproc)=gacontm_hb1(1,j,ii) + zapas(10,nn,iproc)=gacontm_hb1(2,j,ii) + zapas(11,nn,iproc)=gacontm_hb1(3,j,ii) + zapas(12,nn,iproc)=gacontp_hb1(1,j,ii) + zapas(13,nn,iproc)=gacontp_hb1(2,j,ii) + zapas(14,nn,iproc)=gacontp_hb1(3,j,ii) + zapas(15,nn,iproc)=gacontm_hb2(1,j,ii) + zapas(16,nn,iproc)=gacontm_hb2(2,j,ii) + zapas(17,nn,iproc)=gacontm_hb2(3,j,ii) + zapas(18,nn,iproc)=gacontp_hb2(1,j,ii) + zapas(19,nn,iproc)=gacontp_hb2(2,j,ii) + zapas(20,nn,iproc)=gacontp_hb2(3,j,ii) + zapas(21,nn,iproc)=gacontm_hb3(1,j,ii) + zapas(22,nn,iproc)=gacontm_hb3(2,j,ii) + zapas(23,nn,iproc)=gacontm_hb3(3,j,ii) + zapas(24,nn,iproc)=gacontp_hb3(1,j,ii) + zapas(25,nn,iproc)=gacontp_hb3(2,j,ii) + zapas(26,nn,iproc)=gacontp_hb3(3,j,ii) + exit + endif + enddo + endif + enddo + return + end +c------------------------------------------------------------------------------ + subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr, + & n_corr1) +C This subroutine calculates multi-body contributions to hydrogen-bonding + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' +#ifdef MPI + include "mpif.h" + parameter (max_cont=maxconts) + parameter (max_dim=70) + integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error + double precision zapas(max_dim,maxconts,max_fg_procs), + & zapas_recv(max_dim,maxconts,max_fg_procs) + common /przechowalnia/ zapas + integer status(MPI_STATUS_SIZE),req(maxconts*2), + & status_array(MPI_STATUS_SIZE,maxconts*2) +#endif + include 'COMMON.SETUP' + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CHAIN' + include 'COMMON.CONTROL' + double precision gx(3),gx1(3) + integer num_cont_hb_old(maxres) + logical lprn,ldone + double precision eello4,eello5,eelo6,eello_turn6 + external eello4,eello5,eello6,eello_turn6 +C Set lprn=.true. for debugging + lprn=.false. + eturn6=0.0d0 +#ifdef MPI + do i=1,nres + num_cont_hb_old(i)=num_cont_hb(i) + enddo + n_corr=0 + n_corr1=0 + if (nfgtasks.le.1) goto 30 + if (lprn) then + write (iout,'(a)') 'Contact function values before RECEIVE:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i2,f5.2))') + & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), + & j=1,num_cont_hb(i)) + enddo + endif + call flush(iout) + do i=1,ntask_cont_from + ncont_recv(i)=0 + enddo + do i=1,ntask_cont_to + ncont_sent(i)=0 + enddo +c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to", +c & ntask_cont_to +C Make the list of contacts to send to send to other procesors + do i=iturn3_start,iturn3_end +c write (iout,*) "make contact list turn3",i," num_cont", +c & num_cont_hb(i) + call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i)) + enddo + do i=iturn4_start,iturn4_end +c write (iout,*) "make contact list turn4",i," num_cont", +c & num_cont_hb(i) + call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i)) + enddo + do ii=1,nat_sent + i=iat_sent(ii) +c write (iout,*) "make contact list longrange",i,ii," num_cont", +c & num_cont_hb(i) + do j=1,num_cont_hb(i) + do k=1,4 + jjc=jcont_hb(j,i) + iproc=iint_sent_local(k,jjc,ii) +c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc + if (iproc.ne.0) then + ncont_sent(iproc)=ncont_sent(iproc)+1 + nn=ncont_sent(iproc) + zapas(1,nn,iproc)=i + zapas(2,nn,iproc)=jjc + zapas(3,nn,iproc)=d_cont(j,i) + ind=3 + do kk=1,3 + ind=ind+1 + zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i) + enddo + do kk=1,2 + do ll=1,2 + ind=ind+1 + zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i) + enddo + enddo + do jj=1,5 + do kk=1,3 + do ll=1,2 + do mm=1,2 + ind=ind+1 + zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i) + enddo + enddo + enddo + enddo + endif + enddo + enddo + enddo + if (lprn) then + write (iout,*) + & "Numbers of contacts to be sent to other processors", + & (ncont_sent(i),i=1,ntask_cont_to) + write (iout,*) "Contacts sent" + do ii=1,ntask_cont_to + nn=ncont_sent(ii) + iproc=itask_cont_to(ii) + write (iout,*) nn," contacts to processor",iproc, + & " of CONT_TO_COMM group" + do i=1,nn + write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10) + enddo + enddo + call flush(iout) + endif + CorrelType=477 + CorrelID=fg_rank+1 + CorrelType1=478 + CorrelID1=nfgtasks+fg_rank+1 + ireq=0 +C Receive the numbers of needed contacts from other processors + do ii=1,ntask_cont_from + iproc=itask_cont_from(ii) + ireq=ireq+1 + call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType, + & FG_COMM,req(ireq),IERR) + enddo +c write (iout,*) "IRECV ended" +c call flush(iout) +C Send the number of contacts needed by other processors + do ii=1,ntask_cont_to + iproc=itask_cont_to(ii) + ireq=ireq+1 + call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType, + & FG_COMM,req(ireq),IERR) + enddo +c write (iout,*) "ISEND ended" +c write (iout,*) "number of requests (nn)",ireq + call flush(iout) + if (ireq.gt.0) + & call MPI_Waitall(ireq,req,status_array,ierr) +c write (iout,*) +c & "Numbers of contacts to be received from other processors", +c & (ncont_recv(i),i=1,ntask_cont_from) +c call flush(iout) +C Receive contacts + ireq=0 + do ii=1,ntask_cont_from + iproc=itask_cont_from(ii) + nn=ncont_recv(ii) +c write (iout,*) "Receiving",nn," contacts from processor",iproc, +c & " of CONT_TO_COMM group" + call flush(iout) + if (nn.gt.0) then + ireq=ireq+1 + call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim, + & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR) +c write (iout,*) "ireq,req",ireq,req(ireq) + endif + enddo +C Send the contacts to processors that need them + do ii=1,ntask_cont_to + iproc=itask_cont_to(ii) + nn=ncont_sent(ii) +c write (iout,*) nn," contacts to processor",iproc, +c & " of CONT_TO_COMM group" + if (nn.gt.0) then + ireq=ireq+1 + call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION, + & iproc,CorrelType1,FG_COMM,req(ireq),IERR) +c write (iout,*) "ireq,req",ireq,req(ireq) +c do i=1,nn +c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) +c enddo + endif + enddo +c write (iout,*) "number of requests (contacts)",ireq +c write (iout,*) "req",(req(i),i=1,4) +c call flush(iout) + if (ireq.gt.0) + & call MPI_Waitall(ireq,req,status_array,ierr) + do iii=1,ntask_cont_from + iproc=itask_cont_from(iii) + nn=ncont_recv(iii) + if (lprn) then + write (iout,*) "Received",nn," contacts from processor",iproc, + & " of CONT_FROM_COMM group" + call flush(iout) + do i=1,nn + write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10) + enddo + call flush(iout) + endif + do i=1,nn + ii=zapas_recv(1,i,iii) +c Flag the received contacts to prevent double-counting + jj=-zapas_recv(2,i,iii) +c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj +c call flush(iout) + nnn=num_cont_hb(ii)+1 + num_cont_hb(ii)=nnn + jcont_hb(nnn,ii)=jj + d_cont(nnn,ii)=zapas_recv(3,i,iii) + ind=3 + do kk=1,3 + ind=ind+1 + grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii) + enddo + do kk=1,2 + do ll=1,2 + ind=ind+1 + a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii) + enddo + enddo + do jj=1,5 + do kk=1,3 + do ll=1,2 + do mm=1,2 + ind=ind+1 + a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii) + enddo + enddo + enddo + enddo + enddo + enddo + call flush(iout) + if (lprn) then + write (iout,'(a)') 'Contact function values after receive:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i3,5f6.3))') + & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i), + & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i)) + enddo + call flush(iout) + endif + 30 continue +#endif + if (lprn) then + write (iout,'(a)') 'Contact function values:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i2,5f6.3))') + & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i), + & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i)) + enddo + endif + ecorr=0.0D0 + ecorr5=0.0d0 + ecorr6=0.0d0 +C Remove the loop below after debugging !!! + do i=nnt,nct + do j=1,3 + gradcorr(j,i)=0.0D0 + gradxorr(j,i)=0.0D0 + enddo + enddo +C Calculate the dipole-dipole interaction energies + if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then + do i=iatel_s,iatel_e+1 + num_conti=num_cont_hb(i) + do jj=1,num_conti + j=jcont_hb(jj,i) +#ifdef MOMENT + call dipole(i,j,jj) +#endif + enddo + enddo + endif +C Calculate the local-electrostatic correlation terms +c write (iout,*) "gradcorr5 in eello5 before loop" +c do iii=1,nres +c write (iout,'(i5,3f10.5)') +c & iii,(gradcorr5(jjj,iii),jjj=1,3) +c enddo + do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1) +c write (iout,*) "corr loop i",i + i1=i+1 + num_conti=num_cont_hb(i) + num_conti1=num_cont_hb(i+1) + do jj=1,num_conti + j=jcont_hb(jj,i) + jp=iabs(j) + do kk=1,num_conti1 + j1=jcont_hb(kk,i1) + jp1=iabs(j1) +c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk +c if (j1.eq.j+1 .or. j1.eq.j-1) then + if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 + & .or. j.lt.0 .and. j1.gt.0) .and. + & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then +C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. +C The system gains extra energy. + n_corr=n_corr+1 + sqd1=dsqrt(d_cont(jj,i)) + sqd2=dsqrt(d_cont(kk,i1)) + sred_geom = sqd1*sqd2 + IF (sred_geom.lt.cutoff_corr) THEN + call gcont(sred_geom,r0_corr,1.0D0,delt_corr, + & ekont,fprimcont) +cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1, +cd & ' jj=',jj,' kk=',kk + fac_prim1=0.5d0*sqd2/sqd1*fprimcont + fac_prim2=0.5d0*sqd1/sqd2*fprimcont + do l=1,3 + g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i) + g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1) + enddo + n_corr1=n_corr1+1 +cd write (iout,*) 'sred_geom=',sred_geom, +cd & ' ekont=',ekont,' fprim=',fprimcont, +cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2 +cd write (iout,*) "g_contij",g_contij +cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i) +cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1) + call calc_eello(i,jp,i+1,jp1,jj,kk) + if (wcorr4.gt.0.0d0) + & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk) + if (energy_dec.and.wcorr4.gt.0.0d0) + 1 write (iout,'(a6,4i5,0pf7.3)') + 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk) +c write (iout,*) "gradcorr5 before eello5" +c do iii=1,nres +c write (iout,'(i5,3f10.5)') +c & iii,(gradcorr5(jjj,iii),jjj=1,3) +c enddo + if (wcorr5.gt.0.0d0) + & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk) +c write (iout,*) "gradcorr5 after eello5" +c do iii=1,nres +c write (iout,'(i5,3f10.5)') +c & iii,(gradcorr5(jjj,iii),jjj=1,3) +c enddo + if (energy_dec.and.wcorr5.gt.0.0d0) + 1 write (iout,'(a6,4i5,0pf7.3)') + 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk) +cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6 +cd write(2,*)'ijkl',i,jp,i+1,jp1 + if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 + & .or. wturn6.eq.0.0d0))then +cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1 + ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk) + if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') + 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk) +cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5, +cd & 'ecorr6=',ecorr6 +cd write (iout,'(4e15.5)') sred_geom, +cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)), +cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)), +cd & dabs(eello6(i,jp,i+1,jp1,jj,kk)) + else if (wturn6.gt.0.0d0 + & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then +cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1 + eturn6=eturn6+eello_turn6(i,jj,kk) + if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') + 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk) +cd write (2,*) 'multibody_eello:eturn6',eturn6 + endif + ENDIF +1111 continue + endif + enddo ! kk + enddo ! jj + enddo ! i + do i=1,nres + num_cont_hb(i)=num_cont_hb_old(i) + enddo +c write (iout,*) "gradcorr5 in eello5" +c do iii=1,nres +c write (iout,'(i5,3f10.5)') +c & iii,(gradcorr5(jjj,iii),jjj=1,3) +c enddo + return + end +c------------------------------------------------------------------------------ + subroutine add_hb_contact_eello(ii,jj,itask) + implicit real*8 (a-h,o-z) + include "DIMENSIONS" + include "COMMON.IOUNITS" + integer max_cont + integer max_dim + parameter (max_cont=maxconts) + parameter (max_dim=70) + include "COMMON.CONTACTS" + double precision zapas(max_dim,maxconts,max_fg_procs), + & zapas_recv(max_dim,maxconts,max_fg_procs) + common /przechowalnia/ zapas + integer i,j,ii,jj,iproc,itask(4),nn +c write (iout,*) "itask",itask + do i=1,2 + iproc=itask(i) + if (iproc.gt.0) then + do j=1,num_cont_hb(ii) + jjc=jcont_hb(j,ii) +c write (iout,*) "send turns i",ii," j",jj," jjc",jjc + if (jjc.eq.jj) then + ncont_sent(iproc)=ncont_sent(iproc)+1 + nn=ncont_sent(iproc) + zapas(1,nn,iproc)=ii + zapas(2,nn,iproc)=jjc + zapas(3,nn,iproc)=d_cont(j,ii) + ind=3 + do kk=1,3 + ind=ind+1 + zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii) + enddo + do kk=1,2 + do ll=1,2 + ind=ind+1 + zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii) + enddo + enddo + do jj=1,5 + do kk=1,3 + do ll=1,2 + do mm=1,2 + ind=ind+1 + zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii) + enddo + enddo + enddo + enddo + exit + endif + enddo + endif + enddo + return + end +c------------------------------------------------------------------------------ + double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + double precision gx(3),gx1(3) + logical lprn + lprn=.false. + eij=facont_hb(jj,i) + ekl=facont_hb(kk,k) + ees0pij=ees0p(jj,i) + ees0pkl=ees0p(kk,k) + ees0mij=ees0m(jj,i) + ees0mkl=ees0m(kk,k) + ekont=eij*ekl + ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl) +cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl) +C Following 4 lines for diagnostics. +cd ees0pkl=0.0D0 +cd ees0pij=1.0D0 +cd ees0mkl=0.0D0 +cd ees0mij=1.0D0 +c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)') +c & 'Contacts ',i,j, +c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l +c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees, +c & 'gradcorr_long' +C Calculate the multi-body contribution to energy. +c ecorr=ecorr+ekont*ees +C Calculate multi-body contributions to the gradient. + coeffpees0pij=coeffp*ees0pij + coeffmees0mij=coeffm*ees0mij + coeffpees0pkl=coeffp*ees0pkl + coeffmees0mkl=coeffm*ees0mkl + do ll=1,3 +cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i) + gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi + & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ + & coeffmees0mkl*gacontm_hb1(ll,jj,i)) + gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi + & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ + & coeffmees0mkl*gacontm_hb2(ll,jj,i)) +cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k) + gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk + & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ + & coeffmees0mij*gacontm_hb1(ll,kk,k)) + gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk + & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ + & coeffmees0mij*gacontm_hb2(ll,kk,k)) + gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- + & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ + & coeffmees0mkl*gacontm_hb3(ll,jj,i)) + gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij + gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij + gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- + & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ + & coeffmees0mij*gacontm_hb3(ll,kk,k)) + gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl + gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl +c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl + enddo +c write (iout,*) +cgrad do m=i+1,j-1 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ +cgrad & ees*ekl*gacont_hbr(ll,jj,i)- +cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+ +cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i)) +cgrad enddo +cgrad enddo +cgrad do m=k+1,l-1 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ +cgrad & ees*eij*gacont_hbr(ll,kk,k)- +cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+ +cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k)) +cgrad enddo +cgrad enddo +c write (iout,*) "ehbcorr",ekont*ees + ehbcorr=ekont*ees + return + end +#ifdef MOMENT +C--------------------------------------------------------------------------- + subroutine dipole(i,j,jj) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2), + & auxmat(2,2) + iti1 = itortyp(itype(i+1)) + if (j.lt.nres-1) then + itj1 = itortyp(itype(j+1)) + else + itj1=ntortyp+1 + endif + do iii=1,2 + dipi(iii,1)=Ub2(iii,i) + dipderi(iii)=Ub2der(iii,i) + dipi(iii,2)=b1(iii,iti1) + dipj(iii,1)=Ub2(iii,j) + dipderj(iii)=Ub2der(iii,j) + dipj(iii,2)=b1(iii,itj1) + enddo + kkk=0 + do iii=1,2 + call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1)) + do jjj=1,2 + kkk=kkk+1 + dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) + enddo + enddo + do kkk=1,5 + do lll=1,3 + mmm=0 + do iii=1,2 + call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii), + & auxvec(1)) + do jjj=1,2 + mmm=mmm+1 + dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) + enddo + enddo + enddo + enddo + call transpose2(a_chuj(1,1,jj,i),auxmat(1,1)) + call matvec2(auxmat(1,1),dipderi(1),auxvec(1)) + do iii=1,2 + dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii)) + enddo + call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1)) + do iii=1,2 + dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii)) + enddo + return + end +#endif +C--------------------------------------------------------------------------- + subroutine calc_eello(i,j,k,l,jj,kk) +C +C This subroutine computes matrices and vectors needed to calculate +C the fourth-, fifth-, and sixth-order local-electrostatic terms. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.FFIELD' + double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2), + & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2) + logical lprn + common /kutas/ lprn +cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l, +cd & ' jj=',jj,' kk=',kk +cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return +cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2) +cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2) + do iii=1,2 + do jjj=1,2 + aa1(iii,jjj)=a_chuj(iii,jjj,jj,i) + aa2(iii,jjj)=a_chuj(iii,jjj,kk,k) + enddo + enddo + call transpose2(aa1(1,1),aa1t(1,1)) + call transpose2(aa2(1,1),aa2t(1,1)) + do kkk=1,5 + do lll=1,3 + call transpose2(a_chuj_der(1,1,lll,kkk,jj,i), + & aa1tder(1,1,lll,kkk)) + call transpose2(a_chuj_der(1,1,lll,kkk,kk,k), + & aa2tder(1,1,lll,kkk)) + enddo + enddo + if (l.eq.j+1) then +C parallel orientation of the two CA-CA-CA frames. + if (i.gt.1) then + iti=itortyp(itype(i)) + else + iti=ntortyp+1 + endif + itk1=itortyp(itype(k+1)) + itj=itortyp(itype(j)) + if (l.lt.nres-1) then + itl1=itortyp(itype(l+1)) + else + itl1=ntortyp+1 + endif +C A1 kernel(j+1) A2T +cd do iii=1,2 +cd write (iout,'(3f10.5,5x,3f10.5)') +cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2) +cd enddo + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l), + & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0) THEN + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l), + & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l), + & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1), + & ADtEAderx(1,1,1,1,1,1)) + lprn=.false. + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l), + & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), + & ADtEA1derx(1,1,1,1,1,1)) + ENDIF +C End 6-th order cumulants +cd lprn=.false. +cd if (lprn) then +cd write (2,*) 'In calc_eello6' +cd do iii=1,2 +cd write (2,*) 'iii=',iii +cd do kkk=1,5 +cd write (2,*) 'kkk=',kkk +cd do jjj=1,2 +cd write (2,'(3(2f10.5),5x)') +cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) +cd enddo +cd enddo +cd enddo +cd endif + call transpose2(EUgder(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) + call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), + & EAEAderx(1,1,lll,kkk,iii,1)) + enddo + enddo + enddo +C A1T kernel(i+1) A2 + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k), + & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0) THEN + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k), + & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k), + & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), + & ADtEAderx(1,1,1,1,1,2)) + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k), + & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), + & ADtEA1derx(1,1,1,1,1,2)) + ENDIF +C End 6-th order cumulants + call transpose2(EUgder(1,1,l),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2)) + call transpose2(EUg(1,1,l),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & EAEAderx(1,1,lll,kkk,iii,2)) + enddo + enddo + enddo +C AEAb1 and AEAb2 +C Calculate the vectors and their derivatives in virtual-bond dihedral angles. +C They are needed only when the fifth- or the sixth-order cumulants are +C indluded. + IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN + call transpose2(AEA(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1)) + call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1)) + call transpose2(AEAderg(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1)) + call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1)) + call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1)) + call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1)) + call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1)) + call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1)) + call transpose2(AEA(1,1,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2)) + call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2)) + call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2)) + call transpose2(AEAderg(1,1,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2)) + call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2)) + call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2)) + call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2)) + call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2)) + call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2)) + call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2)) +C Calculate the Cartesian derivatives of the vectors. + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti), + & AEAb1derx(1,lll,kkk,iii,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i), + & AEAb2derx(1,lll,kkk,iii,1,1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1), + & AEAb1derx(1,lll,kkk,iii,2,1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1), + & AEAb2derx(1,lll,kkk,iii,2,1)) + call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itj), + & AEAb1derx(1,lll,kkk,iii,1,2)) + call matvec2(auxmat(1,1),Ub2(1,j), + & AEAb2derx(1,lll,kkk,iii,1,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1), + & AEAb1derx(1,lll,kkk,iii,2,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1), + & AEAb2derx(1,lll,kkk,iii,2,2)) + enddo + enddo + enddo + ENDIF +C End vectors + else +C Antiparallel orientation of the two CA-CA-CA frames. + if (i.gt.1) then + iti=itortyp(itype(i)) + else + iti=ntortyp+1 + endif + itk1=itortyp(itype(k+1)) + itl=itortyp(itype(l)) + itj=itortyp(itype(j)) + if (j.lt.nres-1) then + itj1=itortyp(itype(j+1)) + else + itj1=ntortyp+1 + endif +C A2 kernel(j-1)T A1T + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j), + & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. + & j.eq.i+4 .and. l.eq.i+3)) THEN + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j), + & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) + call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j), + & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1), + & ADtEAderx(1,1,1,1,1,1)) + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j), + & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), + & ADtEA1derx(1,1,1,1,1,1)) + ENDIF +C End 6-th order cumulants + call transpose2(EUgder(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) + call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), + & EAEAderx(1,1,lll,kkk,iii,1)) + enddo + enddo + enddo +C A2T kernel(i+1)T A1 + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k), + & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. + & j.eq.i+4 .and. l.eq.i+3)) THEN + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k), + & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k), + & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), + & ADtEAderx(1,1,1,1,1,2)) + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k), + & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), + & ADtEA1derx(1,1,1,1,1,2)) + ENDIF +C End 6-th order cumulants + call transpose2(EUgder(1,1,j),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2)) + call transpose2(EUg(1,1,j),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & EAEAderx(1,1,lll,kkk,iii,2)) + enddo + enddo + enddo +C AEAb1 and AEAb2 +C Calculate the vectors and their derivatives in virtual-bond dihedral angles. +C They are needed only when the fifth- or the sixth-order cumulants are +C indluded. + IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. + & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN + call transpose2(AEA(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1)) + call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1)) + call transpose2(AEAderg(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1)) + call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1)) + call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1)) + call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1)) + call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1)) + call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1)) + call transpose2(AEA(1,1,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2)) + call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2)) + call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2)) + call transpose2(AEAderg(1,1,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2)) + call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2)) + call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2)) + call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2)) + call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2)) + call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2)) + call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2)) +C Calculate the Cartesian derivatives of the vectors. + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti), + & AEAb1derx(1,lll,kkk,iii,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i), + & AEAb2derx(1,lll,kkk,iii,1,1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1), + & AEAb1derx(1,lll,kkk,iii,2,1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1), + & AEAb2derx(1,lll,kkk,iii,2,1)) + call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itl), + & AEAb1derx(1,lll,kkk,iii,1,2)) + call matvec2(auxmat(1,1),Ub2(1,l), + & AEAb2derx(1,lll,kkk,iii,1,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1), + & AEAb1derx(1,lll,kkk,iii,2,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j), + & AEAb2derx(1,lll,kkk,iii,2,2)) + enddo + enddo + enddo + ENDIF +C End vectors + endif + return + end +C--------------------------------------------------------------------------- + subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp, + & KK,KKderg,AKA,AKAderg,AKAderx) + implicit none + integer nderg + logical transp + double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5), + & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2), + & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2) + integer iii,kkk,lll + integer jjj,mmm + logical lprn + common /kutas/ lprn + call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1)) + do iii=1,nderg + call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp, + & AKAderg(1,1,iii)) + enddo +cd if (lprn) write (2,*) 'In kernel' + do kkk=1,5 +cd if (lprn) write (2,*) 'kkk=',kkk + do lll=1,3 + call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1), + & KK(1,1),transp,AKAderx(1,1,lll,kkk,1)) +cd if (lprn) then +cd write (2,*) 'lll=',lll +cd write (2,*) 'iii=1' +cd do jjj=1,2 +cd write (2,'(3(2f10.5),5x)') +cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2) +cd enddo +cd endif + call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk), + & KK(1,1),transp,AKAderx(1,1,lll,kkk,2)) +cd if (lprn) then +cd write (2,*) 'lll=',lll +cd write (2,*) 'iii=2' +cd do jjj=1,2 +cd write (2,'(3(2f10.5),5x)') +cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2) +cd enddo +cd endif + enddo + enddo + return + end +C--------------------------------------------------------------------------- + double precision function eello4(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision pizda(2,2),ggg1(3),ggg2(3) +cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then +cd eello4=0.0d0 +cd return +cd endif +cd print *,'eello4:',i,j,k,l,jj,kk +cd write (2,*) 'i',i,' j',j,' k',k,' l',l +cd call checkint4(i,j,k,l,jj,kk,eel4_num) +cold eij=facont_hb(jj,i) +cold ekl=facont_hb(kk,k) +cold ekont=eij*ekl + eel4=-EAEA(1,1,1)-EAEA(2,2,1) +cd eel41=-EAEA(1,1,2)-EAEA(2,2,2) + gcorr_loc(k-1)=gcorr_loc(k-1) + & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1)) + if (l.eq.j+1) then + gcorr_loc(l-1)=gcorr_loc(l-1) + & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) + else + gcorr_loc(j-1)=gcorr_loc(j-1) + & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) + endif + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) + & -EAEAderx(2,2,lll,kkk,iii,1) +cd derx(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd gcorr_loc(l-1)=0.0d0 +cd gcorr_loc(j-1)=0.0d0 +cd gcorr_loc(k-1)=0.0d0 +cd eel4=1.0d0 +cd write (iout,*)'Contacts have occurred for peptide groups', +cd & i,j,' fcont:',eij,' eij',' and ',k,l, +cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif + do ll=1,3 +cgrad ggg1(ll)=eel4*g_contij(ll,1) +cgrad ggg2(ll)=eel4*g_contij(ll,2) + glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1) + glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2) +cgrad ghalf=0.5d0*ggg1(ll) + gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1) + gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1) + gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1) + gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1) + gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij + gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij +cgrad ghalf=0.5d0*ggg2(ll) + gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2) + gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2) + gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2) + gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2) + gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl + gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl + enddo +cgrad do m=i+1,j-1 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll) +cgrad enddo +cgrad enddo +cgrad do m=k+1,l-1 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll) +cgrad enddo +cgrad enddo +cgrad do m=i+2,j2 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1) +cgrad enddo +cgrad enddo +cgrad do m=k+2,l2 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2) +cgrad enddo +cgrad enddo +cd do iii=1,nres-3 +cd write (2,*) iii,gcorr_loc(iii) +cd enddo + eello4=ekont*eel4 +cd write (2,*) 'ekont',ekont +cd write (iout,*) 'eello4',ekont*eel4 + return + end +C--------------------------------------------------------------------------- + double precision function eello5(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2) + double precision ggg1(3),ggg2(3) +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel chains C +C C +C o o o o C +C /l\ / \ \ / \ / \ / C +C / \ / \ \ / \ / \ / C +C j| o |l1 | o | o| o | | o |o C +C \ |/k\| |/ \| / |/ \| |/ \| C +C \i/ \ / \ / / \ / \ C +C o k1 o C +C (I) (II) (III) (IV) C +C C +C eello5_1 eello5_2 eello5_3 eello5_4 C +C C +C Antiparallel chains C +C C +C o o o o C +C /j\ / \ \ / \ / \ / C +C / \ / \ \ / \ / \ / C +C j1| o |l | o | o| o | | o |o C +C \ |/k\| |/ \| / |/ \| |/ \| C +C \i/ \ / \ / / \ / \ C +C o k1 o C +C (I) (II) (III) (IV) C +C C +C eello5_1 eello5_2 eello5_3 eello5_4 C +C C +C o denotes a local interaction, vertical lines an electrostatic interaction. C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then +cd eello5=0.0d0 +cd return +cd endif +cd write (iout,*) +cd & 'EELLO5: Contacts have occurred for peptide groups',i,j, +cd & ' and',k,l + itk=itortyp(itype(k)) + itl=itortyp(itype(l)) + itj=itortyp(itype(j)) + eello5_1=0.0d0 + eello5_2=0.0d0 + eello5_3=0.0d0 + eello5_4=0.0d0 +cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num, +cd & eel5_3_num,eel5_4_num) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd eij=facont_hb(jj,i) +cd ekl=facont_hb(kk,k) +cd ekont=eij*ekl +cd write (iout,*)'Contacts have occurred for peptide groups', +cd & i,j,' fcont:',eij,' eij',' and ',k,l +cd goto 1111 +C Contribution from the graph I. +cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1) +cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) +C Explicit gradient in virtual-dihedral angles. + if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) + & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2der(1,i))) + call transpose2(EUgder(1,1,k),auxmat1(1,1)) + call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) + call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + if (l.eq.j+1) then + if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) + else + if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) + endif +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) + enddo + enddo + enddo +c goto 1112 +c1111 continue +C Contribution from graph II + call transpose2(EE(1,1,itk),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k)) +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k)) + call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + if (l.eq.j+1) then + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k))) + else + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k))) + endif +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k)) + enddo + enddo + enddo +cd goto 1112 +cd1111 continue + if (l.eq.j+1) then +cd goto 1110 +C Parallel orientation +C Contribution from graph III + call transpose2(EUg(1,1,l),auxmat(1,1)) + call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2der(1,j))) + call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) + call transpose2(EUgder(1,1,l),auxmat1(1,1)) + call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) + enddo + enddo + enddo +cd goto 1112 +C Contribution from graph IV +cd1110 continue + call transpose2(EE(1,1,itl),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) + & -0.5d0*scalar2(vv(1),Ctobr(1,l)) +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) + & -0.5d0*scalar2(vv(1),Ctobr(1,l))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) + & -0.5d0*scalar2(vv(1),Ctobr(1,l)) + enddo + enddo + enddo + else +C Antiparallel orientation +C Contribution from graph III +c goto 1110 + call transpose2(EUg(1,1,j),auxmat(1,1)) + call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2der(1,l))) + call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) + call transpose2(EUgder(1,1,j),auxmat1(1,1)) + call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) + & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) + enddo + enddo + enddo +cd goto 1112 +C Contribution from graph IV +1110 continue + call transpose2(EE(1,1,itj),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) + & -0.5d0*scalar2(vv(1),Ctobr(1,j)) +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) + & -0.5d0*scalar2(vv(1),Ctobr(1,j))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) + & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) + & -0.5d0*scalar2(vv(1),Ctobr(1,j)) + enddo + enddo + enddo + endif +1112 continue + eel5=eello5_1+eello5_2+eello5_3+eello5_4 +cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then +cd write (2,*) 'ijkl',i,j,k,l +cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2, +cd & ' eello5_3',eello5_3,' eello5_4',eello5_4 +cd endif +cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num +cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num +cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num +cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif +cd eij=1.0d0 +cd ekl=1.0d0 +cd ekont=1.0d0 +cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont +C 2/11/08 AL Gradients over DC's connecting interacting sites will be +C summed up outside the subrouine as for the other subroutines +C handling long-range interactions. The old code is commented out +C with "cgrad" to keep track of changes. + do ll=1,3 +cgrad ggg1(ll)=eel5*g_contij(ll,1) +cgrad ggg2(ll)=eel5*g_contij(ll,2) + gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1) + gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2) +c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)') +c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1), +c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2), +c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont +c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)') +c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1), +c & gradcorr5ij, +c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl +cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i) +cgrad ghalf=0.5d0*ggg1(ll) +cd ghalf=0.0d0 + gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1) + gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1) + gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1) + gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1) + gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij + gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij +cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k) +cgrad ghalf=0.5d0*ggg2(ll) +cd ghalf=0.0d0 + gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2) + gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2) + gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2) + gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2) + gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl + gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl + enddo +cd goto 1112 +cgrad do m=i+1,j-1 +cgrad do ll=1,3 +cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i) +cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll) +cgrad enddo +cgrad enddo +cgrad do m=k+1,l-1 +cgrad do ll=1,3 +cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k) +cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll) +cgrad enddo +cgrad enddo +c1112 continue +cgrad do m=i+2,j2 +cgrad do ll=1,3 +cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1) +cgrad enddo +cgrad enddo +cgrad do m=k+2,l2 +cgrad do ll=1,3 +cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2) +cgrad enddo +cgrad enddo +cd do iii=1,nres-3 +cd write (2,*) iii,g_corr5_loc(iii) +cd enddo + eello5=ekont*eel5 +cd write (2,*) 'ekont',ekont +cd write (iout,*) 'eello5',ekont*eel5 + return + end +c-------------------------------------------------------------------------- + double precision function eello6(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.FFIELD' + double precision ggg1(3),ggg2(3) +cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then +cd eello6=0.0d0 +cd return +cd endif +cd write (iout,*) +cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, +cd & ' and',k,l + eello6_1=0.0d0 + eello6_2=0.0d0 + eello6_3=0.0d0 + eello6_4=0.0d0 + eello6_5=0.0d0 + eello6_6=0.0d0 +cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num, +cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd eij=facont_hb(jj,i) +cd ekl=facont_hb(kk,k) +cd ekont=eij*ekl +cd eij=1.0d0 +cd ekl=1.0d0 +cd ekont=1.0d0 + if (l.eq.j+1) then + eello6_1=eello6_graph1(i,j,k,l,1,.false.) + eello6_2=eello6_graph1(j,i,l,k,2,.false.) + eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.) + eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) + eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.) + eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.) + else + eello6_1=eello6_graph1(i,j,k,l,1,.false.) + eello6_2=eello6_graph1(l,k,j,i,2,.true.) + eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.) + eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) + if (wturn6.eq.0.0d0 .or. j.ne.i+4) then + eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) + else + eello6_5=0.0d0 + endif + eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.) + endif +C If turn contributions are considered, they will be handled separately. + eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6 +cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num +cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num +cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num +cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num +cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num +cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num +cd goto 1112 + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif + do ll=1,3 +cgrad ggg1(ll)=eel6*g_contij(ll,1) +cgrad ggg2(ll)=eel6*g_contij(ll,2) +cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i) +cgrad ghalf=0.5d0*ggg1(ll) +cd ghalf=0.0d0 + gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1) + gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2) + gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1) + gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1) + gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1) + gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1) + gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij + gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij +cgrad ghalf=0.5d0*ggg2(ll) +cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k) +cd ghalf=0.0d0 + gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2) + gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2) + gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2) + gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2) + gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl + gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl + enddo +cd goto 1112 +cgrad do m=i+1,j-1 +cgrad do ll=1,3 +cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i) +cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll) +cgrad enddo +cgrad enddo +cgrad do m=k+1,l-1 +cgrad do ll=1,3 +cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k) +cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll) +cgrad enddo +cgrad enddo +cgrad1112 continue +cgrad do m=i+2,j2 +cgrad do ll=1,3 +cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1) +cgrad enddo +cgrad enddo +cgrad do m=k+2,l2 +cgrad do ll=1,3 +cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2) +cgrad enddo +cgrad enddo +cd do iii=1,nres-3 +cd write (2,*) iii,g_corr6_loc(iii) +cd enddo + eello6=ekont*eel6 +cd write (2,*) 'ekont',ekont +cd write (iout,*) 'eello6',ekont*eel6 + return + end +c-------------------------------------------------------------------------- + double precision function eello6_graph1(i,j,k,l,imat,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2) + logical swap + logical lprn + common /kutas/ lprn +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C Parallel Antiparallel +C +C o o +C /l\ /j\ +C / \ / \ +C /| o | | o |\ +C \ j|/k\| / \ |/k\|l / +C \ / \ / \ / \ / +C o o o o +C i i +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + itk=itortyp(itype(k)) + s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i)) + s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k)) + s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k)) + call transpose2(EUgC(1,1,k),auxmat(1,1)) + call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) + vv1(1)=pizda1(1,1)-pizda1(2,2) + vv1(2)=pizda1(1,2)+pizda1(2,1) + s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) + vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk) + vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk) + s5=scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5 + eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5) + if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) + & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) + & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) + & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) + & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) + & +scalar2(vv(1),Dtobr2der(1,i))) + call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1)) + vv1(1)=pizda1(1,1)-pizda1(2,2) + vv1(2)=pizda1(1,2)+pizda1(2,1) + vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk) + vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk) + if (l.eq.j+1) then + g_corr6_loc(l-1)=g_corr6_loc(l-1) + & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) + & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) + & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) + & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i)))) + else + g_corr6_loc(j-1)=g_corr6_loc(j-1) + & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) + & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) + & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) + & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i)))) + endif + call transpose2(EUgCder(1,1,k),auxmat(1,1)) + call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) + vv1(1)=pizda1(1,1)-pizda1(2,2) + vv1(2)=pizda1(1,2)+pizda1(2,1) + if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) + & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) + & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) + & +0.5d0*scalar2(vv1(1),Dtobr2(1,i)))) + do iii=1,2 + if (swap) then + ind=3-iii + else + ind=iii + endif + do kkk=1,5 + do lll=1,3 + s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i)) + s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k)) + s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k)) + call transpose2(EUgC(1,1,k),auxmat(1,1)) + call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1), + & pizda1(1,1)) + vv1(1)=pizda1(1,1)-pizda1(2,2) + vv1(2)=pizda1(1,2)+pizda1(2,1) + s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) + vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) + & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk) + vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) + & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk) + s5=scalar2(vv(1),Dtobr2(1,i)) + derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5) + enddo + enddo + enddo + return + end +c---------------------------------------------------------------------------- + double precision function eello6_graph2(i,j,k,l,jj,kk,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + logical swap + double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), + & auxvec1(2),auxvec2(2),auxmat1(2,2) + logical lprn + common /kutas/ lprn +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel Antiparallel C +C C +C o o C +C \ /l\ /j\ / C +C \ / \ / \ / C +C o| o | | o |o C +C \ j|/k\| \ |/k\|l C +C \ / \ \ / \ C +C o o C +C i i C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l +C AL 7/4/01 s1 would occur in the sixth-order moment, +C but not in a cluster cumulant +#ifdef MOMENT + s1=dip(1,jj,i)*dip(1,kk,k) +#endif + call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + eello6_graph2=-(s1+s2+s3+s4) +#else + eello6_graph2=-(s2+s3+s4) +#endif +c eello6_graph2=-s3 +C Derivatives in gamma(i-1) + if (i.gt.1) then +#ifdef MOMENT + s1=dipderg(1,jj,i)*dip(1,kk,k) +#endif + s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1)) + call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) + s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i)) +#ifdef MOMENT + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) +#endif +c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3 + endif +C Derivatives in gamma(k-1) +#ifdef MOMENT + s1=dip(1,jj,i)*dipderg(1,kk,k) +#endif + call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) + call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) + call transpose2(EUgder(1,1,k),auxmat1(1,1)) + call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +#ifdef MOMENT + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) +#endif +c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3 +C Derivatives in gamma(j-1) or gamma(l-1) + if (j.gt.1) then +#ifdef MOMENT + s1=dipderg(3,jj,i)*dip(1,kk,k) +#endif + call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1)) + call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +#ifdef MOMENT + if (swap) then + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 + else + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 + endif +#endif + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4) +c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3 + endif +C Derivatives in gamma(l-1) or gamma(j-1) + if (l.gt.1) then +#ifdef MOMENT + s1=dip(1,jj,i)*dipderg(3,kk,k) +#endif + call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) + call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) + call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +#ifdef MOMENT + if (swap) then + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 + else + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 + endif +#endif + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4) +c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3 + endif +C Cartesian derivatives. + if (lprn) then + write (2,*) 'In eello6_graph2' + do iii=1,2 + write (2,*) 'iii=',iii + do kkk=1,5 + write (2,*) 'kkk=',kkk + do jjj=1,2 + write (2,'(3(2f10.5),5x)') + & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) + enddo + enddo + enddo + endif + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + if (iii.eq.1) then + s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k) + else + s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k) + endif +#endif + call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k), + & auxvec(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l), + & auxvec(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) +#else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) +#endif + if (swap) then + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 + else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + endif + enddo + enddo + enddo + return + end +c---------------------------------------------------------------------------- + double precision function eello6_graph3(i,j,k,l,jj,kk,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2) + logical swap +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel Antiparallel C +C C +C o o C +C /l\ / \ /j\ C +C / \ / \ / \ C +C /| o |o o| o |\ C +C j|/k\| / |/k\|l / C +C / \ / / \ / C +C / o / o C +C i i C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C 4/7/01 AL Component s1 was removed, because it pertains to the respective +C energy moment and not to the cluster cumulant. + iti=itortyp(itype(i)) + if (j.lt.nres-1) then + itj1=itortyp(itype(j+1)) + else + itj1=ntortyp+1 + endif + itk=itortyp(itype(k)) + itk1=itortyp(itype(k+1)) + if (l.lt.nres-1) then + itl1=itortyp(itype(l+1)) + else + itl1=ntortyp+1 + endif +#ifdef MOMENT + s1=dip(4,jj,i)*dip(4,kk,k) +#endif + call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1)) + s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) + call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1)) + s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) + call transpose2(EE(1,1,itk),auxmat(1,1)) + call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) +cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4, +cd & "sum",-(s2+s3+s4) +#ifdef MOMENT + eello6_graph3=-(s1+s2+s3+s4) +#else + eello6_graph3=-(s2+s3+s4) +#endif +c eello6_graph3=-s4 +C Derivatives in gamma(k-1) + call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1)) + s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) + s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k)) + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4) +C Derivatives in gamma(l-1) + call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1)) + s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) + call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) +C Cartesian derivatives. + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + if (iii.eq.1) then + s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k) + else + s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k) + endif +#endif + call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1), + & auxvec(1)) + s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) + call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1), + & auxvec(1)) + s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) + call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) +#ifdef MOMENT + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) +#else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) +#endif + if (swap) then + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 + else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + endif +c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4 + enddo + enddo + enddo + return + end +c---------------------------------------------------------------------------- + double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.FFIELD' + double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), + & auxvec1(2),auxmat1(2,2) + logical swap +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel Antiparallel C +C C +C o o C +C /l\ / \ /j\ C +C / \ / \ / \ C +C /| o |o o| o |\ C +C \ j|/k\| \ |/k\|l C +C \ / \ \ / \ C +C o \ o \ C +C i i C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C 4/7/01 AL Component s1 was removed, because it pertains to the respective +C energy moment and not to the cluster cumulant. +cd write (2,*) 'eello_graph4: wturn6',wturn6 + iti=itortyp(itype(i)) + itj=itortyp(itype(j)) + if (j.lt.nres-1) then + itj1=itortyp(itype(j+1)) + else + itj1=ntortyp+1 + endif + itk=itortyp(itype(k)) + if (k.lt.nres-1) then + itk1=itortyp(itype(k+1)) + else + itk1=ntortyp+1 + endif + itl=itortyp(itype(l)) + if (l.lt.nres-1) then + itl1=itortyp(itype(l+1)) + else + itl1=ntortyp+1 + endif +cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l +cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk, +cd & ' itl',itl,' itl1',itl1 +#ifdef MOMENT + if (imat.eq.1) then + s1=dip(3,jj,i)*dip(3,kk,k) + else + s1=dip(2,jj,j)*dip(2,kk,l) + endif +#endif + call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) + else + call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) + endif + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + eello6_graph4=-(s1+s2+s3+s4) +#else + eello6_graph4=-(s2+s3+s4) +#endif +C Derivatives in gamma(i-1) + if (i.gt.1) then +#ifdef MOMENT + if (imat.eq.1) then + s1=dipderg(2,jj,i)*dip(3,kk,k) + else + s1=dipderg(4,jj,j)*dip(2,kk,l) + endif +#endif + s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) + else + call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) + endif + s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i)) + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then +cd write (2,*) 'turn6 derivatives' +#ifdef MOMENT + gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4) +#else + gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4) +#endif + else +#ifdef MOMENT + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) +#endif + endif + endif +C Derivatives in gamma(k-1) +#ifdef MOMENT + if (imat.eq.1) then + s1=dip(3,jj,i)*dipderg(2,kk,k) + else + s1=dip(2,jj,j)*dipderg(4,kk,l) + endif +#endif + call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) + else + call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) + endif + call transpose2(EUgder(1,1,k),auxmat1(1,1)) + call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then +#ifdef MOMENT + gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4) +#else + gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4) +#endif + else +#ifdef MOMENT + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) +#endif + endif +C Derivatives in gamma(j-1) or gamma(l-1) + if (l.eq.j+1 .and. l.gt.1) then + call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) + else if (j.gt.1) then + call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then + gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4) + else + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4) + endif + endif +C Cartesian derivatives. + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + if (iii.eq.1) then + if (imat.eq.1) then + s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k) + else + s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l) + endif + else + if (imat.eq.1) then + s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k) + else + s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l) + endif + endif +#endif + call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k), + & auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), + & b1(1,itj1),auxvec(1)) + s3=-0.5d0*scalar2(b1(1,itj),auxvec(1)) + else + call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), + & b1(1,itl1),auxvec(1)) + s3=-0.5d0*scalar2(b1(1,itl),auxvec(1)) + endif + call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + if (swap) then + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then +#ifdef MOMENT + derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) + & -(s1+s2+s4) +#else + derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) + & -(s2+s4) +#endif + derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3 + else +#ifdef MOMENT + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4) +#else + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4) +#endif + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + endif + else +#ifdef MOMENT + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) +#else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) +#endif + if (l.eq.j+1) then + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + else + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 + endif + endif + enddo + enddo + enddo + return + end +c---------------------------------------------------------------------------- + double precision function eello_turn6(i,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2), + & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2), + & ggg1(3),ggg2(3) + double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2), + & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2) +C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to +C the respective energy moment and not to the cluster cumulant. + s1=0.0d0 + s8=0.0d0 + s13=0.0d0 +c + eello_turn6=0.0d0 + j=i+4 + k=i+1 + l=i+3 + iti=itortyp(itype(i)) + itk=itortyp(itype(k)) + itk1=itortyp(itype(k+1)) + itl=itortyp(itype(l)) + itj=itortyp(itype(j)) +cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj +cd write (2,*) 'i',i,' k',k,' j',j,' l',l +cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then +cd eello6=0.0d0 +cd return +cd endif +cd write (iout,*) +cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, +cd & ' and',k,l +cd call checkint_turn6(i,jj,kk,eel_turn6_num) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx_turn(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd eij=1.0d0 +cd ekl=1.0d0 +cd ekont=1.0d0 + eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) +cd eello6_5=0.0d0 +cd write (2,*) 'eello6_5',eello6_5 +#ifdef MOMENT + call transpose2(AEA(1,1,1),auxmat(1,1)) + call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1)) + ss1=scalar2(Ub2(1,i+2),b1(1,itl)) + s1 = (auxmat(1,1)+auxmat(2,2))*ss1 +#endif + call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1)) + call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1)) + s2 = scalar2(b1(1,itk),vtemp1(1)) +#ifdef MOMENT + call transpose2(AEA(1,1,2),atemp(1,1)) + call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1)) + call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1)) + s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) +#endif + call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1)) + call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1)) + s12 = scalar2(Ub2(1,i+2),vtemp3(1)) +#ifdef MOMENT + call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1)) + call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1)) + call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1)) + call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1)) + ss13 = scalar2(b1(1,itk),vtemp4(1)) + s13 = (gtemp(1,1)+gtemp(2,2))*ss13 +#endif +c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13 +c s1=0.0d0 +c s2=0.0d0 +c s8=0.0d0 +c s12=0.0d0 +c s13=0.0d0 + eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13) +C Derivatives in gamma(i+2) + s1d =0.0d0 + s8d =0.0d0 +#ifdef MOMENT + call transpose2(AEA(1,1,1),auxmatd(1,1)) + call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 + call transpose2(AEAderg(1,1,2),atempd(1,1)) + call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1)) + s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) +#endif + call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1)) + call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 + gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d) +C Derivatives in gamma(i+3) +#ifdef MOMENT + call transpose2(AEA(1,1,1),auxmatd(1,1)) + call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + ss1d=scalar2(Ub2der(1,i+2),b1(1,itl)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d +#endif + call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1)) + call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1)) + s2d = scalar2(b1(1,itk),vtemp1d(1)) +#ifdef MOMENT + call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1)) + s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1)) +#endif + s12d = scalar2(Ub2der(1,i+2),vtemp3(1)) +#ifdef MOMENT + call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1)) + call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) + s13d = (gtempd(1,1)+gtempd(2,2))*ss13 +#endif +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + gel_loc_turn6(i+1)=gel_loc_turn6(i+1) + & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) +#else + gel_loc_turn6(i+1)=gel_loc_turn6(i+1) + & -0.5d0*ekont*(s2d+s12d) +#endif +C Derivatives in gamma(i+4) + call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1)) + call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +#ifdef MOMENT + call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1)) + call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1)) + s13d = (gtempd(1,1)+gtempd(2,2))*ss13 +#endif +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +C s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d) +#else + gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d) +#endif +C Derivatives in gamma(i+5) +#ifdef MOMENT + call transpose2(AEAderg(1,1,1),auxmatd(1,1)) + call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 +#endif + call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1)) + call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1)) + s2d = scalar2(b1(1,itk),vtemp1d(1)) +#ifdef MOMENT + call transpose2(AEA(1,1,2),atempd(1,1)) + call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1)) + s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) +#endif + call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +#ifdef MOMENT + call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1)) + ss13d = scalar2(b1(1,itk),vtemp4d(1)) + s13d = (gtemp(1,1)+gtemp(2,2))*ss13d +#endif +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + gel_loc_turn6(i+3)=gel_loc_turn6(i+3) + & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) +#else + gel_loc_turn6(i+3)=gel_loc_turn6(i+3) + & -0.5d0*ekont*(s2d+s12d) +#endif +C Cartesian derivatives + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1)) + call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 +#endif + call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1), + & vtemp1d(1)) + s2d = scalar2(b1(1,itk),vtemp1d(1)) +#ifdef MOMENT + call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1)) + call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1)) + s8d = -(atempd(1,1)+atempd(2,2))* + & scalar2(cc(1,1,itl),vtemp2(1)) +#endif + call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2), + & auxmatd(1,1)) + call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) + & - 0.5d0*(s1d+s2d) +#else + derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) + & - 0.5d0*s2d +#endif +#ifdef MOMENT + derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) + & - 0.5d0*(s8d+s12d) +#else + derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) + & - 0.5d0*s12d +#endif + enddo + enddo + enddo +#ifdef MOMENT + do kkk=1,5 + do lll=1,3 + call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1), + & achuj_tempd(1,1)) + call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1)) + call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) + s13d=(gtempd(1,1)+gtempd(2,2))*ss13 + derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d + call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4), + & vtemp4d(1)) + ss13d = scalar2(b1(1,itk),vtemp4d(1)) + s13d = (gtemp(1,1)+gtemp(2,2))*ss13d + derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d + enddo + enddo +#endif +cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num', +cd & 16*eel_turn6_num +cd goto 1112 + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif + do ll=1,3 +cgrad ggg1(ll)=eel_turn6*g_contij(ll,1) +cgrad ggg2(ll)=eel_turn6*g_contij(ll,2) +cgrad ghalf=0.5d0*ggg1(ll) +cd ghalf=0.0d0 + gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1) + gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2) + gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf + & +ekont*derx_turn(ll,2,1) + gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1) + gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf + & +ekont*derx_turn(ll,4,1) + gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1) + gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij + gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij +cgrad ghalf=0.5d0*ggg2(ll) +cd ghalf=0.0d0 + gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf + & +ekont*derx_turn(ll,2,2) + gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2) + gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf + & +ekont*derx_turn(ll,4,2) + gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2) + gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl + gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl + enddo +cd goto 1112 +cgrad do m=i+1,j-1 +cgrad do ll=1,3 +cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll) +cgrad enddo +cgrad enddo +cgrad do m=k+1,l-1 +cgrad do ll=1,3 +cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll) +cgrad enddo +cgrad enddo +cgrad1112 continue +cgrad do m=i+2,j2 +cgrad do ll=1,3 +cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1) +cgrad enddo +cgrad enddo +cgrad do m=k+2,l2 +cgrad do ll=1,3 +cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2) +cgrad enddo +cgrad enddo +cd do iii=1,nres-3 +cd write (2,*) iii,g_corr6_loc(iii) +cd enddo + eello_turn6=ekont*eel_turn6 +cd write (2,*) 'ekont',ekont +cd write (2,*) 'eel_turn6',ekont*eel_turn6 + return + end + +C----------------------------------------------------------------------------- + double precision function scalar(u,v) +!DIR$ INLINEALWAYS scalar +#ifndef OSF +cDEC$ ATTRIBUTES FORCEINLINE::scalar +#endif + implicit none + double precision u(3),v(3) +cd double precision sc +cd integer i +cd sc=0.0d0 +cd do i=1,3 +cd sc=sc+u(i)*v(i) +cd enddo +cd scalar=sc + + scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3) + return + end +crc------------------------------------------------- + SUBROUTINE MATVEC2(A1,V1,V2) +!DIR$ INLINEALWAYS MATVEC2 +#ifndef OSF +cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2 +#endif + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + DIMENSION A1(2,2),V1(2),V2(2) +c DO 1 I=1,2 +c VI=0.0 +c DO 3 K=1,2 +c 3 VI=VI+A1(I,K)*V1(K) +c Vaux(I)=VI +c 1 CONTINUE + + vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2) + vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2) + + v2(1)=vaux1 + v2(2)=vaux2 + END +C--------------------------------------- + SUBROUTINE MATMAT2(A1,A2,A3) +#ifndef OSF +cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2 +#endif + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + DIMENSION A1(2,2),A2(2,2),A3(2,2) +c DIMENSION AI3(2,2) +c DO J=1,2 +c A3IJ=0.0 +c DO K=1,2 +c A3IJ=A3IJ+A1(I,K)*A2(K,J) +c enddo +c A3(I,J)=A3IJ +c enddo +c enddo + + ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1) + ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2) + ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1) + ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2) + + A3(1,1)=AI3_11 + A3(2,1)=AI3_21 + A3(1,2)=AI3_12 + A3(2,2)=AI3_22 + END + +c------------------------------------------------------------------------- + double precision function scalar2(u,v) +!DIR$ INLINEALWAYS scalar2 + implicit none + double precision u(2),v(2) + double precision sc + integer i + scalar2=u(1)*v(1)+u(2)*v(2) + return + end + +C----------------------------------------------------------------------------- + + subroutine transpose2(a,at) +!DIR$ INLINEALWAYS transpose2 +#ifndef OSF +cDEC$ ATTRIBUTES FORCEINLINE::transpose2 +#endif + implicit none + double precision a(2,2),at(2,2) + at(1,1)=a(1,1) + at(1,2)=a(2,1) + at(2,1)=a(1,2) + at(2,2)=a(2,2) + return + end +c-------------------------------------------------------------------------- + subroutine transpose(n,a,at) + implicit none + integer n,i,j + double precision a(n,n),at(n,n) + do i=1,n + do j=1,n + at(j,i)=a(i,j) + enddo + enddo + return + end +C--------------------------------------------------------------------------- + subroutine prodmat3(a1,a2,kk,transp,prod) +!DIR$ INLINEALWAYS prodmat3 +#ifndef OSF +cDEC$ ATTRIBUTES FORCEINLINE::prodmat3 +#endif + implicit none + integer i,j + double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2) + logical transp +crc double precision auxmat(2,2),prod_(2,2) + + if (transp) then +crc call transpose2(kk(1,1),auxmat(1,1)) +crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1)) +crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) + + prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) + & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1) + prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) + & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2) + prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) + & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1) + prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) + & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2) + + else +crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1)) +crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) + + prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) + & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1) + prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) + & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2) + prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) + & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1) + prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) + & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2) + + endif +c call transpose2(a2(1,1),a2t(1,1)) + +crc print *,transp +crc print *,((prod_(i,j),i=1,2),j=1,2) +crc print *,((prod(i,j),i=1,2),j=1,2) + + return + end + diff --git a/source/unres/src_MD-DFA-restraints/energy_split-sep.F b/source/unres/src_MD-DFA-restraints/energy_split-sep.F new file mode 100644 index 0000000..97442a3 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/energy_split-sep.F @@ -0,0 +1,500 @@ + subroutine etotal_long(energia) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +c +c Compute the long-range slow-varying contributions to the energy +c +#ifndef ISNAN + external proc_proc +#ifdef WINPGI +cMS$ATTRIBUTES C :: proc_proc +#endif +#endif +#ifdef MPI + include "mpif.h" + double precision weights_(n_ene) +#endif + include 'COMMON.SETUP' + include 'COMMON.IOUNITS' + double precision energia(0:n_ene) + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.MD' +c write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot + if (modecalc.eq.12.or.modecalc.eq.14) then +#ifdef MPI +c if (fg_rank.eq.0) call int_from_cart1(.false.) +#else + call int_from_cart1(.false.) +#endif + endif +#ifdef MPI +c write(iout,*) "ETOTAL_LONG Processor",fg_rank, +c & " absolute rank",myrank," nfgtasks",nfgtasks + call flush(iout) + if (nfgtasks.gt.1) then + time00=MPI_Wtime() +C FG slaves call the following matching MPI_Bcast in ERGASTULUM + if (fg_rank.eq.0) then + call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR) +c write (iout,*) "Processor",myrank," BROADCAST iorder" +c call flush(iout) +C FG master sets up the WEIGHTS_ array which will be broadcast to the +C FG slaves as WEIGHTS array. + weights_(1)=wsc + weights_(2)=wscp + weights_(3)=welec + weights_(4)=wcorr + weights_(5)=wcorr5 + weights_(6)=wcorr6 + weights_(7)=wel_loc + weights_(8)=wturn3 + weights_(9)=wturn4 + weights_(10)=wturn6 + weights_(11)=wang + weights_(12)=wscloc + weights_(13)=wtor + weights_(14)=wtor_d + weights_(15)=wstrain + weights_(16)=wvdwpp + weights_(17)=wbond + weights_(18)=scal14 + weights_(21)=wsccor +C FG Master broadcasts the WEIGHTS_ array + call MPI_Bcast(weights_(1),n_ene, + & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) + else +C FG slaves receive the WEIGHTS array + call MPI_Bcast(weights(1),n_ene, + & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) + wsc=weights(1) + wscp=weights(2) + welec=weights(3) + wcorr=weights(4) + wcorr5=weights(5) + wcorr6=weights(6) + wel_loc=weights(7) + wturn3=weights(8) + wturn4=weights(9) + wturn6=weights(10) + wang=weights(11) + wscloc=weights(12) + wtor=weights(13) + wtor_d=weights(14) + wstrain=weights(15) + wvdwpp=weights(16) + wbond=weights(17) + scal14=weights(18) + wsccor=weights(21) + endif + call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION, + & king,FG_COMM,IERR) + time_Bcast=time_Bcast+MPI_Wtime()-time00 + time_Bcastw=time_Bcastw+MPI_Wtime()-time00 +c call chainbuild_cart +c call int_from_cart1(.false.) + endif +c write (iout,*) 'Processor',myrank, +c & ' calling etotal_short ipot=',ipot +c call flush(iout) +c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct +#endif +cd print *,'nnt=',nnt,' nct=',nct +C +C Compute the side-chain and electrostatic interaction energy +C + goto (101,102,103,104,105,106) ipot +C Lennard-Jones potential. + 101 call elj_long(evdw) +cd print '(a)','Exit ELJ' + goto 107 +C Lennard-Jones-Kihara potential (shifted). + 102 call eljk_long(evdw) + goto 107 +C Berne-Pechukas potential (dilated LJ, angular dependence). + 103 call ebp_long(evdw) + goto 107 +C Gay-Berne potential (shifted LJ, angular dependence). + 104 call egb_long(evdw,evdw_p,evdw_m) + goto 107 +C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). + 105 call egbv_long(evdw) + goto 107 +C Soft-sphere potential + 106 call e_softsphere(evdw) +C +C Calculate electrostatic (H-bonding) energy of the main chain. +C + 107 continue + call vec_and_deriv + if (ipot.lt.6) then +#ifdef SPLITELE + if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. + & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 + & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 + & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then +#else + if (welec.gt.0d0.or.wel_loc.gt.0d0.or. + & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 + & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 + & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then +#endif + call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4) + else + ees=0 + evdw1=0 + eel_loc=0 + eello_turn3=0 + eello_turn4=0 + endif + else +c write (iout,*) "Soft-spheer ELEC potential" + call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3, + & eello_turn4) + endif +C +C Calculate excluded-volume interaction energy between peptide groups +C and side chains. +C + if (ipot.lt.6) then + if(wscp.gt.0d0) then + call escp_long(evdw2,evdw2_14) + else + evdw2=0 + evdw2_14=0 + endif + else + call escp_soft_sphere(evdw2,evdw2_14) + endif +C +C 12/1/95 Multi-body terms +C + n_corr=0 + n_corr1=0 + if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 + & .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then + call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1) +c write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1, +c &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6 + else + ecorr=0.0d0 + ecorr5=0.0d0 + ecorr6=0.0d0 + eturn6=0.0d0 + endif + if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then + call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) + endif +C +C If performing constraint dynamics, call the constraint energy +C after the equilibration time + if(usampl.and.totT.gt.eq_time) then + call EconstrQ + call Econstr_back + else + Uconst=0.0d0 + Uconst_back=0.0d0 + endif +C +C Sum the energies +C + do i=1,n_ene + energia(i)=0.0d0 + enddo + energia(1)=evdw +#ifdef SCP14 + energia(2)=evdw2-evdw2_14 + energia(18)=evdw2_14 +#else + energia(2)=evdw2 + energia(18)=0.0d0 +#endif +#ifdef SPLITELE + energia(3)=ees + energia(16)=evdw1 +#else + energia(3)=ees+evdw1 + energia(16)=0.0d0 +#endif + energia(4)=ecorr + energia(5)=ecorr5 + energia(6)=ecorr6 + energia(7)=eel_loc + energia(8)=eello_turn3 + energia(9)=eello_turn4 + energia(10)=eturn6 + energia(20)=Uconst+Uconst_back + energia(22)=evdw_p + energia(23)=evdw_m + call sum_energy(energia,.true.) +c write (iout,*) "Exit ETOTAL_LONG" + call flush(iout) + return + end +c------------------------------------------------------------------------------ + subroutine etotal_short(energia) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +c +c Compute the short-range fast-varying contributions to the energy +c +#ifndef ISNAN + external proc_proc +#ifdef WINPGI +cMS$ATTRIBUTES C :: proc_proc +#endif +#endif +#ifdef MPI + include "mpif.h" + double precision weights_(n_ene) +#endif + include 'COMMON.SETUP' + include 'COMMON.IOUNITS' + double precision energia(0:n_ene) + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CONTROL' + +c write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot +c call flush(iout) + if (modecalc.eq.12.or.modecalc.eq.14) then +#ifdef MPI + if (fg_rank.eq.0) call int_from_cart1(.false.) +#else + call int_from_cart1(.false.) +#endif + endif +#ifdef MPI +c write(iout,*) "ETOTAL_SHORT Processor",fg_rank, +c & " absolute rank",myrank," nfgtasks",nfgtasks +c call flush(iout) + if (nfgtasks.gt.1) then + time00=MPI_Wtime() +C FG slaves call the following matching MPI_Bcast in ERGASTULUM + if (fg_rank.eq.0) then + call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR) +c write (iout,*) "Processor",myrank," BROADCAST iorder" +c call flush(iout) +C FG master sets up the WEIGHTS_ array which will be broadcast to the +C FG slaves as WEIGHTS array. + weights_(1)=wsc + weights_(2)=wscp + weights_(3)=welec + weights_(4)=wcorr + weights_(5)=wcorr5 + weights_(6)=wcorr6 + weights_(7)=wel_loc + weights_(8)=wturn3 + weights_(9)=wturn4 + weights_(10)=wturn6 + weights_(11)=wang + weights_(12)=wscloc + weights_(13)=wtor + weights_(14)=wtor_d + weights_(15)=wstrain + weights_(16)=wvdwpp + weights_(17)=wbond + weights_(18)=scal14 + weights_(21)=wsccor +C FG Master broadcasts the WEIGHTS_ array + call MPI_Bcast(weights_(1),n_ene, + & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) + else +C FG slaves receive the WEIGHTS array + call MPI_Bcast(weights(1),n_ene, + & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) + wsc=weights(1) + wscp=weights(2) + welec=weights(3) + wcorr=weights(4) + wcorr5=weights(5) + wcorr6=weights(6) + wel_loc=weights(7) + wturn3=weights(8) + wturn4=weights(9) + wturn6=weights(10) + wang=weights(11) + wscloc=weights(12) + wtor=weights(13) + wtor_d=weights(14) + wstrain=weights(15) + wvdwpp=weights(16) + wbond=weights(17) + scal14=weights(18) + wsccor=weights(21) + endif +c write (iout,*),"Processor",myrank," BROADCAST weights" + call MPI_Bcast(c(1,1),maxres6,MPI_DOUBLE_PRECISION, + & king,FG_COMM,IERR) +c write (iout,*) "Processor",myrank," BROADCAST c" + call MPI_Bcast(dc(1,1),maxres6,MPI_DOUBLE_PRECISION, + & king,FG_COMM,IERR) +c write (iout,*) "Processor",myrank," BROADCAST dc" + call MPI_Bcast(dc_norm(1,1),maxres6,MPI_DOUBLE_PRECISION, + & king,FG_COMM,IERR) +c write (iout,*) "Processor",myrank," BROADCAST dc_norm" + call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION, + & king,FG_COMM,IERR) +c write (iout,*) "Processor",myrank," BROADCAST theta" + call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION, + & king,FG_COMM,IERR) +c write (iout,*) "Processor",myrank," BROADCAST phi" + call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION, + & king,FG_COMM,IERR) +c write (iout,*) "Processor",myrank," BROADCAST alph" + call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION, + & king,FG_COMM,IERR) +c write (iout,*) "Processor",myrank," BROADCAST omeg" + call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION, + & king,FG_COMM,IERR) +c write (iout,*) "Processor",myrank," BROADCAST vbld" + call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION, + & king,FG_COMM,IERR) + time_Bcast=time_Bcast+MPI_Wtime()-time00 +c write (iout,*) "Processor",myrank," BROADCAST vbld_inv" + endif +c write (iout,*) 'Processor',myrank, +c & ' calling etotal_short ipot=',ipot +c call flush(iout) +c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct +#endif +c call int_from_cart1(.false.) +C +C Compute the side-chain and electrostatic interaction energy +C + goto (101,102,103,104,105,106) ipot +C Lennard-Jones potential. + 101 call elj_short(evdw) +cd print '(a)','Exit ELJ' + goto 107 +C Lennard-Jones-Kihara potential (shifted). + 102 call eljk_short(evdw) + goto 107 +C Berne-Pechukas potential (dilated LJ, angular dependence). + 103 call ebp_short(evdw) + goto 107 +C Gay-Berne potential (shifted LJ, angular dependence). + 104 call egb_short(evdw,evdw_p,evdw_m) + goto 107 +C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). + 105 call egbv_short(evdw) + goto 107 +C Soft-sphere potential - already dealt with in the long-range part + 106 evdw=0.0d0 +c 106 call e_softsphere_short(evdw) +C +C Calculate electrostatic (H-bonding) energy of the main chain. +C + 107 continue + +C BARTEK 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 +c Calculate the short-range part of Evdwpp +c + call evdwpp_short(evdw1) +c +c Calculate the short-range part of ESCp +c + if (ipot.lt.6) then + call escp_short(evdw2,evdw2_14) + endif +c +c Calculate the bond-stretching energy +c + call ebond(estr) +C +C Calculate the disulfide-bridge and other energy and the contributions +C from other distance constraints. + call edis(ehpb) +C +C Calculate the virtual-bond-angle energy. +C + call ebend(ebe) +C +C Calculate the SC local energy. +C + call vec_and_deriv + call esc(escloc) +C +C Calculate the virtual-bond torsional energy. +C + call etor(etors,edihcnstr) +c +c Homology restraints +c + if (constr_homology.ge.1) then + call e_modeller(ehomology_constr) + else + ehomology_constr=0.0d0 + endif +C +C 6/23/01 Calculate double-torsional energy +C + call etor_d(etors_d) +C +C 21/5/07 Calculate local sicdechain correlation energy +C + if (wsccor.gt.0.0d0) then + call eback_sc_corr(esccor) + else + esccor=0.0d0 + endif +C +C Put energy components into an array +C + do i=1,n_ene + energia(i)=0.0d0 + enddo + energia(1)=evdw +#ifdef SCP14 + energia(2)=evdw2-evdw2_14 + energia(18)=evdw2_14 +#else + energia(2)=evdw2 + energia(18)=0.0d0 +#endif +#ifdef SPLITELE + energia(16)=evdw1 +#else + energia(3)=evdw1 +#endif + energia(11)=ebe + energia(12)=escloc + energia(13)=etors + energia(14)=etors_d + energia(15)=ehpb + energia(17)=estr + energia(19)=edihcnstr + energia(21)=esccor + energia(22)=evdw_p + energia(23)=evdw_m + energia(24)=ehomology_constr + energia(25)=edfadis + energia(26)=edfator + energia(27)=edfanei + energia(28)=edfabet +c write (iout,*) "ETOTAL_SHORT before SUM_ENERGY" + call flush(iout) + call sum_energy(energia,.true.) +c write (iout,*) "Exit ETOTAL_SHORT" + call flush(iout) + return + end diff --git a/source/unres/src_MD-DFA-restraints/entmcm.F b/source/unres/src_MD-DFA-restraints/entmcm.F new file mode 100644 index 0000000..3c2dc5a --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/entmcm.F @@ -0,0 +1,684 @@ + subroutine entmcm +C Does modified entropic sampling in the space of minima. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' +#ifdef MPL + include 'COMMON.INFO' +#endif + include 'COMMON.GEO' + include 'COMMON.CHAIN' + include 'COMMON.MCM' + include 'COMMON.MCE' + include 'COMMON.CONTACTS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.THREAD' + include 'COMMON.NAMES' + logical accepted,not_done,over,ovrtim,error,lprint + integer MoveType,nbond + integer conf_comp + double precision RandOrPert + double precision varia(maxvar),elowest,ehighest,eold + double precision przes(3),obr(3,3) + double precision varold(maxvar) + logical non_conv + double precision energia(0:n_ene),energia_ave(0:n_ene) +C +cd write (iout,*) 'print_mc=',print_mc + WhatsUp=0 + maxtrial_iter=50 +c--------------------------------------------------------------------------- +C Initialize counters. +c--------------------------------------------------------------------------- +C Total number of generated confs. + ngen=0 +C Total number of moves. In general this won't be equal to the number of +C attempted moves, because we may want to reject some "bad" confs just by +C overlap check. + nmove=0 +C Total number of shift (nbond_move(1)), spike, crankshaft, three-bond,... +C motions. + do i=1,nres + nbond_move(i)=0 + enddo +C Initialize total and accepted number of moves of various kind. + do i=0,MaxMoveType + moves(i)=0 + moves_acc(i)=0 + enddo +C Total number of energy evaluations. + neneval=0 + nfun=0 + indminn=-max_ene + indmaxx=max_ene + delte=0.5D0 + facee=1.0D0/(maxacc*delte) + conste=dlog(facee) +C Read entropy from previous simulations. + if (ent_read) then + read (ientin,*) indminn,indmaxx,emin,emax + print *,'indminn=',indminn,' indmaxx=',indmaxx,' emin=',emin, + & ' emax=',emax + do i=-max_ene,max_ene + entropy(i)=(emin+i*delte)*betbol + enddo + read (ientin,*) (ijunk,ejunk,entropy(i),i=indminn,indmaxx) + indmin=indminn + indmax=indmaxx + write (iout,*) 'indminn=',indminn,' indmaxx=',indmaxx, + & ' emin=',emin,' emax=',emax + write (iout,'(/a)') 'Initial entropy' + do i=indminn,indmaxx + write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) + enddo + endif ! ent_read +C Read the pool of conformations + call read_pool +C---------------------------------------------------------------------------- +C Entropy-sampling simulations with continually updated entropy +C Loop thru simulations +C---------------------------------------------------------------------------- + DO ISWEEP=1,NSWEEP +C---------------------------------------------------------------------------- +C Take a conformation from the pool +C---------------------------------------------------------------------------- + if (npool.gt.0) then + ii=iran_num(1,npool) + do i=1,nvar + varia(i)=xpool(i,ii) + enddo + write (iout,*) 'Took conformation',ii,' from the pool energy=', + & epool(ii) + call var_to_geom(nvar,varia) +C Print internal coordinates of the initial conformation + call intout + else + call gen_rand_conf(1,*20) + endif +C---------------------------------------------------------------------------- +C Compute and print initial energies. +C---------------------------------------------------------------------------- + nsave=0 +#ifdef MPL + if (MyID.eq.MasterID) then + do i=1,nctasks + nsave_part(i)=0 + enddo + endif +#endif + Kwita=0 + WhatsUp=0 + write (iout,'(/80(1h*)/a,i2/80(1h*)/)') 'MCE iteration #',isweep + write (iout,'(/80(1h*)/a)') 'Initial energies:' + call chainbuild + call etotal(energia(0)) + etot = energia(0) + call enerprint(energia(0)) +C Minimize the energy of the first conformation. + if (minim) then + call geom_to_var(nvar,varia) + call minimize(etot,varia,iretcode,nfun) + call etotal(energia(0)) + etot = energia(0) + write (iout,'(/80(1h*)/a/80(1h*))') + & 'Results of the first energy minimization:' + call enerprint(energia(0)) + endif + if (refstr) then + call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup),nsup,przes, + & obr,non_conv) + rms=dsqrt(rms) + call contact(.false.,ncont,icont,co) + frac=contact_fract(ncont,ncont_ref,icont,icont_ref) + write (iout,'(a,f8.3,a,f8.3,a,f8.3)') + & 'RMS deviation from the reference structure:',rms, + & ' % of native contacts:',frac*100,' contact order:',co + write (istat,'(i5,11(1pe14.5))') 0, + & (energia(print_order(i)),i=1,nprint_ene),etot,rms,frac,co + else + write (istat,'(i5,9(1pe14.5))') 0, + & (energia(print_order(i)),i=1,nprint_ene),etot + endif + close(istat) + neneval=neneval+nfun+1 + if (.not. ent_read) then +C Initialize the entropy array + do i=-max_ene,max_ene + emin=etot +C Uncomment the line below for actual entropic sampling (start with uniform +C energy distribution). +c entropy(i)=0.0D0 +C Uncomment the line below for multicanonical sampling (start with Boltzmann +C distribution). + entropy(i)=(emin+i*delte)*betbol + enddo + emax=10000000.0D0 + emin=etot + write (iout,'(/a)') 'Initial entropy' + do i=indminn,indmaxx + write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) + enddo + endif ! ent_read +#ifdef MPL + call recv_stop_sig(Kwita) + if (whatsup.eq.1) then + call send_stop_sig(-2) + not_done=.false. + else if (whatsup.le.-2) then + not_done=.false. + else if (whatsup.eq.2) then + not_done=.false. + else + not_done=.true. + endif +#else + not_done = (iretcode.ne.11) +#endif + write (iout,'(/80(1h*)/20x,a/80(1h*))') + & 'Enter Monte Carlo procedure.' + close(igeom) + call briefout(0,etot) + do i=1,nvar + varold(i)=varia(i) + enddo + eold=etot + indeold=(eold-emin)/delte + deix=eold-(emin+indeold*delte) + dent=entropy(indeold+1)-entropy(indeold) +cd write (iout,*) 'indeold=',indeold,' deix=',deix,' dent=',dent +cd write (*,*) 'Processor',MyID,' indeold=',indeold,' deix=',deix, +cd & ' dent=',dent + sold=entropy(indeold)+(dent/delte)*deix + elowest=etot + write (iout,*) 'eold=',eold,' sold=',sold,' elowest=',etot + write (*,*) 'Processor',MyID,' eold=',eold,' sold=',sold, + & ' elowest=',etot + if (minim) call zapis(varia,etot) + nminima(1)=1.0D0 +C NACC is the counter for the accepted conformations of a given processor + nacc=0 +C NACC_TOT counts the total number of accepted conformations + nacc_tot=0 +#ifdef MPL + if (MyID.eq.MasterID) then + call receive_MCM_info + else + call send_MCM_info(2) + endif +#endif + do iene=indminn,indmaxx + nhist(iene)=0.0D0 + enddo + do i=2,maxsave + nminima(i)=0.0D0 + enddo +C Main loop. +c---------------------------------------------------------------------------- + elowest=1.0D10 + ehighest=-1.0D10 + it=0 + do while (not_done) + it=it+1 + if (print_mc.gt.0) write (iout,'(80(1h*)/20x,a,i7)') + & 'Beginning iteration #',it +C Initialize local counter. + ntrial=0 ! # of generated non-overlapping confs. + noverlap=0 ! # of overlapping confs. + accepted=.false. + do while (.not. accepted .and. WhatsUp.eq.0 .and. Kwita.eq.0) + ntrial=ntrial+1 +C Retrieve the angles of previously accepted conformation + do j=1,nvar + varia(j)=varold(j) + enddo +cd write (iout,'(a)') 'Old variables:' +cd write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) + call var_to_geom(nvar,varia) +C Rebuild the chain. + call chainbuild + MoveType=0 + nbond=0 + lprint=.true. +C Decide whether to generate a random conformation or perturb the old one + RandOrPert=ran_number(0.0D0,1.0D0) + if (RandOrPert.gt.RanFract) then + if (print_mc.gt.0) + & write (iout,'(a)') 'Perturbation-generated conformation.' + call perturb(error,lprint,MoveType,nbond,1.0D0) + if (error) goto 20 + if (MoveType.lt.1 .or. MoveType.gt.MaxMoveType) then + write (iout,'(/a,i7,a/)') 'Error - unknown MoveType=', + & MoveType,' returned from PERTURB.' + goto 20 + endif + call chainbuild + else + MoveType=0 + moves(0)=moves(0)+1 + nstart_grow=iran_num(3,nres) + if (print_mc.gt.0) + & write (iout,'(2a,i3)') 'Random-generated conformation', + & ' - chain regrown from residue',nstart_grow + call gen_rand_conf(nstart_grow,*30) + endif + call geom_to_var(nvar,varia) +cd write (iout,'(a)') 'New variables:' +cd write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) + ngen=ngen+1 + if (print_mc.gt.0) write (iout,'(a,i5,a,i10,a,i10)') + & 'Processor',MyId,' trial move',ntrial,' total generated:',ngen + if (print_mc.gt.0) write (*,'(a,i5,a,i10,a,i10)') + & 'Processor',MyId,' trial move',ntrial,' total generated:',ngen + call etotal(energia(0)) + etot = energia(0) +c call enerprint(energia(0)) +c write (iout,'(2(a,1pe14.5))') 'Etot=',Etot,' Elowest=',Elowest + if (etot-elowest.gt.overlap_cut) then + write (iout,'(a,i5,a,1pe14.5)') 'Iteration',it, + & ' Overlap detected in the current conf.; energy is',etot + neneval=neneval+1 + accepted=.false. + noverlap=noverlap+1 + if (noverlap.gt.maxoverlap) then + write (iout,'(a)') 'Too many overlapping confs.' + goto 20 + endif + else + if (minim) then + call minimize(etot,varia,iretcode,nfun) +cd write (iout,'(a)') 'Variables after minimization:' +cd write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) + call etotal(energia(0)) + etot = energia(0) + neneval=neneval+nfun+1 + endif + if (print_mc.gt.2) then + write (iout,'(a)') 'Total energies of trial conf:' + call enerprint(energia(0)) + else if (print_mc.eq.1) then + write (iout,'(a,i6,a,1pe16.6)') + & 'Trial conformation:',ngen,' energy:',etot + endif +C-------------------------------------------------------------------------- +C... Acceptance test +C-------------------------------------------------------------------------- + accepted=.false. + if (WhatsUp.eq.0) + & call accepting(etot,eold,scur,sold,varia,varold, + & accepted) + if (accepted) then + nacc=nacc+1 + nacc_tot=nacc_tot+1 + if (elowest.gt.etot) elowest=etot + if (ehighest.lt.etot) ehighest=etot + moves_acc(MoveType)=moves_acc(MoveType)+1 + if (MoveType.eq.1) then + nbond_acc(nbond)=nbond_acc(nbond)+1 + endif +C Check against conformation repetitions. + irep=conf_comp(varia,etot) +#if defined(AIX) || defined(PGI) + open (istat,file=statname,position='append') +#else + open (istat,file=statname,access='append') +#endif + if (refstr) then + call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup),nsup, + & przes,obr,non_conv) + rms=dsqrt(rms) + call contact(.false.,ncont,icont,co) + frac=contact_fract(ncont,ncont_ref,icont,icont_ref) + if (print_mc.gt.0) + & write (iout,'(a,f8.3,a,f8.3,a,f8.3)') + & 'RMS deviation from the reference structure:',rms, + & ' % of native contacts:',frac*100,' contact order:',co + if (print_stat) + & write (istat,'(i5,11(1pe14.5))') it, + & (energia(print_order(i)),i=1,nprint_ene),etot, + & rms,frac,co + elseif (print_stat) then + write (istat,'(i5,10(1pe14.5))') it, + & (energia(print_order(i)),i=1,nprint_ene),etot + endif + close(istat) + if (print_mc.gt.1) + & call statprint(nacc,nfun,iretcode,etot,elowest) +C Print internal coordinates. + if (print_int) call briefout(nacc,etot) +#ifdef MPL + if (MyID.ne.MasterID) then + call recv_stop_sig(Kwita) +cd print *,'Processor:',MyID,' STOP=',Kwita + if (irep.eq.0) then + call send_MCM_info(2) + else + call send_MCM_info(1) + endif + endif +#endif +C Store the accepted conf. and its energy. + eold=etot + sold=scur + do i=1,nvar + varold(i)=varia(i) + enddo + if (irep.eq.0) then + irep=nsave+1 +cd write (iout,*) 'Accepted conformation:' +cd write (iout,*) (rad2deg*varia(i),i=1,nphi) + if (minim) call zapis(varia,etot) + do i=1,n_ene + ener(i,nsave)=energia(i) + enddo + ener(n_ene+1,nsave)=etot + ener(n_ene+2,nsave)=frac + endif + nminima(irep)=nminima(irep)+1.0D0 +c print *,'irep=',irep,' nminima=',nminima(irep) +#ifdef MPL + if (Kwita.eq.0) call recv_stop_sig(kwita) +#endif + endif ! accepted + endif ! overlap +#ifdef MPL + if (MyID.eq.MasterID) then + call receive_MCM_info + if (nacc_tot.ge.maxacc) accepted=.true. + endif +#endif + if (ntrial.gt.maxtrial_iter .and. npool.gt.0) then +C Take a conformation from the pool + ii=iran_num(1,npool) + do i=1,nvar + varia(i)=xpool(i,ii) + enddo + write (iout,*) 'Iteration',it,' max. # of trials exceeded.' + write (iout,*) + & 'Take conformation',ii,' from the pool energy=',epool(ii) + if (print_mc.gt.2) + & write (iout,'(10f8.3)') (rad2deg*varia(i),i=1,nvar) + ntrial=0 + endif ! (ntrial.gt.maxtrial_iter .and. npool.gt.0) + 30 continue + enddo ! accepted +#ifdef MPL + if (MyID.eq.MasterID) then + call receive_MCM_info + endif + if (Kwita.eq.0) call recv_stop_sig(kwita) +#endif + if (ovrtim()) WhatsUp=-1 +cd write (iout,*) 'WhatsUp=',WhatsUp,' Kwita=',Kwita + not_done = (nacc_tot.lt.maxacc) .and. (WhatsUp.eq.0) + & .and. (Kwita.eq.0) +cd write (iout,*) 'not_done=',not_done +#ifdef MPL + if (Kwita.lt.0) then + print *,'Processor',MyID, + & ' has received STOP signal =',Kwita,' in EntSamp.' +cd print *,'not_done=',not_done + if (Kwita.lt.-1) WhatsUp=Kwita + else if (nacc_tot.ge.maxacc) then + print *,'Processor',MyID,' calls send_stop_sig,', + & ' because a sufficient # of confs. have been collected.' +cd print *,'not_done=',not_done + call send_stop_sig(-1) + else if (WhatsUp.eq.-1) then + print *,'Processor',MyID, + & ' calls send_stop_sig because of timeout.' +cd print *,'not_done=',not_done + call send_stop_sig(-2) + endif +#endif + enddo ! not_done + +C----------------------------------------------------------------- +C... Construct energy histogram & update entropy +C----------------------------------------------------------------- + go to 21 + 20 WhatsUp=-3 +#ifdef MPL + write (iout,*) 'Processor',MyID, + & ' is broadcasting ERROR-STOP signal.' + write (*,*) 'Processor',MyID, + & ' is broadcasting ERROR-STOP signal.' + call send_stop_sig(-3) +#endif + 21 continue +#ifdef MPL + if (MyID.eq.MasterID) then +c call receive_MCM_results + call receive_energies +#endif + do i=1,nsave + if (esave(i).lt.elowest) elowest=esave(i) + if (esave(i).gt.ehighest) ehighest=esave(i) + enddo + write (iout,'(a,i10)') '# of accepted confs:',nacc_tot + write (iout,'(a,f10.5,a,f10.5)') 'Lowest energy:',elowest, + & ' Highest energy',ehighest + if (isweep.eq.1 .and. .not.ent_read) then + emin=elowest + emax=ehighest + write (iout,*) 'EMAX=',emax + indminn=0 + indmaxx=(ehighest-emin)/delte + indmin=indminn + indmax=indmaxx + do i=-max_ene,max_ene + entropy(i)=(emin+i*delte)*betbol + enddo + ent_read=.true. + else + indmin=(elowest-emin)/delte + indmax=(ehighest-emin)/delte + if (indmin.lt.indminn) indminn=indmin + if (indmax.gt.indmaxx) indmaxx=indmax + endif + write(iout,*)'indminn=',indminn,' indmaxx=',indmaxx +C Construct energy histogram + do i=1,nsave + inde=(esave(i)-emin)/delte + nhist(inde)=nhist(inde)+nminima(i) + enddo +C Update entropy (density of states) + do i=indmin,indmax + if (nhist(i).gt.0) then + entropy(i)=entropy(i)+dlog(nhist(i)+0.0D0) + endif + enddo +Cd do i=indmaxx+1 +Cd entropy(i)=1.0D+10 +Cd enddo + write (iout,'(/80(1h*)/a,i2/80(1h*)/)') + & 'End of macroiteration',isweep + write (iout,'(a,f10.5,a,f10.5)') 'Elowest=',elowest, + & ' Ehighest=',ehighest + write (iout,'(a)') 'Frequecies of minima' + do i=1,nsave + write (iout,'(i5,f5.0,f10.5)') i,nminima(i),esave(i) + enddo + write (iout,'(/a)') 'Energy histogram' + do i=indminn,indmaxx + write (iout,'(i5,2f10.5)') i,emin+i*delte,nhist(i) + enddo + write (iout,'(/a)') 'Entropy' + do i=indminn,indmaxx + write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) + enddo +C----------------------------------------------------------------- +C... End of energy histogram construction +C----------------------------------------------------------------- +#ifdef MPL + entropy(-max_ene-4)=dfloat(indminn) + entropy(-max_ene-3)=dfloat(indmaxx) + entropy(-max_ene-2)=emin + entropy(-max_ene-1)=emax + call send_MCM_update +cd print *,entname,ientout + open (ientout,file=entname,status='unknown') + write (ientout,'(2i5,2e25.17)') indminn,indmaxx,emin,emax + do i=indminn,indmaxx + write (ientout,'(i5,f10.5,f20.15)') i,emin+i*delte,entropy(i) + enddo + close(ientout) + else + write (iout,'(a)') 'Frequecies of minima' + do i=1,nsave + write (iout,'(i5,f5.0,f10.5)') i,nminima(i),esave(i) + enddo +c call send_MCM_results + call send_energies + call receive_MCM_update + indminn=entropy(-max_ene-4) + indmaxx=entropy(-max_ene-3) + emin=entropy(-max_ene-2) + emax=entropy(-max_ene-1) + write (iout,*) 'Received from master:' + write (iout,*) 'indminn=',indminn,' indmaxx=',indmaxx, + & ' emin=',emin,' emax=',emax + write (iout,'(/a)') 'Entropy' + do i=indminn,indmaxx + write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) + enddo + endif + if (WhatsUp.lt.-1) return +#else + if (ovrtim() .or. WhatsUp.lt.0) return +#endif + + write (iout,'(/80(1h*)/20x,a)') 'Summary run statistics:' + call statprint(nacc,nfun,iretcode,etot,elowest) + write (iout,'(a)') + & 'Statistics of multiple-bond motions. Total motions:' + write (iout,'(16i5)') (nbond_move(i),i=1,Nbm) + write (iout,'(a)') 'Accepted motions:' + write (iout,'(16i5)') (nbond_acc(i),i=1,Nbm) + write (iout,'(a,i10)') 'Number of chain regrowths:',nregrow + write (iout,'(a,i10)') 'Accepted chain regrowths:',nregrow_acc + +C--------------------------------------------------------------------------- + ENDDO ! ISWEEP +C--------------------------------------------------------------------------- + + runtime=tcpu() + + if (isweep.eq.nsweep .and. it.ge.maxacc) + &write (iout,'(/80(1h*)/20x,a/80(1h*)/)') 'All iterations done.' + return + end +c------------------------------------------------------------------------------ + subroutine accepting(ecur,eold,scur,sold,x,xold,accepted) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.MCM' + include 'COMMON.MCE' + include 'COMMON.IOUNITS' + include 'COMMON.VAR' +#ifdef MPL + include 'COMMON.INFO' +#endif + include 'COMMON.GEO' + double precision ecur,eold,xx,ran_number,bol + double precision x(maxvar),xold(maxvar) + double precision tole /1.0D-1/, tola /5.0D0/ + logical accepted +C Check if the conformation is similar. +cd write (iout,*) 'Enter ACCEPTING' +cd write (iout,*) 'Old PHI angles:' +cd write (iout,*) (rad2deg*xold(i),i=1,nphi) +cd write (iout,*) 'Current angles' +cd write (iout,*) (rad2deg*x(i),i=1,nphi) +cd ddif=dif_ang(nphi,x,xold) +cd write (iout,*) 'Angle norm:',ddif +cd write (iout,*) 'ecur=',ecur,' emax=',emax + if (ecur.gt.emax) then + accepted=.false. + if (print_mc.gt.0) + & write (iout,'(a)') 'Conformation rejected as too high in energy' + return + else if (dabs(ecur-eold).lt.tole .and. + & dif_ang(nphi,x,xold).lt.tola) then + accepted=.false. + if (print_mc.gt.0) + & write (iout,'(a)') 'Conformation rejected as too similar' + return + endif +C Else evaluate the entropy of the conf and compare it with that of the previous +C one. + indecur=(ecur-emin)/delte + if (iabs(indecur).gt.max_ene) then + write (iout,'(a,2i5)') + & 'Accepting: Index out of range:',indecur + scur=1000.0D0 + else if (indecur.eq.indmaxx) then + scur=entropy(indecur) + if (print_mc.gt.0) write (iout,*)'Energy boundary reached', + & indmaxx,indecur,entropy(indecur) + else + deix=ecur-(emin+indecur*delte) + dent=entropy(indecur+1)-entropy(indecur) + scur=entropy(indecur)+(dent/delte)*deix + endif +cd print *,'Processor',MyID,' ecur=',ecur,' indecur=',indecur, +cd & ' scur=',scur,' eold=',eold,' sold=',sold +cd print *,'deix=',deix,' dent=',dent,' delte=',delte + if (print_mc.gt.1) then + write(iout,*)'ecur=',ecur,' indecur=',indecur,' scur=',scur + write(iout,*)'eold=',eold,' sold=',sold + endif + if (scur.le.sold) then + accepted=.true. + else +C Else carry out acceptance test + xx=ran_number(0.0D0,1.0D0) + xxh=scur-sold + if (xxh.gt.50.0D0) then + bol=0.0D0 + else + bol=exp(-xxh) + endif + if (bol.gt.xx) then + accepted=.true. + if (print_mc.gt.0) write (iout,'(a)') + & 'Conformation accepted.' + else + accepted=.false. + if (print_mc.gt.0) write (iout,'(a)') + & 'Conformation rejected.' + endif + endif + return + end +c----------------------------------------------------------------------------- + subroutine read_pool + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.MCM' + include 'COMMON.MCE' + include 'COMMON.VAR' + double precision varia(maxvar) + print '(a)','Call READ_POOL' + do npool=1,max_pool + print *,'i=',i + read (intin,'(i5,f10.5)',end=10,err=10) iconf,epool(npool) + if (epool(npool).eq.0.0D0) goto 10 + call read_angles(intin,*10) + call geom_to_var(nvar,xpool(1,npool)) + enddo + goto 11 + 10 npool=npool-1 + 11 write (iout,'(a,i5)') 'Number of pool conformations:',npool + if (print_mc.gt.2) then + do i=1,npool + write (iout,'(a,i5,a,1pe14.5)') 'Pool conformation',i,' energy', + & epool(i) + write (iout,'(10f8.3)') (rad2deg*xpool(j,i),j=1,nvar) + enddo + endif ! (print_mc.gt.2) + return + end diff --git a/source/unres/src_MD-DFA-restraints/fitsq.f b/source/unres/src_MD-DFA-restraints/fitsq.f new file mode 100644 index 0000000..36cbd30 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/gauss.f b/source/unres/src_MD-DFA-restraints/gauss.f new file mode 100644 index 0000000..7ba6e1d --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/gauss.f @@ -0,0 +1,69 @@ + subroutine gauss(RO,AP,MT,M,N,*) +c +c CALCULATES (RO**(-1))*AP BY GAUSS ELIMINATION +c RO IS A SQUARE MATRIX +c THE CALCULATED PRODUCT IS STORED IN AP +c ABNORMAL EXIT IF RO IS SINGULAR +c + integer MT, M, N, M1,I,J,IM, + & I1,MI,MI1 + double precision RO(MT,M),AP(MT,N),X,RM,PR, + & Y + if(M.ne.1)goto 10 + X=RO(1,1) + if(dabs(X).le.1.0D-13) return 1 + X=1.0/X + do 16 I=1,N +16 AP(1,I)=AP(1,I)*X + return +10 continue + M1=M-1 + DO1 I=1,M1 + IM=I + RM=DABS(RO(I,I)) + I1=I+1 + do 2 J=I1,M + if(DABS(RO(J,I)).LE.RM) goto 2 + RM=DABS(RO(J,I)) + IM=J +2 continue + If(IM.eq.I)goto 17 + do 3 J=1,N + PR=AP(I,J) + AP(I,J)=AP(IM,J) +3 AP(IM,J)=PR + do 4 J=I,M + PR=RO(I,J) + RO(I,J)=RO(IM,J) +4 RO(IM,J)=PR +17 X=RO(I,I) + if(dabs(X).le.1.0E-13) return 1 + X=1.0/X + do 5 J=1,N +5 AP(I,J)=X*AP(I,J) + do 6 J=I1,M +6 RO(I,J)=X*RO(I,J) + do 7 J=I1,M + Y=RO(J,I) + do 8 K=1,N +8 AP(J,K)=AP(J,K)-Y*AP(I,K) + do 9 K=I1,M +9 RO(J,K)=RO(J,K)-Y*RO(I,K) +7 continue +1 continue + X=RO(M,M) + if(dabs(X).le.1.0E-13) return 1 + X=1.0/X + do 11 J=1,N +11 AP(M,J)=X*AP(M,J) + do 12 I=1,M1 + MI=M-I + MI1=MI+1 + do 14 J=1,N + X=AP(MI,J) + do 15 K=MI1,M +15 X=X-AP(K,J)*RO(MI,K) +14 AP(MI,J)=X +12 continue + return + end diff --git a/source/unres/src_MD-DFA-restraints/gen_rand_conf.F b/source/unres/src_MD-DFA-restraints/gen_rand_conf.F new file mode 100644 index 0000000..6cc31ba --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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) +c print *,'phi(',i,')=',phi(i) + theta(i-1)=gen_theta(it2,phi(i-1),phi(i)) + if (it2.ne.10) then + nsi=0 + fail=.true. + do while (fail.and.nsi.le.maxsi) + call gen_side(it2,theta(i-1),alph(i-2),omeg(i-2),fail) + nsi=nsi+1 + enddo + if (nsi.gt.maxsi) return1 + endif + call locate_next_res(i-1) + endif + theta(i)=gen_theta(it1,phi(i),phi(i+1)) + if (it1.ne.10) then + nsi=0 + fail=.true. + do while (fail.and.nsi.le.maxsi) + call gen_side(it1,theta(i),alph(i-1),omeg(i-1),fail) + nsi=nsi+1 + enddo + if (nsi.gt.maxsi) return1 + endif + call locate_next_res(i) + if (overlap(i-1)) then + if (nit.lt.maxnit) then + back=.true. + nit=nit+1 + else + nit=0 + if (i.gt.3) then + back=.true. + i=i-1 + else + write (iout,'(a)') + & 'Cannot generate non-overlaping conformation. Increase MAXNIT.' + write (*,'(a)') + & 'Cannot generate non-overlaping conformation. Increase MAXNIT.' + return1 + endif + endif + else + back=.false. + nit=0 + i=i+1 + endif + niter=niter+1 + enddo + if (niter.ge.maxgen) then + write (iout,'(a,2i5)') + & 'Too many trials in conformation generation',niter,maxgen + write (*,'(a,2i5)') + & 'Too many trials in conformation generation',niter,maxgen + return1 + endif + do j=1,3 + c(j,nres+1)=c(j,1) + c(j,nres+nres)=c(j,nres) + enddo + return + end +c------------------------------------------------------------------------- + logical function overlap(i) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + data redfac /0.5D0/ + overlap=.false. + iti=itype(i) + if (iti.gt.ntyp) return +C Check for SC-SC overlaps. +cd print *,'nnt=',nnt,' nct=',nct + do j=nnt,i-1 + itj=itype(j) + if (j.lt.i-1 .or. ipot.ne.4) then + rcomp=sigmaii(iti,itj) + else + rcomp=sigma(iti,itj) + endif +cd print *,'j=',j + if (dist(nres+i,nres+j).lt.redfac*rcomp) then + overlap=.true. +c print *,'overlap, SC-SC: i=',i,' j=',j, +c & ' dist=',dist(nres+i,nres+j),' rcomp=', +c & rcomp + return + endif + enddo +C Check for overlaps between the added peptide group and the preceding +C SCs. + iteli=itel(i) + do j=1,3 + c(j,maxres2+1)=0.5D0*(c(j,i)+c(j,i+1)) + enddo + do j=nnt,i-2 + itj=itype(j) +cd print *,'overlap, p-Sc: i=',i,' j=',j, +cd & ' dist=',dist(nres+j,maxres2+1) + if (dist(nres+j,maxres2+1).lt.4.0D0*redfac) then + overlap=.true. + return + endif + enddo +C Check for overlaps between the added side chain and the preceding peptide +C groups. + do j=1,nnt-2 + do k=1,3 + c(k,maxres2+1)=0.5D0*(c(k,j)+c(k,j+1)) + enddo +cd print *,'overlap, SC-p: i=',i,' j=',j, +cd & ' dist=',dist(nres+i,maxres2+1) + if (dist(nres+i,maxres2+1).lt.4.0D0*redfac) then + overlap=.true. + return + endif + enddo +C Check for p-p overlaps + do j=1,3 + c(j,maxres2+2)=0.5D0*(c(j,i)+c(j,i+1)) + enddo + do j=nnt,i-2 + itelj=itel(j) + do k=1,3 + c(k,maxres2+2)=0.5D0*(c(k,j)+c(k,j+1)) + enddo +cd print *,'overlap, p-p: i=',i,' j=',j, +cd & ' dist=',dist(maxres2+1,maxres2+2) + if(iteli.ne.0.and.itelj.ne.0)then + if (dist(maxres2+1,maxres2+2).lt.rpp(iteli,itelj)*redfac) then + overlap=.true. + return + endif + endif + enddo + return + end +c-------------------------------------------------------------------------- + double precision function gen_phi(i,it1,it2) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.BOUNDS' +c gen_phi=ran_number(-pi,pi) +C 8/13/98 Generate phi using pre-defined boundaries + gen_phi=ran_number(phibound(1,i),phibound(2,i)) + return + end +c--------------------------------------------------------------------------- + double precision function gen_theta(it,gama,gama1) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + double precision y(2),z(2) + double precision theta_max,theta_min +c print *,'gen_theta: it=',it + theta_min=0.05D0*pi + theta_max=0.95D0*pi + if (dabs(gama).gt.dwapi) then + y(1)=dcos(gama) + y(2)=dsin(gama) + else + y(1)=0.0D0 + y(2)=0.0D0 + endif + if (dabs(gama1).gt.dwapi) then + z(1)=dcos(gama1) + z(2)=dsin(gama1) + else + z(1)=0.0D0 + z(2)=0.0D0 + endif + thet_pred_mean=a0thet(it) + do k=1,2 + thet_pred_mean=thet_pred_mean+athet(k,it)*y(k)+bthet(k,it)*z(k) + enddo + sig=polthet(3,it) + do j=2,0,-1 + sig=sig*thet_pred_mean+polthet(j,it) + enddo + sig=0.5D0/(sig*sig+sigc0(it)) + ak=dexp(gthet(1,it)- + &0.5D0*((gthet(2,it)-thet_pred_mean)/gthet(3,it))**2) +c print '(i5,5(1pe14.4))',it,(gthet(j,it),j=1,3) +c print '(5(1pe14.4))',thet_pred_mean,theta0(it),sig,sig0(it),ak + theta_temp=binorm(thet_pred_mean,theta0(it),sig,sig0(it),ak) + if (theta_temp.lt.theta_min) theta_temp=theta_min + if (theta_temp.gt.theta_max) theta_temp=theta_max + gen_theta=theta_temp +c print '(a)','Exiting GENTHETA.' + return + end +c------------------------------------------------------------------------- + subroutine gen_side(it,the,al,om,fail) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.SETUP' + include 'COMMON.IOUNITS' + double precision MaxBoxLen /10.0D0/ + double precision Ap_inv(3,3),a(3,3),z(3,maxlob),W1(maxlob), + & sumW(0:maxlob),y(2),cm(2),eig(2),box(2,2),work(100),detAp(maxlob) + double precision eig_limit /1.0D-8/ + double precision Big /10.0D0/ + double precision vec(3,3) + logical lprint,fail,lcheck + lcheck=.false. + lprint=.false. + fail=.false. + if (the.eq.0.0D0 .or. the.eq.pi) then +#ifdef MPI + write (*,'(a,i4,a,i3,a,1pe14.5)') + & 'CG Processor:',me,' Error in GenSide: it=',it,' theta=',the +#else +cd write (iout,'(a,i3,a,1pe14.5)') +cd & 'Error in GenSide: it=',it,' theta=',the +#endif + fail=.true. + return + endif + tant=dtan(the-pipol) + nlobit=nlob(it) + if (lprint) then +#ifdef MPI + print '(a,i4,a)','CG Processor:',me,' Enter Gen_Side.' + write (iout,'(a,i4,a)') 'Processor:',me,' Enter Gen_Side.' +#endif + print *,'it=',it,' nlobit=',nlobit,' the=',the,' tant=',tant + write (iout,*) 'it=',it,' nlobit=',nlobit,' the=',the, + & ' tant=',tant + endif + do i=1,nlobit + zz1=tant-censc(1,i,it) + do k=1,3 + do l=1,3 + a(k,l)=gaussc(k,l,i,it) + enddo + enddo + detApi=a(2,2)*a(3,3)-a(2,3)**2 + Ap_inv(2,2)=a(3,3)/detApi + Ap_inv(2,3)=-a(2,3)/detApi + Ap_inv(3,2)=Ap_inv(2,3) + Ap_inv(3,3)=a(2,2)/detApi + if (lprint) then + write (*,'(/a,i2/)') 'Cluster #',i + write (*,'(3(1pe14.5),5x,1pe14.5)') + & ((a(l,k),l=1,3),censc(k,i,it),k=1,3) + write (iout,'(/a,i2/)') 'Cluster #',i + write (iout,'(3(1pe14.5),5x,1pe14.5)') + & ((a(l,k),l=1,3),censc(k,i,it),k=1,3) + endif + W1i=0.0D0 + do k=2,3 + do l=2,3 + W1i=W1i+a(k,1)*a(l,1)*Ap_inv(k,l) + enddo + enddo + W1i=a(1,1)-W1i + W1(i)=dexp(bsc(i,it)-0.5D0*W1i*zz1*zz1) +c if (lprint) write(*,'(a,3(1pe15.5)/)') +c & 'detAp, W1, anormi',detApi,W1i,anormi + do k=2,3 + zk=censc(k,i,it) + do l=2,3 + zk=zk+zz1*Ap_inv(k,l)*a(l,1) + enddo + z(k,i)=zk + enddo + detAp(i)=dsqrt(detApi) + enddo + + if (lprint) then + print *,'W1:',(w1(i),i=1,nlobit) + print *,'detAp:',(detAp(i),i=1,nlobit) + print *,'Z' + do i=1,nlobit + print '(i2,3f10.5)',i,(rad2deg*z(j,i),j=2,3) + enddo + write (iout,*) 'W1:',(w1(i),i=1,nlobit) + write (iout,*) 'detAp:',(detAp(i),i=1,nlobit) + write (iout,*) 'Z' + do i=1,nlobit + write (iout,'(i2,3f10.5)') i,(rad2deg*z(j,i),j=2,3) + enddo + endif + if (lcheck) then +C Writing the distribution just to check the procedure + fac=0.0D0 + dV=deg2rad**2*10.0D0 + sum=0.0D0 + sum1=0.0D0 + do i=1,nlobit + fac=fac+W1(i)/detAp(i) + enddo + fac=1.0D0/(2.0D0*fac*pi) +cd print *,it,'fac=',fac + do ial=90,180,2 + y(1)=deg2rad*ial + do iom=-180,180,5 + y(2)=deg2rad*iom + wart=0.0D0 + do i=1,nlobit + do j=2,3 + do k=2,3 + a(j-1,k-1)=gaussc(j,k,i,it) + enddo + enddo + y2=y(2) + + do iii=-1,1 + + y(2)=y2+iii*dwapi + + wykl=0.0D0 + do j=1,2 + do k=1,2 + wykl=wykl+a(j,k)*(y(j)-z(j+1,i))*(y(k)-z(k+1,i)) + enddo + enddo + wart=wart+W1(i)*dexp(-0.5D0*wykl) + + enddo + + y(2)=y2 + + enddo +c print *,'y',y(1),y(2),' fac=',fac + wart=fac*wart + write (20,'(2f10.3,1pd15.5)') y(1)*rad2deg,y(2)*rad2deg,wart + sum=sum+wart + sum1=sum1+1.0D0 + enddo + enddo +c print *,'it=',it,' sum=',sum*dV,' sum1=',sum1*dV + return + endif + +C Calculate the CM of the system +C + do i=1,nlobit + W1(i)=W1(i)/detAp(i) + enddo + sumW(0)=0.0D0 + do i=1,nlobit + sumW(i)=sumW(i-1)+W1(i) + enddo + cm(1)=z(2,1)*W1(1) + cm(2)=z(3,1)*W1(1) + do j=2,nlobit + cm(1)=cm(1)+z(2,j)*W1(j) + cm(2)=cm(2)+W1(j)*(z(3,1)+pinorm(z(3,j)-z(3,1))) + enddo + cm(1)=cm(1)/sumW(nlobit) + cm(2)=cm(2)/sumW(nlobit) + if (cm(1).gt.Big .or. cm(1).lt.-Big .or. + & cm(2).gt.Big .or. cm(2).lt.-Big) then +cd write (iout,'(a)') +cd & 'Unexpected error in GenSide - CM coordinates too large.' +cd write (iout,'(i5,2(1pe14.5))') it,cm(1),cm(2) +cd write (*,'(a)') +cd & 'Unexpected error in GenSide - CM coordinates too large.' +cd write (*,'(i5,2(1pe14.5))') it,cm(1),cm(2) + fail=.true. + return + endif +cd print *,'CM:',cm(1),cm(2) +C +C Find the largest search distance from CM +C + radmax=0.0D0 + do i=1,nlobit + do j=2,3 + do k=2,3 + a(j-1,k-1)=gaussc(j,k,i,it) + enddo + enddo +#ifdef NAG + call f02faf('N','U',2,a,3,eig,work,100,ifail) +#else + call djacob(2,3,10000,1.0d-10,a,vec,eig) +#endif +#ifdef MPI + if (lprint) then + print *,'*************** CG Processor',me + print *,'CM:',cm(1),cm(2) + write (iout,*) '*************** CG Processor',me + write (iout,*) 'CM:',cm(1),cm(2) + print '(A,8f10.5)','Eigenvalues: ',(1.0/dsqrt(eig(k)),k=1,2) + write (iout,'(A,8f10.5)') + & 'Eigenvalues: ',(1.0/dsqrt(eig(k)),k=1,2) + endif +#endif + if (eig(1).lt.eig_limit) then + write(iout,'(a)') + & 'From Mult_Norm: Eigenvalues of A are too small.' + write(*,'(a)') + & 'From Mult_Norm: Eigenvalues of A are too small.' + fail=.true. + return + endif + radius=0.0D0 +cd print *,'i=',i + do j=1,2 + radius=radius+pinorm(z(j+1,i)-cm(j))**2 + enddo + radius=dsqrt(radius)+3.0D0/dsqrt(eig(1)) + if (radius.gt.radmax) radmax=radius + enddo + if (radmax.gt.pi) radmax=pi +C +C Determine the boundaries of the search rectangle. +C + if (lprint) then + print '(a,4(1pe14.4))','W1: ',(W1(i),i=1,nlob(it) ) + print '(a,4(1pe14.4))','radmax: ',radmax + endif + box(1,1)=dmax1(cm(1)-radmax,0.0D0) + box(2,1)=dmin1(cm(1)+radmax,pi) + box(1,2)=cm(2)-radmax + box(2,2)=cm(2)+radmax + if (lprint) then +#ifdef MPI + print *,'CG Processor',me,' Array BOX:' +#else + print *,'Array BOX:' +#endif + print '(4(1pe14.4))',((box(k,j),k=1,2),j=1,2) + print '(a,4(1pe14.4))','sumW: ',(sumW(i),i=0,nlob(it) ) +#ifdef MPI + write (iout,*)'CG Processor',me,' Array BOX:' +#else + write (iout,*)'Array BOX:' +#endif + write(iout,'(4(1pe14.4))') ((box(k,j),k=1,2),j=1,2) + write(iout,'(a,4(1pe14.4))')'sumW: ',(sumW(i),i=0,nlob(it) ) + endif + if (box(1,2).lt.-MaxBoxLen .or. box(2,2).gt.MaxBoxLen) then +#ifdef MPI + write (iout,'(a,i4,a)') 'CG Processor:',me,': bad sampling box.' + write (*,'(a,i4,a)') 'CG Processor:',me,': bad sampling box.' +#else +c write (iout,'(a)') 'Bad sampling box.' +#endif + fail=.true. + return + endif + which_lobe=ran_number(0.0D0,sumW(nlobit)) +c print '(a,1pe14.4)','which_lobe=',which_lobe + do i=1,nlobit + if (sumW(i-1).le.which_lobe .and. sumW(i).ge.which_lobe) goto 1 + enddo + 1 ilob=i +c print *,'ilob=',ilob,' nlob=',nlob(it) + do i=2,3 + cm(i-1)=z(i,ilob) + do j=2,3 + a(i-1,j-1)=gaussc(i,j,ilob,it) + enddo + enddo +cd print '(a,i4,a)','CG Processor',me,' Calling MultNorm1.' + call mult_norm1(3,2,a,cm,box,y,fail) + if (fail) return + al=y(1) + om=pinorm(y(2)) +cd print *,'al=',al,' om=',om +cd stop + return + end +c--------------------------------------------------------------------------- + double precision function ran_number(x1,x2) +C Calculate a random real number from the range (x1,x2). + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + double precision x1,x2,fctor + data fctor /2147483647.0D0/ +#ifdef MPI + include "mpif.h" + include 'COMMON.SETUP' + ran_number=x1+(x2-x1)*prng_next(me) +#else + call vrnd(ix,1) + ran_number=x1+(x2-x1)*ix/fctor +#endif + return + end +c-------------------------------------------------------------------------- + integer function iran_num(n1,n2) +C Calculate a random integer number from the range (n1,n2). + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + integer n1,n2,ix + real fctor /2147483647.0/ +#ifdef MPI + include "mpif.h" + include 'COMMON.SETUP' + ix=n1+(n2-n1+1)*prng_next(me) + if (ix.lt.n1) ix=n1 + if (ix.gt.n2) ix=n2 + iran_num=ix +#else + call vrnd(ix,1) + ix=n1+(n2-n1+1)*(ix/fctor) + if (ix.gt.n2) ix=n2 + iran_num=ix +#endif + return + end +c-------------------------------------------------------------------------- + double precision function binorm(x1,x2,sigma1,sigma2,ak) + implicit real*8 (a-h,o-z) +c print '(a)','Enter BINORM.' + alowb=dmin1(x1-3.0D0*sigma1,x2-3.0D0*sigma2) + aupb=dmax1(x1+3.0D0*sigma1,x2+3.0D0*sigma2) + seg=sigma1/(sigma1+ak*sigma2) + alen=ran_number(0.0D0,1.0D0) + if (alen.lt.seg) then + binorm=anorm_distr(x1,sigma1,alowb,aupb) + else + binorm=anorm_distr(x2,sigma2,alowb,aupb) + endif +c print '(a)','Exiting BINORM.' + return + end +c----------------------------------------------------------------------- +c double precision function anorm_distr(x,sigma,alowb,aupb) +c implicit real*8 (a-h,o-z) +c print '(a)','Enter ANORM_DISTR.' +c 10 y=ran_number(alowb,aupb) +c expon=dexp(-0.5D0*((y-x)/sigma)**2) +c ran=ran_number(0.0D0,1.0D0) +c if (expon.lt.ran) goto 10 +c anorm_distr=y +c print '(a)','Exiting ANORM_DISTR.' +c return +c end +c----------------------------------------------------------------------- + double precision function anorm_distr(x,sigma,alowb,aupb) + implicit real*8 (a-h,o-z) +c to make a normally distributed deviate with zero mean and unit variance +c + integer iset + real fac,gset,rsq,v1,v2,ran1 + save iset,gset + data iset/0/ + if(iset.eq.0) then +1 v1=2.0d0*ran_number(0.0d0,1.0d0)-1.0d0 + v2=2.0d0*ran_number(0.0d0,1.0d0)-1.0d0 + rsq=v1**2+v2**2 + if(rsq.ge.1.d0.or.rsq.eq.0.0d0) goto 1 + fac=sqrt(-2.0d0*log(rsq)/rsq) + gset=v1*fac + gaussdev=v2*fac + iset=1 + else + gaussdev=gset + iset=0 + endif + anorm_distr=x+gaussdev*sigma + return + end +c------------------------------------------------------------------------ + subroutine mult_norm(lda,n,a,x,fail) +C +C Generate the vector X whose elements obey the multiple-normal distribution +C from exp(-0.5*X'AX). LDA is the leading dimension of the moment matrix A, +C n is the dimension of the problem. FAIL is set at .TRUE., if the smallest +C eigenvalue of the matrix A is close to 0. +C + implicit double precision (a-h,o-z) + double precision a(lda,n),x(n),eig(100),vec(3,3),work(100) + double precision eig_limit /1.0D-8/ + logical fail + fail=.false. +c print '(a)','Enter MULT_NORM.' +C +C Find the smallest eigenvalue of the matrix A. +C +c do i=1,n +c print '(8f10.5)',(a(i,j),j=1,n) +c enddo +#ifdef NAG + call f02faf('V','U',2,a,lda,eig,work,100,ifail) +#else + call djacob(2,lda,10000,1.0d-10,a,vec,eig) +#endif +c print '(8f10.5)',(eig(i),i=1,n) +C print '(a)' +c do i=1,n +c print '(8f10.5)',(a(i,j),j=1,n) +c enddo + if (eig(1).lt.eig_limit) then + print *,'From Mult_Norm: Eigenvalues of A are too small.' + fail=.true. + return + endif +C +C Generate points following the normal distributions along the principal +C axes of the moment matrix. Store in WORK. +C + do i=1,n + sigma=1.0D0/dsqrt(eig(i)) + alim=-3.0D0*sigma + work(i)=anorm_distr(0.0D0,sigma,-alim,alim) + enddo +C +C Transform the vector of normal variables back to the original basis. +C + do i=1,n + xi=0.0D0 + do j=1,n + xi=xi+a(i,j)*work(j) + enddo + x(i)=xi + enddo + return + end +c------------------------------------------------------------------------ + subroutine mult_norm1(lda,n,a,z,box,x,fail) +C +C Generate the vector X whose elements obey the multi-gaussian multi-dimensional +C distribution from sum_{i=1}^m W(i)exp[-0.5*X'(i)A(i)X(i)]. LDA is the +C leading dimension of the moment matrix A, n is the dimension of the +C distribution, nlob is the number of lobes. FAIL is set at .TRUE., if the +C smallest eigenvalue of the matrix A is close to 0. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + double precision a(lda,n),z(n),x(n),box(n,n) + double precision etmp + include 'COMMON.IOUNITS' +#ifdef MP + include 'COMMON.SETUP' +#endif + logical fail +C +C Generate points following the normal distributions along the principal +C axes of the moment matrix. Store in WORK. +C +cd print *,'CG Processor',me,' entered MultNorm1.' +cd print '(2(1pe14.4),3x,1pe14.4)',((a(i,j),j=1,2),z(i),i=1,2) +cd do i=1,n +cd print *,i,box(1,i),box(2,i) +cd enddo + istep = 0 + 10 istep = istep + 1 + if (istep.gt.10000) then +c write (iout,'(a,i4,2a)') 'CG Processor: ',me,': too many steps', +c & ' in MultNorm1.' +c write (*,'(a,i4,2a)') 'CG Processor: ',me,': too many steps', +c & ' in MultNorm1.' +c write (iout,*) 'box',box +c write (iout,*) 'a',a +c write (iout,*) 'z',z + fail=.true. + return + endif + do i=1,n + x(i)=ran_number(box(1,i),box(2,i)) + enddo + ww=0.0D0 + do i=1,n + xi=pinorm(x(i)-z(i)) + ww=ww+0.5D0*a(i,i)*xi*xi + do j=i+1,n + ww=ww+a(i,j)*xi*pinorm(x(j)-z(j)) + enddo + enddo + dec=ran_number(0.0D0,1.0D0) +c print *,(x(i),i=1,n),ww,dexp(-ww),dec +crc if (dec.gt.dexp(-ww)) goto 10 + if(-ww.lt.100) then + etmp=dexp(-ww) + else + return + endif + if (dec.gt.etmp) goto 10 +cd print *,'CG Processor',me,' exitting MultNorm1.' + return + end +c +crc-------------------------------------- + subroutine overlap_sc(scfail) +c Internal and cartesian coordinates must be consistent as input, +c and will be up-to-date on return. +c At the end of this procedure, scfail is true if there are +c overlapping residues left, or false otherwise (success) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.VAR' + include 'COMMON.SBRIDGE' + include 'COMMON.IOUNITS' + logical had_overlaps,fail,scfail + integer ioverlap(maxres),ioverlap_last + + had_overlaps=.false. + call overlap_sc_list(ioverlap,ioverlap_last) + if (ioverlap_last.gt.0) then + write (iout,*) '#OVERLAPing residues ',ioverlap_last + write (iout,'(20i4)') (ioverlap(k),k=1,ioverlap_last) + had_overlaps=.true. + endif + + maxsi=1000 + do k=1,1000 + if (ioverlap_last.eq.0) exit + + do ires=1,ioverlap_last + i=ioverlap(ires) + iti=itype(i) + if (iti.ne.10) then + nsi=0 + fail=.true. + do while (fail.and.nsi.le.maxsi) + call gen_side(iti,theta(i+1),alph(i),omeg(i),fail) + nsi=nsi+1 + enddo + if(fail) goto 999 + endif + enddo + + call chainbuild + call overlap_sc_list(ioverlap,ioverlap_last) +c write (iout,*) 'Overlaping residues ',ioverlap_last, +c & (ioverlap(j),j=1,ioverlap_last) + enddo + + if (k.le.1000.and.ioverlap_last.eq.0) then + scfail=.false. + if (had_overlaps) then + write (iout,*) '#OVERLAPing all corrected after ',k, + & ' random generation' + endif + else + scfail=.true. + write (iout,*) '#OVERLAPing NOT all corrected ',ioverlap_last + write (iout,'(20i4)') (ioverlap(j),j=1,ioverlap_last) + endif + + return + + 999 continue + write (iout,'(a30,i5,a12,i4)') + & '#OVERLAP FAIL in gen_side after',maxsi, + & 'iter for RES',i + scfail=.true. + return + end + + subroutine overlap_sc_list(ioverlap,ioverlap_last) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.VAR' + include 'COMMON.CALC' + logical fail + integer ioverlap(maxres),ioverlap_last + data redfac /0.5D0/ + + ioverlap_last=0 +C Check for SC-SC overlaps and mark residues +c print *,'>>overlap_sc nnt=',nnt,' nct=',nct + ind=0 + do i=iatsc_s,iatsc_e + itypi=itype(i) + itypi1=itype(i+1) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) + dxi=dc_norm(1,nres+i) + dyi=dc_norm(2,nres+i) + dzi=dc_norm(3,nres+i) + dsci_inv=dsc_inv(itypi) +c + do iint=1,nint_gr(i) + do j=istart(i,iint),iend(i,iint) + ind=ind+1 + itypj=itype(j) + dscj_inv=dsc_inv(itypj) + sig0ij=sigma(itypi,itypj) + chi1=chi(itypi,itypj) + chi2=chi(itypj,itypi) + chi12=chi1*chi2 + chip1=chip(itypi) + chip2=chip(itypj) + chip12=chip1*chip2 + alf1=alp(itypi) + alf2=alp(itypj) + alf12=0.5D0*(alf1+alf2) + if (j.gt.i+1) then + rcomp=sigmaii(itypi,itypj) + else + rcomp=sigma(itypi,itypj) + endif +c print '(2(a3,2i3),a3,2f10.5)', +c & ' i=',i,iti,' j=',j,itj,' d=',dist(nres+i,nres+j) +c & ,rcomp + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + rij=dsqrt(rrij) + call sc_angular + sigsq=1.0D0/sigsq + sig=sig0ij*dsqrt(sigsq) + rij_shift=1.0D0/rij-sig+sig0ij + +ct if ( 1.0/rij .lt. redfac*rcomp .or. +ct & rij_shift.le.0.0D0 ) then + if ( rij_shift.le.0.0D0 ) then +cd write (iout,'(a,i3,a,i3,a,f10.5,a,3f10.5)') +cd & 'overlap SC-SC: i=',i,' j=',j, +cd & ' dist=',dist(nres+i,nres+j),' rcomp=', +cd & rcomp,1.0/rij,rij_shift + ioverlap_last=ioverlap_last+1 + ioverlap(ioverlap_last)=i + do k=1,ioverlap_last-1 + if (ioverlap(k).eq.i) ioverlap_last=ioverlap_last-1 + enddo + ioverlap_last=ioverlap_last+1 + ioverlap(ioverlap_last)=j + do k=1,ioverlap_last-1 + if (ioverlap(k).eq.j) ioverlap_last=ioverlap_last-1 + enddo + endif + enddo + enddo + enddo + return + end diff --git a/source/unres/src_MD-DFA-restraints/geomout.F b/source/unres/src_MD-DFA-restraints/geomout.F new file mode 100644 index 0000000..a5c6f96 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/geomout.F @@ -0,0 +1,522 @@ + 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 + if (dyn_ss) then + write(iunit,'(a6,i4,1x,a3,i7,4x,a3,i7)') + & 'SSBOND',i,'CYS',idssb(i)-nnt+1, + & 'CYS',jdssb(i)-nnt+1 + else + write(iunit,'(a6,i4,1x,a3,i7,4x,a3,i7)') + & 'SSBOND',i,'CYS',ihpb(i)-nnt+1-nres, + & 'CYS',jhpb(i)-nnt+1-nres + endif + 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 + if (dyn_ss) then + write (iunit,30) ica(idssb(i))+1,ica(jdssb(i))+1 + else + write (iunit,30) ica(ihpb(i)-nres)+1,ica(jhpb(i)-nres)+1 + endif + 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---------------------------------------------------------------- +#ifdef NOXDR + subroutine cartout(time) +#else + subroutine cartoutx(time) +#endif + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.HEADER' + include 'COMMON.SBRIDGE' + include 'COMMON.DISTFIT' + include 'COMMON.MD' + double precision time +#if defined(AIX) || defined(PGI) + open(icart,file=cartname,position="append") +#else + open(icart,file=cartname,access="append") +#endif + write (icart,'(e15.8,2e15.5,f12.5,$)') time,potE,uconst,t_bath + if (dyn_ss) then + write (icart,'(i4,$)') + & nss,(idssb(j)+nres,jdssb(j)+nres,j=1,nss) + else + write (icart,'(i4,$)') + & nss,(ihpb(j),jhpb(j),j=1,nss) + endif + write (icart,'(i4,20f7.4)') nfrag+npair+3*nfrag_back, + & (qfrag(i),i=1,nfrag),(qpair(i),i=1,npair), + & (utheta(i),ugamma(i),uscdiff(i),i=1,nfrag_back) + write (icart,'(8f10.5)') + & ((c(k,j),k=1,3),j=1,nres), + & ((c(k,j+nres),k=1,3),j=nnt,nct) + close(icart) + return + end +c----------------------------------------------------------------- +#ifndef NOXDR + subroutine cartout(time) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' + include 'COMMON.SETUP' +#else + parameter (me=0) +#endif + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.HEADER' + include 'COMMON.SBRIDGE' + include 'COMMON.DISTFIT' + include 'COMMON.MD' + double precision time + integer iret,itmp + real xcoord(3,maxres2+2),prec + +#ifdef AIX + call xdrfopen_(ixdrf,cartname, "a", iret) + call xdrffloat_(ixdrf, real(time), iret) + call xdrffloat_(ixdrf, real(potE), iret) + call xdrffloat_(ixdrf, real(uconst), iret) + call xdrffloat_(ixdrf, real(uconst_back), iret) + call xdrffloat_(ixdrf, real(t_bath), iret) + call xdrfint_(ixdrf, nss, iret) + do j=1,nss + if (dyn_ss) then + call xdrfint_(ixdrf, idssb(j)+nres, iret) + call xdrfint_(ixdrf, jdssb(j)+nres, iret) + else + call xdrfint_(ixdrf, ihpb(j), iret) + call xdrfint_(ixdrf, jhpb(j), iret) + endif + enddo + call xdrfint_(ixdrf, nfrag+npair+3*nfrag_back, iret) + do i=1,nfrag + call xdrffloat_(ixdrf, real(qfrag(i)), iret) + enddo + do i=1,npair + call xdrffloat_(ixdrf, real(qpair(i)), iret) + enddo + do i=1,nfrag_back + call xdrffloat_(ixdrf, real(utheta(i)), iret) + call xdrffloat_(ixdrf, real(ugamma(i)), iret) + call xdrffloat_(ixdrf, real(uscdiff(i)), iret) + enddo +#else + call xdrfopen(ixdrf,cartname, "a", iret) + call xdrffloat(ixdrf, real(time), iret) + call xdrffloat(ixdrf, real(potE), iret) + call xdrffloat(ixdrf, real(uconst), iret) + call xdrffloat(ixdrf, real(uconst_back), iret) + call xdrffloat(ixdrf, real(t_bath), iret) + call xdrfint(ixdrf, nss, iret) + do j=1,nss + if (dyn_ss) then + call xdrfint(ixdrf, idssb(j)+nres, iret) + call xdrfint(ixdrf, jdssb(j)+nres, iret) + else + call xdrfint(ixdrf, ihpb(j), iret) + call xdrfint(ixdrf, jhpb(j), iret) + endif + enddo + call xdrfint(ixdrf, nfrag+npair+3*nfrag_back, iret) + do i=1,nfrag + call xdrffloat(ixdrf, real(qfrag(i)), iret) + enddo + do i=1,npair + call xdrffloat(ixdrf, real(qpair(i)), iret) + enddo + do i=1,nfrag_back + call xdrffloat(ixdrf, real(utheta(i)), iret) + call xdrffloat(ixdrf, real(ugamma(i)), iret) + call xdrffloat(ixdrf, real(uscdiff(i)), iret) + enddo +#endif + prec=10000.0 + do i=1,nres + do j=1,3 + xcoord(j,i)=c(j,i) + enddo + enddo + do i=nnt,nct + do j=1,3 + xcoord(j,nres+i-nnt+1)=c(j,i+nres) + enddo + enddo + + itmp=nres+nct-nnt+1 +#ifdef AIX + call xdrf3dfcoord_(ixdrf, xcoord, itmp, prec, iret) + call xdrfclose_(ixdrf, iret) +#else + call xdrf3dfcoord(ixdrf, xcoord, itmp, prec, iret) + call xdrfclose(ixdrf, iret) +#endif + return + end +#endif +c----------------------------------------------------------------- + subroutine statout(itime) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.HEADER' + include 'COMMON.SBRIDGE' + include 'COMMON.DISTFIT' + include 'COMMON.MD' + include 'COMMON.REMD' + include 'COMMON.SETUP' + integer itime + double precision energia(0:n_ene) + double precision gyrate + external gyrate + common /gucio/ cm + character*256 line1,line2 + character*4 format1,format2 + character*30 format +#ifdef AIX + if(itime.eq.0) then + open(istat,file=statname,position="append") + endif +#else +#ifdef PGI + open(istat,file=statname,position="append") +#else + open(istat,file=statname,access="append") +#endif +#endif + if (refstr) then + call rms_nac_nnc(rms,frac,frac_nn,co,.false.) + if(tnp .or. tnp1 .or. tnh) then + write (line1,'(i10,f15.2,3f12.3,f12.6,f7.2,4f6.3,3f12.3,i5,$)') + & itime,totT,EK,potE,totE,hhh, + & rms,frac,frac_nn,co,amax,kinetic_T,t_bath,gyrate(),me + format1="a145" + else + write (line1,'(i10,f15.2,3f12.3,f7.2,4f6.3,3f12.3,i5,$)') + & itime,totT,EK,potE,totE, + & rms,frac,frac_nn,co,amax,kinetic_T,t_bath,gyrate(),me + format1="a133" + endif + else + if(tnp .or. tnp1 .or. tnh) then + write (line1,'(i10,f15.2,7f12.3,f12.6,i5,$)') + & itime,totT,EK,potE,totE,hhh, + & amax,kinetic_T,t_bath,gyrate(),me + format1="a126" + else + write (line1,'(i10,f15.2,7f12.3,i5,$)') + & itime,totT,EK,potE,totE, + & amax,kinetic_T,t_bath,gyrate(),me + format1="a114" + endif + endif + if(usampl.and.totT.gt.eq_time) then + write(line2,'(i5,2f9.4,300f7.4)') iset,uconst,uconst_back, + & (qfrag(ii1),ii1=1,nfrag),(qpair(ii2),ii2=1,npair), + & (utheta(i),ugamma(i),uscdiff(i),i=1,nfrag_back) + write(format2,'(a1,i3.3)') "a",23+7*nfrag+7*npair + & +21*nfrag_back + elseif(hremd.gt.0) then + write(line2,'(i5)') iset + format2="a005" + else + format2="a001" + line2=' ' + endif + if (print_compon) then + if(itime.eq.0) then + write(format,'(a1,a4,a1,a4,a10)') "(",format1,",",format2, + & ",100a12)" + write (istat,format) "#","", + & (ename(print_order(i)),i=1,nprint_ene) + endif + write(format,'(a1,a4,a1,a4,a10)') "(",format1,",",format2, + & ",100f12.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_MD-DFA-restraints/gnmr1.f b/source/unres/src_MD-DFA-restraints/gnmr1.f new file mode 100644 index 0000000..905e746 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/gnmr1.f @@ -0,0 +1,43 @@ + double precision function gnmr1(y,ymin,ymax) + implicit none + double precision y,ymin,ymax + double precision wykl /4.0d0/ + if (y.lt.ymin) then + gnmr1=(ymin-y)**wykl/wykl + else if (y.gt.ymax) then + gnmr1=(y-ymax)**wykl/wykl + else + gnmr1=0.0d0 + endif + return + end +c------------------------------------------------------------------------------ + double precision function gnmr1prim(y,ymin,ymax) + implicit none + double precision y,ymin,ymax + double precision wykl /4.0d0/ + if (y.lt.ymin) then + gnmr1prim=-(ymin-y)**(wykl-1) + else if (y.gt.ymax) then + gnmr1prim=(y-ymax)**(wykl-1) + else + gnmr1prim=0.0d0 + endif + return + end +c------------------------------------------------------------------------------ + double precision function harmonic(y,ymax) + implicit none + double precision y,ymax + double precision wykl /2.0d0/ + harmonic=(y-ymax)**wykl + return + end +c------------------------------------------------------------------------------- + double precision function harmonicprim(y,ymax) + double precision y,ymin,ymax + double precision wykl /2.0d0/ + harmonicprim=(y-ymax)*wykl + return + end +c--------------------------------------------------------------------------------- diff --git a/source/unres/src_MD-DFA-restraints/gradient_p.F b/source/unres/src_MD-DFA-restraints/gradient_p.F new file mode 100644 index 0000000..7fec1e8 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/gradient_p.F @@ -0,0 +1,421 @@ + subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.MD' + include 'COMMON.IOUNITS' + include 'COMMON.SCCOR' + external ufparm + integer uiparm(1) + double precision urparm(1) + dimension x(maxvar),g(maxvar) +c +c This subroutine calculates total internal coordinate gradient. +c Depending on the number of function evaluations, either whole energy +c is evaluated beforehand, Cartesian coordinates and their derivatives in +c internal coordinates are reevaluated or only the cartesian-in-internal +c coordinate derivatives are evaluated. The subroutine was designed to work +c with SUMSL. +c +c + icg=mod(nf,2)+1 + +cd print *,'grad',nf,icg + if (nf-nfl+1) 20,30,40 + 20 call func(n,x,nf,f,uiparm,urparm,ufparm) +c write (iout,*) 'grad 20' + if (nf.eq.0) return + goto 40 + 30 call var_to_geom(n,x) + call chainbuild +c write (iout,*) 'grad 30' +C +C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. +C + 40 call cartder +c write (iout,*) 'grad 40' +c print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon +C +C Convert the Cartesian gradient into internal-coordinate gradient. +C + ind=0 + ind1=0 + do i=1,nres-2 + gthetai=0.0D0 + gphii=0.0D0 + do j=i+1,nres-1 + ind=ind+1 +c ind=indmat(i,j) +c print *,'GRAD: i=',i,' jc=',j,' ind=',ind + do k=1,3 + gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) + enddo + do k=1,3 + gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) + enddo + enddo + do j=i+1,nres-1 + ind1=ind1+1 +c ind1=indmat(i,j) +c print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1 + do k=1,3 + gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg) + gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg) + enddo + enddo + if (i.gt.1) g(i-1)=gphii + if (n.gt.nphi) g(nphi+i)=gthetai + enddo + if (n.le.nphi+ntheta) goto 10 + do i=2,nres-1 + if (itype(i).ne.10) then + galphai=0.0D0 + gomegai=0.0D0 + do k=1,3 + galphai=galphai+dxds(k,i)*gradx(k,i,icg) + enddo + do k=1,3 + gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) + enddo + g(ialph(i,1))=galphai + g(ialph(i,1)+nside)=gomegai + endif + enddo +C +C Add the components corresponding to local energy terms. +C + 10 continue + do i=1,nvar +cd write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg) + g(i)=g(i)+gloc(i,icg) + enddo +C Uncomment following three lines for diagnostics. +cd call intout +cd call briefout(0,0.0d0) +cd write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n) + return + end +C------------------------------------------------------------------------- + subroutine grad_restr(n,x,nf,g,uiparm,urparm,ufparm) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.IOUNITS' + external ufparm + integer uiparm(1) + double precision urparm(1) + dimension x(maxvar),g(maxvar) + + icg=mod(nf,2)+1 + if (nf-nfl+1) 20,30,40 + 20 call func_restr(n,x,nf,f,uiparm,urparm,ufparm) +c write (iout,*) 'grad 20' + if (nf.eq.0) return + goto 40 + 30 continue +#ifdef OSF +c Intercept NaNs in the coordinates +c write(iout,*) (var(i),i=1,nvar) + x_sum=0.D0 + do i=1,n + x_sum=x_sum+x(i) + enddo + if (x_sum.ne.x_sum) then + write(iout,*)" *** grad_restr : Found NaN in coordinates" + call flush(iout) + print *," *** grad_restr : Found NaN in coordinates" + return + endif +#endif + call var_to_geom_restr(n,x) + call chainbuild +C +C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. +C + 40 call cartder +C +C Convert the Cartesian gradient into internal-coordinate gradient. +C + + ig=0 + ind=nres-2 + do i=2,nres-2 + IF (mask_phi(i+2).eq.1) THEN + gphii=0.0D0 + do j=i+1,nres-1 + ind=ind+1 + do k=1,3 + gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) + gphii=gphii+dxdv(k+3,ind)*gradx(k,j,icg) + enddo + enddo + ig=ig+1 + g(ig)=gphii + ELSE + ind=ind+nres-1-i + ENDIF + enddo + + + ind=0 + do i=1,nres-2 + IF (mask_theta(i+2).eq.1) THEN + ig=ig+1 + gthetai=0.0D0 + do j=i+1,nres-1 + ind=ind+1 + do k=1,3 + gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) + gthetai=gthetai+dxdv(k,ind)*gradx(k,j,icg) + enddo + enddo + g(ig)=gthetai + ELSE + ind=ind+nres-1-i + ENDIF + enddo + + do i=2,nres-1 + if (itype(i).ne.10) then + IF (mask_side(i).eq.1) THEN + ig=ig+1 + galphai=0.0D0 + do k=1,3 + galphai=galphai+dxds(k,i)*gradx(k,i,icg) + enddo + g(ig)=galphai + ENDIF + endif + enddo + + + do i=2,nres-1 + if (itype(i).ne.10) then + IF (mask_side(i).eq.1) THEN + ig=ig+1 + gomegai=0.0D0 + do k=1,3 + gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) + enddo + g(ig)=gomegai + ENDIF + endif + enddo + +C +C Add the components corresponding to local energy terms. +C + + ig=0 + igall=0 + do i=4,nres + igall=igall+1 + if (mask_phi(i).eq.1) then + ig=ig+1 + g(ig)=g(ig)+gloc(igall,icg) + endif + enddo + + do i=3,nres + igall=igall+1 + if (mask_theta(i).eq.1) then + ig=ig+1 + g(ig)=g(ig)+gloc(igall,icg) + endif + enddo + + do ij=1,2 + do i=2,nres-1 + if (itype(i).ne.10) then + igall=igall+1 + if (mask_side(i).eq.1) then + ig=ig+1 + g(ig)=g(ig)+gloc(igall,icg) + endif + endif + enddo + enddo + +cd do i=1,ig +cd write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i) +cd enddo + return + end +C------------------------------------------------------------------------- + subroutine cartgrad + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.MD' + include 'COMMON.IOUNITS' + include 'COMMON.TIME1' + include 'COMMON.SCCOR' +c +c This subrouting calculates total Cartesian coordinate gradient. +c The subroutine chainbuild_cart and energy MUST be called beforehand. +c +c do i=1,nres +c write (iout,*) "przed sum_grad", gloc_sc(1,i,icg),gloc(i,icg) +c enddo + +#ifdef TIMING + time00=MPI_Wtime() +#endif + icg=1 + call sum_gradient +#ifdef TIMING +#endif +c do i=1,nres +c write (iout,*) "checkgrad", gloc_sc(1,i,icg),gloc(i,icg) +c enddo +cd write (iout,*) "After sum_gradient" +cd do i=1,nres-1 +cd write (iout,*) i," gradc ",(gradc(j,i,icg),j=1,3) +cd write (iout,*) i," gradx ",(gradx(j,i,icg),j=1,3) +cd enddo +c If performing constraint dynamics, add the gradients of the constraint energy + if(usampl.and.totT.gt.eq_time) then + do i=1,nct + do j=1,3 + gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i) + gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i) + enddo + enddo + do i=1,nres-3 + gloc(i,icg)=gloc(i,icg)+dugamma(i) + enddo + do i=1,nres-2 + gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i) + enddo + endif +#ifdef TIMING + time01=MPI_Wtime() +#endif + call intcartderiv +#ifdef TIMING + time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01 +#endif +cd call checkintcartgrad +cd write(iout,*) 'calling int_to_cart' +cd write (iout,*) "gcart, gxcart, gloc before int_to_cart" + do i=1,nct + do j=1,3 + gcart(j,i)=gradc(j,i,icg) + gxcart(j,i)=gradx(j,i,icg) + enddo +cd write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3), +cd & (gxcart(j,i),j=1,3),gloc(i,icg) + enddo +#ifdef TIMING + time01=MPI_Wtime() +#endif + call int_to_cart +#ifdef TIMING + time_inttocart=time_inttocart+MPI_Wtime()-time01 +#endif +cd write (iout,*) "gcart and gxcart after int_to_cart" +cd do i=0,nres-1 +cd write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), +cd & (gxcart(j,i),j=1,3) +cd enddo +#ifdef TIMING + time_cartgrad=time_cartgrad+MPI_Wtime()-time00 +#endif + return + end +C------------------------------------------------------------------------- + subroutine zerograd + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.MD' + include 'COMMON.SCCOR' +C +C Initialize Cartesian-coordinate gradient +C + do i=1,nres + do j=1,3 + gvdwx(j,i)=0.0D0 + gvdwxT(j,i)=0.0D0 + gradx_scp(j,i)=0.0D0 + gvdwc(j,i)=0.0D0 + gvdwcT(j,i)=0.0D0 + gvdwc_scp(j,i)=0.0D0 + gvdwc_scpp(j,i)=0.0d0 + gelc (j,i)=0.0D0 + gelc_long(j,i)=0.0D0 + gradb(j,i)=0.0d0 + gradbx(j,i)=0.0d0 + gvdwpp(j,i)=0.0d0 + gel_loc(j,i)=0.0d0 + gel_loc_long(j,i)=0.0d0 + ghpbc(j,i)=0.0D0 + ghpbx(j,i)=0.0D0 + gcorr3_turn(j,i)=0.0d0 + gcorr4_turn(j,i)=0.0d0 + gradcorr(j,i)=0.0d0 + gradcorr_long(j,i)=0.0d0 + gradcorr5_long(j,i)=0.0d0 + gradcorr6_long(j,i)=0.0d0 + gcorr6_turn_long(j,i)=0.0d0 + gradcorr5(j,i)=0.0d0 + gradcorr6(j,i)=0.0d0 + gcorr6_turn(j,i)=0.0d0 + gsccorc(j,i)=0.0d0 + gsccorx(j,i)=0.0d0 + gradc(j,i,icg)=0.0d0 + gradx(j,i,icg)=0.0d0 + gscloc(j,i)=0.0d0 + gsclocx(j,i)=0.0d0 + do intertyp=1,3 + gloc_sc(intertyp,i,icg)=0.0d0 + enddo + enddo + enddo +C +C Initialize the gradient of local energy terms. +C + do i=1,4*nres + gloc(i,icg)=0.0D0 + enddo + do i=1,nres + gel_loc_loc(i)=0.0d0 + gcorr_loc(i)=0.0d0 + g_corr5_loc(i)=0.0d0 + g_corr6_loc(i)=0.0d0 + gel_loc_turn3(i)=0.0d0 + gel_loc_turn4(i)=0.0d0 + gel_loc_turn6(i)=0.0d0 + gsccor_loc(i)=0.0d0 + enddo +c initialize gcart and gxcart + do i=0,nres + do j=1,3 + gcart(j,i)=0.0d0 + gxcart(j,i)=0.0d0 + enddo + enddo + return + end +c------------------------------------------------------------------------- + double precision function fdum() + fdum=0.0D0 + return + end diff --git a/source/unres/src_MD-DFA-restraints/initialize_p.F b/source/unres/src_MD-DFA-restraints/initialize_p.F new file mode 100644 index 0000000..d02ebd1 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/initialize_p.F @@ -0,0 +1,1439 @@ + block data + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.MCM' + include 'COMMON.MD' + data MovTypID + & /'pool','chain regrow','multi-bond','phi','theta','side chain', + & 'total'/ +c Conversion from poises to molecular unit and the gas constant + data cPoise /2.9361d0/, Rb /0.001986d0/ + end +c-------------------------------------------------------------------------- + subroutine initialize +C +C Define constants and zero out tables. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif +#ifndef ISNAN + external proc_proc +#ifdef WINPGI +cMS$ATTRIBUTES C :: proc_proc +#endif +#endif + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + include 'COMMON.MCM' + include 'COMMON.MINIM' + include 'COMMON.DERIV' + include 'COMMON.SPLITELE' +c Common blocks from the diagonalization routines + COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(400) + COMMON /MACHSW/ KDIAG,ICORFL,IXDR + logical mask_r +c real*8 text1 /'initial_i'/ + + mask_r=.false. +#ifndef ISNAN +c NaNQ initialization + i=-1 + arg=100.0d0 + rr=dacos(arg) +#ifdef WINPGI + idumm=proc_proc(rr,i) +#else + call proc_proc(rr,i) +#endif +#endif + + kdiag=0 + icorfl=0 + iw=2 +C +C The following is just to define auxiliary variables used in angle conversion +C + pi=4.0D0*datan(1.0D0) + dwapi=2.0D0*pi + dwapi3=dwapi/3.0D0 + pipol=0.5D0*pi + deg2rad=pi/180.0D0 + rad2deg=1.0D0/deg2rad + angmin=10.0D0*deg2rad +C +C Define I/O units. +C + inp= 1 + iout= 2 + ipdbin= 3 + ipdb= 7 + icart = 30 + imol2= 4 + igeom= 8 + intin= 9 + ithep= 11 + ithep_pdb=51 + irotam=12 + irotam_pdb=52 + itorp= 13 + itordp= 23 + ielep= 14 + isidep=15 + iscpp=25 + icbase=16 + ifourier=20 + istat= 17 + irest1=55 + irest2=56 + iifrag=57 + ientin=18 + ientout=19 + ibond = 28 + isccor = 29 +crc for write_rmsbank1 + izs1=21 +cdr include secondary structure prediction bias + isecpred=27 +C +C CSA I/O units (separated from others especially for Jooyoung) +C + icsa_rbank=30 + icsa_seed=31 + icsa_history=32 + icsa_bank=33 + icsa_bank1=34 + icsa_alpha=35 + icsa_alpha1=36 + icsa_bankt=37 + icsa_int=39 + icsa_bank_reminimized=38 + icsa_native_int=41 + icsa_in=40 +crc for ifc error 118 + icsa_pdb=42 +C +C Set default weights of the energy terms. +C + wlong=1.0D0 + welec=1.0D0 + wtor =1.0D0 + wang =1.0D0 + wscloc=1.0D0 + wstrain=1.0D0 +C +C Zero out tables. +C + print '(a,$)','Inside initialize' +c call memmon_print_usage() + do i=1,maxres2 + do j=1,3 + c(j,i)=0.0D0 + dc(j,i)=0.0D0 + enddo + enddo + do i=1,maxres + do j=1,3 + xloc(j,i)=0.0D0 + enddo + enddo + do i=1,ntyp + do j=1,ntyp + aa(i,j)=0.0D0 + bb(i,j)=0.0D0 + augm(i,j)=0.0D0 + sigma(i,j)=0.0D0 + r0(i,j)=0.0D0 + chi(i,j)=0.0D0 + enddo + do j=1,2 + bad(i,j)=0.0D0 + enddo + chip(i)=0.0D0 + alp(i)=0.0D0 + sigma0(i)=0.0D0 + sigii(i)=0.0D0 + rr0(i)=0.0D0 + a0thet(i)=0.0D0 + do j=1,2 + athet(j,i)=0.0D0 + bthet(j,i)=0.0D0 + enddo + do j=0,3 + polthet(j,i)=0.0D0 + enddo + do j=1,3 + gthet(j,i)=0.0D0 + enddo + theta0(i)=0.0D0 + sig0(i)=0.0D0 + sigc0(i)=0.0D0 + do j=1,maxlob + bsc(j,i)=0.0D0 + do k=1,3 + censc(k,j,i)=0.0D0 + enddo + do k=1,3 + do l=1,3 + gaussc(l,k,j,i)=0.0D0 + enddo + enddo + nlob(i)=0 + enddo + enddo + nlob(ntyp1)=0 + dsc(ntyp1)=0.0D0 + do i=1,maxtor + itortyp(i)=0 + do j=1,maxtor + do k=1,maxterm + v1(k,j,i)=0.0D0 + v2(k,j,i)=0.0D0 + enddo + enddo + enddo + do i=1,maxres + itype(i)=0 + itel(i)=0 + enddo +C Initialize the bridge arrays + ns=0 + nss=0 + nhpb=0 + do i=1,maxss + iss(i)=0 + enddo + do i=1,maxdim + dhpb(i)=0.0D0 + enddo + do i=1,maxres + ihpb(i)=0 + jhpb(i)=0 + enddo +C +C Initialize timing. +C + call set_timers +C +C Initialize variables used in minimization. +C +c maxfun=5000 +c maxit=2000 + maxfun=500 + maxit=200 + tolf=1.0D-2 + rtolf=5.0D-4 +C +C Initialize the variables responsible for the mode of gradient storage. +C + nfl=0 + icg=1 +C +C Initialize constants used to split the energy into long- and short-range +C components +C + r_cut=2.0d0 + rlamb=0.3d0 +#ifndef SPLITELE + nprint_ene=nprint_ene-1 +#endif + return + end +c------------------------------------------------------------------------- + block data nazwy + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + data restyp / + &'CYS','MET','PHE','ILE','LEU','VAL','TRP','TYR','ALA','GLY','THR', + &'SER','GLN','ASN','GLU','ASP','HIS','ARG','LYS','PRO','D'/ + data onelet / + &'C','M','F','I','L','V','W','Y','A','G','T', + &'S','Q','N','E','D','H','R','K','P','X'/ + data potname /'LJ','LJK','BP','GB','GBV'/ + data ename / + & "EVDW SC-SC","EVDW2 SC-p","EES p-p","ECORR4 ","ECORR5 ", + & "ECORR6 ","EELLO ","ETURN3 ","ETURN4 ","ETURN6 ", + & "EBE bend","ESC SCloc","ETORS ","ETORSD ","EHPB ","EVDWPP ", + & "ESTR ","EVDW2_14 ","UCONST ", " ","ESCCOR"," "," ", + & "Ehomology","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", + & " "," ","EHOMO","WDFAD","WDFAT","WDFAN","WDFAB"/ + data nprint_ene /25/ + 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,28,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' + include 'COMMON.MD' + common /przechowalnia/ iturn3_start_all(0:max_fg_procs), + & iturn3_end_all(0:max_fg_procs),iturn4_start_all(0:max_fg_procs), + & iturn4_end_all(0:max_fg_procs),iatel_s_all(0:max_fg_procs), + &iatel_e_all(0:max_fg_procs),ielstart_all(maxres,0:max_fg_procs-1), + & ielend_all(maxres,0:max_fg_procs-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. + if (dyn_ss) goto 10 + do ii=1,nss + if (ihpb(ii).eq.i+nres) then + scheck=.true. + jj=jhpb(ii)-nres + goto 10 + endif + enddo + 10 continue +cd write (iout,*) 'i=',i,' scheck=',scheck,' jj=',jj + if (scheck) then + if (jj.eq.i+1) then +#ifdef MPI +c write (iout,*) 'jj=i+1' + call int_partition(ind_scint,my_sc_inds,my_sc_inde,i, + & iatsc_s,iatsc_e,i+2,nct,nint_gr(i),istart(i,1),iend(i,1),*12) +#else + nint_gr(i)=1 + istart(i,1)=i+2 + iend(i,1)=nct +#endif + else if (jj.eq.nct) then +#ifdef MPI +c write (iout,*) 'jj=nct' + call int_partition(ind_scint,my_sc_inds,my_sc_inde,i, + & iatsc_s,iatsc_e,i+1,nct-1,nint_gr(i),istart(i,1),iend(i,1),*12) +#else + nint_gr(i)=1 + istart(i,1)=i+1 + iend(i,1)=nct-1 +#endif + else +#ifdef MPI + call int_partition(ind_scint,my_sc_inds,my_sc_inde,i, + & iatsc_s,iatsc_e,i+1,jj-1,nint_gr(i),istart(i,1),iend(i,1),*12) + ii=nint_gr(i)+1 + call int_partition(ind_scint,my_sc_inds,my_sc_inde,i, + & iatsc_s,iatsc_e,jj+1,nct,nint_gr(i),istart(i,ii),iend(i,ii),*12) +#else + nint_gr(i)=2 + istart(i,1)=i+1 + iend(i,1)=jj-1 + istart(i,2)=jj+1 + iend(i,2)=nct +#endif + endif + else +#ifdef MPI + call int_partition(ind_scint,my_sc_inds,my_sc_inde,i, + & iatsc_s,iatsc_e,i+1,nct,nint_gr(i),istart(i,1),iend(i,1),*12) +#else + nint_gr(i)=1 + istart(i,1)=i+1 + iend(i,1)=nct + ind_scint=ind_scint+nct-i +#endif + endif +#ifdef MPI + ind_scint_old=ind_scint +#endif + enddo + 12 continue +#ifndef MPI + iatsc_s=nnt + iatsc_e=nct-1 +#endif +#ifdef MPI + if (lprint) write (*,*) 'Processor',fg_rank,' CG Group',kolor, + & ' absolute rank',myrank,' iatsc_s=',iatsc_s,' iatsc_e=',iatsc_e +#endif + if (lprint) then + write (iout,'(a)') 'Interaction array:' + do i=iatsc_s,iatsc_e + write (iout,'(i3,2(2x,2i3))') + & i,(istart(i,iint),iend(i,iint),iint=1,nint_gr(i)) + enddo + endif + ispp=4 +#ifdef MPI +C Now partition the electrostatic-interaction array + npept=nct-nnt + nele_int_tot=(npept-ispp)*(npept-ispp+1)/2 + call int_bounds(nele_int_tot,my_ele_inds,my_ele_inde) + if (lprint) + & write (*,*) 'Processor',fg_rank,' CG group',kolor, + & ' absolute rank',MyRank, + & ' nele_int_tot',nele_int_tot,' my_ele_inds=',my_ele_inds, + & ' my_ele_inde',my_ele_inde + iatel_s=0 + iatel_e=0 + ind_eleint=0 + ind_eleint_old=0 + do i=nnt,nct-3 + ijunk=0 + call int_partition(ind_eleint,my_ele_inds,my_ele_inde,i, + & iatel_s,iatel_e,i+ispp,nct-1,ijunk,ielstart(i),ielend(i),*13) + enddo ! i + 13 continue + if (iatel_s.eq.0) iatel_s=1 + nele_int_tot_vdw=(npept-2)*(npept-2+1)/2 +c write (iout,*) "nele_int_tot_vdw",nele_int_tot_vdw + call int_bounds(nele_int_tot_vdw,my_ele_inds_vdw,my_ele_inde_vdw) +c write (iout,*) "my_ele_inds_vdw",my_ele_inds_vdw, +c & " my_ele_inde_vdw",my_ele_inde_vdw + ind_eleint_vdw=0 + ind_eleint_vdw_old=0 + iatel_s_vdw=0 + iatel_e_vdw=0 + do i=nnt,nct-3 + ijunk=0 + call int_partition(ind_eleint_vdw,my_ele_inds_vdw, + & my_ele_inde_vdw,i, + & iatel_s_vdw,iatel_e_vdw,i+2,nct-1,ijunk,ielstart_vdw(i), + & ielend_vdw(i),*15) +c write (iout,*) i," ielstart_vdw",ielstart_vdw(i), +c & " ielend_vdw",ielend_vdw(i) + enddo ! i + if (iatel_s_vdw.eq.0) iatel_s_vdw=1 + 15 continue +#else + iatel_s=nnt + iatel_e=nct-5 + do i=iatel_s,iatel_e + ielstart(i)=i+4 + ielend(i)=nct-1 + enddo + iatel_s_vdw=nnt + iatel_e_vdw=nct-3 + do i=iatel_s_vdw,iatel_e_vdw + ielstart_vdw(i)=i+2 + ielend_vdw(i)=nct-1 + enddo +#endif + if (lprint) then + write (*,'(a)') 'Processor',fg_rank,' CG group',kolor, + & ' absolute rank',MyRank + write (iout,*) 'Electrostatic interaction array:' + do i=iatel_s,iatel_e + write (iout,'(i3,2(2x,2i3))') i,ielstart(i),ielend(i) + enddo + endif ! lprint +c iscp=3 + iscp=2 +C Partition the SC-p interaction array +#ifdef MPI + nscp_int_tot=(npept-iscp+1)*(npept-iscp+1) + call int_bounds(nscp_int_tot,my_scp_inds,my_scp_inde) + if (lprint) write (iout,*) 'Processor',fg_rank,' CG group',kolor, + & ' absolute rank',myrank, + & ' nscp_int_tot',nscp_int_tot,' my_scp_inds=',my_scp_inds, + & ' my_scp_inde',my_scp_inde + iatscp_s=0 + iatscp_e=0 + ind_scpint=0 + ind_scpint_old=0 + do i=nnt,nct-1 + if (i.lt.nnt+iscp) then +cd write (iout,*) 'i.le.nnt+iscp' + call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i, + & iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,1), + & iscpend(i,1),*14) + else if (i.gt.nct-iscp) then +cd write (iout,*) 'i.gt.nct-iscp' + call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i, + & iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1), + & iscpend(i,1),*14) + else + call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i, + & iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1), + & iscpend(i,1),*14) + ii=nscp_gr(i)+1 + call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i, + & iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,ii), + & iscpend(i,ii),*14) + endif + enddo ! i + 14 continue +#else + iatscp_s=nnt + iatscp_e=nct-1 + do i=nnt,nct-1 + if (i.lt.nnt+iscp) then + nscp_gr(i)=1 + iscpstart(i,1)=i+iscp + iscpend(i,1)=nct + elseif (i.gt.nct-iscp) then + nscp_gr(i)=1 + iscpstart(i,1)=nnt + iscpend(i,1)=i-iscp + else + nscp_gr(i)=2 + iscpstart(i,1)=nnt + iscpend(i,1)=i-iscp + iscpstart(i,2)=i+iscp + iscpend(i,2)=nct + endif + enddo ! i +#endif + if (lprint) then + write (iout,'(a)') 'SC-p interaction array:' + do i=iatscp_s,iatscp_e + write (iout,'(i3,2(2x,2i3))') + & i,(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i)) + enddo + endif ! lprint +C Partition local interactions +#ifdef MPI + call int_bounds(nres-2,loc_start,loc_end) + loc_start=loc_start+1 + loc_end=loc_end+1 + call int_bounds(nres-2,ithet_start,ithet_end) + ithet_start=ithet_start+2 + ithet_end=ithet_end+2 + call int_bounds(nct-nnt-2,iturn3_start,iturn3_end) + iturn3_start=iturn3_start+nnt + iphi_start=iturn3_start+2 + iturn3_end=iturn3_end+nnt + iphi_end=iturn3_end+2 + iturn3_start=iturn3_start-1 + iturn3_end=iturn3_end-1 + call int_bounds(nres-3,itau_start,itau_end) + itau_start=itau_start+3 + itau_end=itau_end+3 + call int_bounds(nres-3,iphi1_start,iphi1_end) + iphi1_start=iphi1_start+3 + iphi1_end=iphi1_end+3 + call int_bounds(nct-nnt-3,iturn4_start,iturn4_end) + iturn4_start=iturn4_start+nnt + iphid_start=iturn4_start+2 + iturn4_end=iturn4_end+nnt + iphid_end=iturn4_end+2 + iturn4_start=iturn4_start-1 + iturn4_end=iturn4_end-1 + call int_bounds(nres-2,ibond_start,ibond_end) + ibond_start=ibond_start+1 + ibond_end=ibond_end+1 + call int_bounds(nct-nnt,ibondp_start,ibondp_end) + ibondp_start=ibondp_start+nnt + ibondp_end=ibondp_end+nnt + call int_bounds1(nres-1,ivec_start,ivec_end) + print *,"Processor",myrank,fg_rank,fg_rank1, + & " ivec_start",ivec_start," ivec_end",ivec_end + iset_start=loc_start+2 + iset_end=loc_end+2 + if (ndih_constr.eq.0) then + idihconstr_start=1 + idihconstr_end=0 + else + call int_bounds(ndih_constr,idihconstr_start,idihconstr_end) + endif + nsumgrad=(nres-nnt)*(nres-nnt+1)/2 + nlen=nres-nnt+1 + call int_bounds(nsumgrad,ngrad_start,ngrad_end) + igrad_start=((2*nlen+1) + & -sqrt(float((2*nlen-1)**2-8*(ngrad_start-1))))/2 + jgrad_start(igrad_start)= + & ngrad_start-(2*nlen-igrad_start)*(igrad_start-1)/2 + & +igrad_start + jgrad_end(igrad_start)=nres + igrad_end=((2*nlen+1) + & -sqrt(float((2*nlen-1)**2-8*(ngrad_end-1))))/2 + if (igrad_end.gt.igrad_start) jgrad_start(igrad_end)=igrad_end+1 + jgrad_end(igrad_end)=ngrad_end-(2*nlen-igrad_end)*(igrad_end-1)/2 + & +igrad_end + do i=igrad_start+1,igrad_end-1 + jgrad_start(i)=i+1 + jgrad_end(i)=nres + enddo + if (lprint) then + write (*,*) 'Processor:',fg_rank,' CG group',kolor, + & ' absolute rank',myrank, + & ' loc_start',loc_start,' loc_end',loc_end, + & ' ithet_start',ithet_start,' ithet_end',ithet_end, + & ' iphi_start',iphi_start,' iphi_end',iphi_end, + & ' iphid_start',iphid_start,' iphid_end',iphid_end, + & ' ibond_start',ibond_start,' ibond_end',ibond_end, + & ' ibondp_start',ibondp_start,' ibondp_end',ibondp_end, + & ' iturn3_start',iturn3_start,' iturn3_end',iturn3_end, + & ' iturn4_start',iturn4_start,' iturn4_end',iturn4_end, + & ' ivec_start',ivec_start,' ivec_end',ivec_end, + & ' iset_start',iset_start,' iset_end',iset_end, + & ' idihconstr_start',idihconstr_start,' idihconstr_end', + & idihconstr_end + write (*,*) 'Processor:',fg_rank,myrank,' igrad_start', + & igrad_start,' igrad_end',igrad_end,' ngrad_start',ngrad_start, + & ' ngrad_end',ngrad_end + do i=igrad_start,igrad_end + write(*,*) 'Processor:',fg_rank,myrank,i, + & jgrad_start(i),jgrad_end(i) + enddo + endif + if (nfgtasks.gt.1) then + call MPI_Allgather(ivec_start,1,MPI_INTEGER,ivec_displ(0),1, + & MPI_INTEGER,FG_COMM1,IERROR) + iaux=ivec_end-ivec_start+1 + call MPI_Allgather(iaux,1,MPI_INTEGER,ivec_count(0),1, + & MPI_INTEGER,FG_COMM1,IERROR) + call MPI_Allgather(iset_start-2,1,MPI_INTEGER,iset_displ(0),1, + & MPI_INTEGER,FG_COMM,IERROR) + iaux=iset_end-iset_start+1 + call MPI_Allgather(iaux,1,MPI_INTEGER,iset_count(0),1, + & MPI_INTEGER,FG_COMM,IERROR) + call MPI_Allgather(ibond_start,1,MPI_INTEGER,ibond_displ(0),1, + & MPI_INTEGER,FG_COMM,IERROR) + iaux=ibond_end-ibond_start+1 + call MPI_Allgather(iaux,1,MPI_INTEGER,ibond_count(0),1, + & MPI_INTEGER,FG_COMM,IERROR) + call MPI_Allgather(ithet_start,1,MPI_INTEGER,ithet_displ(0),1, + & MPI_INTEGER,FG_COMM,IERROR) + iaux=ithet_end-ithet_start+1 + call MPI_Allgather(iaux,1,MPI_INTEGER,ithet_count(0),1, + & MPI_INTEGER,FG_COMM,IERROR) + call MPI_Allgather(iphi_start,1,MPI_INTEGER,iphi_displ(0),1, + & MPI_INTEGER,FG_COMM,IERROR) + iaux=iphi_end-iphi_start+1 + call MPI_Allgather(iaux,1,MPI_INTEGER,iphi_count(0),1, + & MPI_INTEGER,FG_COMM,IERROR) + call MPI_Allgather(iphi1_start,1,MPI_INTEGER,iphi1_displ(0),1, + & MPI_INTEGER,FG_COMM,IERROR) + iaux=iphi1_end-iphi1_start+1 + call MPI_Allgather(iaux,1,MPI_INTEGER,iphi1_count(0),1, + & MPI_INTEGER,FG_COMM,IERROR) + do i=0,maxprocs-1 + do j=1,maxres + ielstart_all(j,i)=0 + ielend_all(j,i)=0 + enddo + enddo + call MPI_Allgather(iturn3_start,1,MPI_INTEGER, + & iturn3_start_all(0),1,MPI_INTEGER,FG_COMM,IERROR) + call MPI_Allgather(iturn4_start,1,MPI_INTEGER, + & iturn4_start_all(0),1,MPI_INTEGER,FG_COMM,IERROR) + call MPI_Allgather(iturn3_end,1,MPI_INTEGER, + & iturn3_end_all(0),1,MPI_INTEGER,FG_COMM,IERROR) + call MPI_Allgather(iturn4_end,1,MPI_INTEGER, + & iturn4_end_all(0),1,MPI_INTEGER,FG_COMM,IERROR) + call MPI_Allgather(iatel_s,1,MPI_INTEGER, + & iatel_s_all(0),1,MPI_INTEGER,FG_COMM,IERROR) + call MPI_Allgather(iatel_e,1,MPI_INTEGER, + & iatel_e_all(0),1,MPI_INTEGER,FG_COMM,IERROR) + call MPI_Allgather(ielstart(1),maxres,MPI_INTEGER, + & ielstart_all(1,0),maxres,MPI_INTEGER,FG_COMM,IERROR) + call MPI_Allgather(ielend(1),maxres,MPI_INTEGER, + & ielend_all(1,0),maxres,MPI_INTEGER,FG_COMM,IERROR) + if (lprint) then + write (iout,*) "iatel_s_all",(iatel_s_all(i),i=0,nfgtasks) + write (iout,*) "iatel_e_all",(iatel_e_all(i),i=0,nfgtasks) + write (iout,*) "iturn3_start_all", + & (iturn3_start_all(i),i=0,nfgtasks-1) + write (iout,*) "iturn3_end_all", + & (iturn3_end_all(i),i=0,nfgtasks-1) + write (iout,*) "iturn4_start_all", + & (iturn4_start_all(i),i=0,nfgtasks-1) + write (iout,*) "iturn4_end_all", + & (iturn4_end_all(i),i=0,nfgtasks-1) + write (iout,*) "The ielstart_all array" + do i=nnt,nct + write (iout,'(20i4)') i,(ielstart_all(i,j),j=0,nfgtasks-1) + enddo + write (iout,*) "The ielend_all array" + do i=nnt,nct + write (iout,'(20i4)') i,(ielend_all(i,j),j=0,nfgtasks-1) + enddo + call flush(iout) + endif + ntask_cont_from=0 + ntask_cont_to=0 + itask_cont_from(0)=fg_rank + itask_cont_to(0)=fg_rank + flag=.false. + do ii=iturn3_start,iturn3_end + call add_int(ii,ii+2,iturn3_sent(1,ii), + & ntask_cont_to,itask_cont_to,flag) + enddo + do ii=iturn4_start,iturn4_end + call add_int(ii,ii+3,iturn4_sent(1,ii), + & ntask_cont_to,itask_cont_to,flag) + enddo + do ii=iturn3_start,iturn3_end + call add_int_from(ii,ii+2,ntask_cont_from,itask_cont_from) + enddo + do ii=iturn4_start,iturn4_end + call add_int_from(ii,ii+3,ntask_cont_from,itask_cont_from) + enddo + if (lprint) then + write (iout,*) "After turn3 ntask_cont_from",ntask_cont_from, + & " ntask_cont_to",ntask_cont_to + write (iout,*) "itask_cont_from", + & (itask_cont_from(i),i=1,ntask_cont_from) + write (iout,*) "itask_cont_to", + & (itask_cont_to(i),i=1,ntask_cont_to) + call flush(iout) + endif +c write (iout,*) "Loop forward" +c call flush(iout) + do i=iatel_s,iatel_e +c write (iout,*) "from loop i=",i +c call flush(iout) + do j=ielstart(i),ielend(i) + call add_int_from(i,j,ntask_cont_from,itask_cont_from) + enddo + enddo +c write (iout,*) "Loop backward iatel_e-1",iatel_e-1, +c & " iatel_e",iatel_e +c call flush(iout) + nat_sent=0 + do i=iatel_s,iatel_e +c write (iout,*) "i",i," ielstart",ielstart(i), +c & " ielend",ielend(i) +c call flush(iout) + flag=.false. + do j=ielstart(i),ielend(i) + call add_int(i,j,iint_sent(1,j,nat_sent+1),ntask_cont_to, + & itask_cont_to,flag) + enddo + if (flag) then + nat_sent=nat_sent+1 + iat_sent(nat_sent)=i + endif + enddo + if (lprint) then + write (iout,*)"After longrange ntask_cont_from",ntask_cont_from, + & " ntask_cont_to",ntask_cont_to + write (iout,*) "itask_cont_from", + & (itask_cont_from(i),i=1,ntask_cont_from) + write (iout,*) "itask_cont_to", + & (itask_cont_to(i),i=1,ntask_cont_to) + call flush(iout) + write (iout,*) "iint_sent" + do i=1,nat_sent + ii=iat_sent(i) + write (iout,'(20i4)') ii,(j,(iint_sent(k,j,i),k=1,4), + & j=ielstart(ii),ielend(ii)) + enddo + write (iout,*) "iturn3_sent iturn3_start",iturn3_start, + & " iturn3_end",iturn3_end + write (iout,'(20i4)') (i,(iturn3_sent(j,i),j=1,4), + & i=iturn3_start,iturn3_end) + write (iout,*) "iturn4_sent iturn4_start",iturn4_start, + & " iturn4_end",iturn4_end + write (iout,'(20i4)') (i,(iturn4_sent(j,i),j=1,4), + & i=iturn4_start,iturn4_end) + call flush(iout) + endif + call MPI_Gather(ntask_cont_from,1,MPI_INTEGER, + & ntask_cont_from_all,1,MPI_INTEGER,king,FG_COMM,IERR) +c write (iout,*) "Gather ntask_cont_from ended" +c call flush(iout) + call MPI_Gather(itask_cont_from(0),max_fg_procs,MPI_INTEGER, + & itask_cont_from_all(0,0),max_fg_procs,MPI_INTEGER,king, + & FG_COMM,IERR) +c write (iout,*) "Gather itask_cont_from ended" +c call flush(iout) + call MPI_Gather(ntask_cont_to,1,MPI_INTEGER,ntask_cont_to_all, + & 1,MPI_INTEGER,king,FG_COMM,IERR) +c write (iout,*) "Gather ntask_cont_to ended" +c call flush(iout) + call MPI_Gather(itask_cont_to,max_fg_procs,MPI_INTEGER, + & itask_cont_to_all,max_fg_procs,MPI_INTEGER,king,FG_COMM,IERR) +c write (iout,*) "Gather itask_cont_to ended" +c call flush(iout) + if (fg_rank.eq.king) then + write (iout,*)"Contact receive task map (proc, #tasks, tasks)" + do i=0,nfgtasks-1 + write (iout,'(20i4)') i,ntask_cont_from_all(i), + & (itask_cont_from_all(j,i),j=1,ntask_cont_from_all(i)) + enddo + write (iout,*) + call flush(iout) + write (iout,*) "Contact send task map (proc, #tasks, tasks)" + do i=0,nfgtasks-1 + write (iout,'(20i4)') i,ntask_cont_to_all(i), + & (itask_cont_to_all(j,i),j=1,ntask_cont_to_all(i)) + enddo + write (iout,*) + call flush(iout) +C Check if every send will have a matching receive + ncheck_to=0 + ncheck_from=0 + do i=0,nfgtasks-1 + ncheck_to=ncheck_to+ntask_cont_to_all(i) + ncheck_from=ncheck_from+ntask_cont_from_all(i) + enddo + write (iout,*) "Control sums",ncheck_from,ncheck_to + if (ncheck_from.ne.ncheck_to) then + write (iout,*) "Error: #receive differs from #send." + write (iout,*) "Terminating program...!" + call flush(iout) + flag=.false. + else + flag=.true. + do i=0,nfgtasks-1 + do j=1,ntask_cont_to_all(i) + ii=itask_cont_to_all(j,i) + do k=1,ntask_cont_from_all(ii) + if (itask_cont_from_all(k,ii).eq.i) then + if(lprint)write(iout,*)"Matching send/receive",i,ii + exit + endif + enddo + if (k.eq.ntask_cont_from_all(ii)+1) then + flag=.false. + write (iout,*) "Error: send by",j," to",ii, + & " would have no matching receive" + endif + enddo + enddo + endif + if (.not.flag) then + write (iout,*) "Unmatched sends; terminating program" + call flush(iout) + endif + endif + call MPI_Bcast(flag,1,MPI_LOGICAL,king,FG_COMM,IERROR) +c write (iout,*) "flag broadcast ended flag=",flag +c call flush(iout) + if (.not.flag) then + call MPI_Finalize(IERROR) + stop "Error in INIT_INT_TABLE: unmatched send/receive." + endif + call MPI_Comm_group(FG_COMM,fg_group,IERR) +c write (iout,*) "MPI_Comm_group ended" +c call flush(iout) + call MPI_Group_incl(fg_group,ntask_cont_from+1, + & itask_cont_from(0),CONT_FROM_GROUP,IERR) + call MPI_Group_incl(fg_group,ntask_cont_to+1,itask_cont_to(0), + & CONT_TO_GROUP,IERR) + do i=1,nat_sent + ii=iat_sent(i) + iaux=4*(ielend(ii)-ielstart(ii)+1) + call MPI_Group_translate_ranks(fg_group,iaux, + & iint_sent(1,ielstart(ii),i),CONT_TO_GROUP, + & iint_sent_local(1,ielstart(ii),i),IERR ) +c write (iout,*) "Ranks translated i=",i +c call flush(iout) + enddo + iaux=4*(iturn3_end-iturn3_start+1) + call MPI_Group_translate_ranks(fg_group,iaux, + & iturn3_sent(1,iturn3_start),CONT_TO_GROUP, + & iturn3_sent_local(1,iturn3_start),IERR) + iaux=4*(iturn4_end-iturn4_start+1) + call MPI_Group_translate_ranks(fg_group,iaux, + & iturn4_sent(1,iturn4_start),CONT_TO_GROUP, + & iturn4_sent_local(1,iturn4_start),IERR) + if (lprint) then + write (iout,*) "iint_sent_local" + do i=1,nat_sent + ii=iat_sent(i) + write (iout,'(20i4)') ii,(j,(iint_sent_local(k,j,i),k=1,4), + & j=ielstart(ii),ielend(ii)) + call flush(iout) + enddo + write (iout,*) "iturn3_sent_local iturn3_start",iturn3_start, + & " iturn3_end",iturn3_end + write (iout,'(20i4)') (i,(iturn3_sent_local(j,i),j=1,4), + & i=iturn3_start,iturn3_end) + write (iout,*) "iturn4_sent_local iturn4_start",iturn4_start, + & " iturn4_end",iturn4_end + write (iout,'(20i4)') (i,(iturn4_sent_local(j,i),j=1,4), + & i=iturn4_start,iturn4_end) + call flush(iout) + endif + call MPI_Group_free(fg_group,ierr) + call MPI_Group_free(cont_from_group,ierr) + call MPI_Group_free(cont_to_group,ierr) + call MPI_Type_contiguous(3,MPI_DOUBLE_PRECISION,MPI_UYZ,IERROR) + call MPI_Type_commit(MPI_UYZ,IERROR) + call MPI_Type_contiguous(18,MPI_DOUBLE_PRECISION,MPI_UYZGRAD, + & IERROR) + call MPI_Type_commit(MPI_UYZGRAD,IERROR) + call MPI_Type_contiguous(2,MPI_DOUBLE_PRECISION,MPI_MU,IERROR) + call MPI_Type_commit(MPI_MU,IERROR) + call MPI_Type_contiguous(4,MPI_DOUBLE_PRECISION,MPI_MAT1,IERROR) + call MPI_Type_commit(MPI_MAT1,IERROR) + call MPI_Type_contiguous(8,MPI_DOUBLE_PRECISION,MPI_MAT2,IERROR) + call MPI_Type_commit(MPI_MAT2,IERROR) + call MPI_Type_contiguous(6,MPI_DOUBLE_PRECISION,MPI_THET,IERROR) + call MPI_Type_commit(MPI_THET,IERROR) + call MPI_Type_contiguous(9,MPI_DOUBLE_PRECISION,MPI_GAM,IERROR) + call MPI_Type_commit(MPI_GAM,IERROR) +#ifndef MATGATHER +c 9/22/08 Derived types to send matrices which appear in correlation terms + do i=0,nfgtasks-1 + if (ivec_count(i).eq.ivec_count(0)) then + lentyp(i)=0 + else + lentyp(i)=1 + endif + enddo + do ind_typ=lentyp(0),lentyp(nfgtasks-1) + if (ind_typ.eq.0) then + ichunk=ivec_count(0) + else + ichunk=ivec_count(1) + endif +c do i=1,4 +c blocklengths(i)=4 +c enddo +c displs(1)=0 +c do i=2,4 +c displs(i)=displs(i-1)+blocklengths(i-1)*maxres +c enddo +c do i=1,4 +c blocklengths(i)=blocklengths(i)*ichunk +c enddo +c write (iout,*) "blocklengths and displs" +c do i=1,4 +c write (iout,*) i,blocklengths(i),displs(i) +c enddo +c call flush(iout) +c call MPI_Type_indexed(4,blocklengths(1),displs(1), +c & MPI_DOUBLE_PRECISION,MPI_ROTAT1(ind_typ),IERROR) +c call MPI_Type_commit(MPI_ROTAT1(ind_typ),IERROR) +c write (iout,*) "MPI_ROTAT1",MPI_ROTAT1 +c do i=1,4 +c blocklengths(i)=2 +c enddo +c displs(1)=0 +c do i=2,4 +c displs(i)=displs(i-1)+blocklengths(i-1)*maxres +c enddo +c do i=1,4 +c blocklengths(i)=blocklengths(i)*ichunk +c enddo +c write (iout,*) "blocklengths and displs" +c do i=1,4 +c write (iout,*) i,blocklengths(i),displs(i) +c enddo +c call flush(iout) +c call MPI_Type_indexed(4,blocklengths(1),displs(1), +c & MPI_DOUBLE_PRECISION,MPI_ROTAT2(ind_typ),IERROR) +c call MPI_Type_commit(MPI_ROTAT2(ind_typ),IERROR) +c write (iout,*) "MPI_ROTAT2",MPI_ROTAT2 + do i=1,8 + blocklengths(i)=2 + enddo + displs(1)=0 + do i=2,8 + displs(i)=displs(i-1)+blocklengths(i-1)*maxres + enddo + do i=1,15 + blocklengths(i)=blocklengths(i)*ichunk + enddo + call MPI_Type_indexed(8,blocklengths,displs, + & MPI_DOUBLE_PRECISION,MPI_PRECOMP11(ind_typ),IERROR) + call MPI_Type_commit(MPI_PRECOMP11(ind_typ),IERROR) + do i=1,8 + blocklengths(i)=4 + enddo + displs(1)=0 + do i=2,8 + displs(i)=displs(i-1)+blocklengths(i-1)*maxres + enddo + do i=1,15 + blocklengths(i)=blocklengths(i)*ichunk + enddo + call MPI_Type_indexed(8,blocklengths,displs, + & MPI_DOUBLE_PRECISION,MPI_PRECOMP12(ind_typ),IERROR) + call MPI_Type_commit(MPI_PRECOMP12(ind_typ),IERROR) + do i=1,6 + blocklengths(i)=4 + enddo + displs(1)=0 + do i=2,6 + displs(i)=displs(i-1)+blocklengths(i-1)*maxres + enddo + do i=1,6 + blocklengths(i)=blocklengths(i)*ichunk + enddo + call MPI_Type_indexed(6,blocklengths,displs, + & MPI_DOUBLE_PRECISION,MPI_PRECOMP22(ind_typ),IERROR) + call MPI_Type_commit(MPI_PRECOMP22(ind_typ),IERROR) + do i=1,2 + blocklengths(i)=8 + enddo + displs(1)=0 + do i=2,2 + displs(i)=displs(i-1)+blocklengths(i-1)*maxres + enddo + do i=1,2 + blocklengths(i)=blocklengths(i)*ichunk + enddo + call MPI_Type_indexed(2,blocklengths,displs, + & MPI_DOUBLE_PRECISION,MPI_PRECOMP23(ind_typ),IERROR) + call MPI_Type_commit(MPI_PRECOMP23(ind_typ),IERROR) + do i=1,4 + blocklengths(i)=1 + enddo + displs(1)=0 + do i=2,4 + displs(i)=displs(i-1)+blocklengths(i-1)*maxres + enddo + do i=1,4 + blocklengths(i)=blocklengths(i)*ichunk + enddo + call MPI_Type_indexed(4,blocklengths,displs, + & MPI_DOUBLE_PRECISION,MPI_ROTAT_OLD(ind_typ),IERROR) + call MPI_Type_commit(MPI_ROTAT_OLD(ind_typ),IERROR) + enddo +#endif + endif + iint_start=ivec_start+1 + iint_end=ivec_end+1 + do i=0,nfgtasks-1 + iint_count(i)=ivec_count(i) + iint_displ(i)=ivec_displ(i) + ivec_displ(i)=ivec_displ(i)-1 + iset_displ(i)=iset_displ(i)-1 + ithet_displ(i)=ithet_displ(i)-1 + iphi_displ(i)=iphi_displ(i)-1 + iphi1_displ(i)=iphi1_displ(i)-1 + ibond_displ(i)=ibond_displ(i)-1 + enddo + if (nfgtasks.gt.1 .and. fg_rank.eq.king + & .and. (me.eq.0 .or. out1file)) then + write (iout,*) "IVEC_DISPL, IVEC_COUNT, ISET_START, ISET_COUNT" + do i=0,nfgtasks-1 + write (iout,*) i,ivec_displ(i),ivec_count(i),iset_displ(i), + & iset_count(i) + enddo + write (iout,*) "iphi_start",iphi_start," iphi_end",iphi_end, + & " iphi1_start",iphi1_start," iphi1_end",iphi1_end + write (iout,*)"IPHI_COUNT, IPHI_DISPL, IPHI1_COUNT, IPHI1_DISPL" + do i=0,nfgtasks-1 + write (iout,*) i,iphi_count(i),iphi_displ(i),iphi1_count(i), + & iphi1_displ(i) + enddo + write(iout,'(i10,a,i10,a,i10,a/a,i3,a)') n_sc_int_tot,' SC-SC ', + & nele_int_tot,' electrostatic and ',nscp_int_tot, + & ' SC-p interactions','were distributed among',nfgtasks, + & ' fine-grain processors.' + endif +#else + loc_start=2 + loc_end=nres-1 + ithet_start=3 + ithet_end=nres + iturn3_start=nnt + iturn3_end=nct-3 + iturn4_start=nnt + iturn4_end=nct-4 + iphi_start=nnt+3 + iphi_end=nct + iphi1_start=4 + iphi1_end=nres + idihconstr_start=1 + idihconstr_end=ndih_constr + iphid_start=iphi_start + iphid_end=iphi_end-1 + itau_start=4 + itau_end=nres + ibond_start=2 + ibond_end=nres-1 + ibondp_start=nnt+1 + ibondp_end=nct + ivec_start=1 + ivec_end=nres-1 + iset_start=3 + iset_end=nres+1 + iint_start=2 + iint_end=nres-1 +#endif + return + end +#ifdef MPI +c--------------------------------------------------------------------------- + subroutine add_int(ii,jj,itask,ntask_cont_to,itask_cont_to,flag) + implicit none + include "DIMENSIONS" + include "COMMON.INTERACT" + include "COMMON.SETUP" + include "COMMON.IOUNITS" + integer ii,jj,itask(4), + & ntask_cont_to,itask_cont_to(0:max_fg_procs-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:max_fg_procs), + & iturn3_end_all(0:max_fg_procs),iturn4_start_all(0:max_fg_procs), + & iturn4_end_all(0:max_fg_procs),iatel_s_all(0:max_fg_procs), + &iatel_e_all(0:max_fg_procs),ielstart_all(maxres,0:max_fg_procs-1), + & ielend_all(maxres,0:max_fg_procs-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:max_fg_procs-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:max_fg_procs), + & iturn3_end_all(0:max_fg_procs),iturn4_start_all(0:max_fg_procs), + & iturn4_end_all(0:max_fg_procs),iatel_s_all(0:max_fg_procs), + &iatel_e_all(0:max_fg_procs),ielstart_all(maxres,0:max_fg_procs-1), + & ielend_all(maxres,0:max_fg_procs-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:max_fg_procs-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' +c write(2,*)"hpb_partition: nhpb=",nhpb +#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 +c write(2,*)"hpb_partition: link_start=",nhpb," link_end=",link_end + return + end +c------------------------------------------------------------------------------ + subroutine homology_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' + include 'COMMON.MD' + include 'COMMON.INTERACT' + write(iout,*)"homology_partition: lim_odl=",lim_odl, + & " lim_dih",lim_dih +#ifdef MPI + write (iout,*) "MPI" + call int_bounds(lim_odl,link_start_homo,link_end_homo) + call int_bounds(lim_dih-nnt+1,idihconstr_start_homo, + & idihconstr_end_homo) + idihconstr_start_homo=idihconstr_start_homo+nnt-1 + idihconstr_end_homo=idihconstr_end_homo+nnt-1 + if (me.eq.king .or. .not. out1file) + & write (iout,*) 'Processor',fg_rank,' CG group',kolor, + & ' absolute rank',MyRank, + & ' lim_odl',lim_odl,' link_start=',link_start_homo, + & ' link_end',link_end_homo,' lim_dih',lim_dih, + & ' idihconstr_start_homo',idihconstr_start_homo, + & ' idihconstr_end_homo',idihconstr_end_homo +#else + write (iout,*) "Not MPI" + link_start_homo=1 + link_end_homo=lim_odl + idihconstr_start_homo=nnt + idihconstr_end_homo=lim_dih + write (iout,*) + & ' lim_odl',lim_odl,' link_start=',link_start_homo, + & ' link_end',link_end_homo,' lim_dih',lim_dih, + & ' idihconstr_start_homo',idihconstr_start_homo, + & ' idihconstr_end_homo',idihconstr_end_homo +#endif + return + end diff --git a/source/unres/src_MD-DFA-restraints/int_to_cart.f b/source/unres/src_MD-DFA-restraints/int_to_cart.f new file mode 100644 index 0000000..73e8384 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/int_to_cart.f @@ -0,0 +1,278 @@ + subroutine int_to_cart +c-------------------------------------------------------------- +c This subroutine converts the energy derivatives from internal +c coordinates to cartesian coordinates +c------------------------------------------------------------- + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.MD' + include 'COMMON.IOUNITS' + include 'COMMON.SCCOR' +c calculating dE/ddc1 + if (nres.lt.3) goto 18 +c do i=1,nres +c c do intertyp=1,3 +c write (iout,*) "przed tosyjnymi",i,intertyp,gcart(intertyp,i) +c &,gloc_sc(1,i,icg),gloc(i,icg) +c enddo +c enddo + do j=1,3 + gcart(j,1)=gcart(j,1)+gloc(1,icg)*dphi(j,1,4) + & +gloc(nres-2,icg)*dtheta(j,1,3) + if(itype(2).ne.10) then + gcart(j,1)=gcart(j,1)+gloc(ialph(2,1),icg)*dalpha(j,1,2)+ + & gloc(ialph(2,1)+nside,icg)*domega(j,1,2) + endif + enddo +c Calculating the remainder of dE/ddc2 + do j=1,3 + gcart(j,2)=gcart(j,2)+gloc(1,icg)*dphi(j,2,4)+ + & gloc(nres-2,icg)*dtheta(j,2,3)+gloc(nres-1,icg)*dtheta(j,1,4) + if(itype(2).ne.10) then + gcart(j,2)=gcart(j,2)+gloc(ialph(2,1),icg)*dalpha(j,2,2)+ + & gloc(ialph(2,1)+nside,icg)*domega(j,2,2) + endif + if(itype(3).ne.10) then + gcart(j,2)=gcart(j,2)+gloc(ialph(3,1),icg)*dalpha(j,1,3)+ + & gloc(ialph(3,1)+nside,icg)*domega(j,1,3) + endif + if(nres.gt.4) then + gcart(j,2)=gcart(j,2)+gloc(2,icg)*dphi(j,1,5) + endif + enddo +c If there are only five residues + if(nres.eq.5) then + do j=1,3 + gcart(j,3)=gcart(j,3)+gloc(1,icg)*dphi(j,3,4)+gloc(2,icg)* + & dphi(j,2,5)+gloc(nres-1,icg)*dtheta(j,2,4)+gloc(nres,icg)* + & dtheta(j,1,5) + if(itype(3).ne.10) then + gcart(j,3)=gcart(j,3)+gloc(ialph(3,1),icg)* + & dalpha(j,2,3)+gloc(ialph(3,1)+nside,icg)*domega(j,2,3) + endif + if(itype(4).ne.10) then + gcart(j,3)=gcart(j,3)+gloc(ialph(4,1),icg)* + & dalpha(j,1,4)+gloc(ialph(4,1)+nside,icg)*domega(j,1,4) + endif + enddo + endif +c If there are more than five residues + if(nres.gt.5) then + do i=3,nres-3 + do j=1,3 + gcart(j,i)=gcart(j,i)+gloc(i-2,icg)*dphi(j,3,i+1) + & +gloc(i-1,icg)*dphi(j,2,i+2)+ + & gloc(i,icg)*dphi(j,1,i+3)+gloc(nres+i-4,icg)*dtheta(j,2,i+1)+ + & gloc(nres+i-3,icg)*dtheta(j,1,i+2) + if(itype(i).ne.10) then + gcart(j,i)=gcart(j,i)+gloc(ialph(i,1),icg)*dalpha(j,2,i)+ + & gloc(ialph(i,1)+nside,icg)*domega(j,2,i) + endif + if(itype(i+1).ne.10) then + gcart(j,i)=gcart(j,i)+gloc(ialph(i+1,1),icg)*dalpha(j,1,i+1) + & +gloc(ialph(i+1,1)+nside,icg)*domega(j,1,i+1) + endif + enddo + enddo + endif +c Setting dE/ddnres-2 + if(nres.gt.5) then + do j=1,3 + gcart(j,nres-2)=gcart(j,nres-2)+gloc(nres-4,icg)* + & dphi(j,3,nres-1)+gloc(nres-3,icg)*dphi(j,2,nres) + & +gloc(2*nres-6,icg)* + & dtheta(j,2,nres-1)+gloc(2*nres-5,icg)*dtheta(j,1,nres) + if(itype(nres-2).ne.10) then + gcart(j,nres-2)=gcart(j,nres-2)+gloc(ialph(nres-2,1),icg)* + & dalpha(j,2,nres-2)+gloc(ialph(nres-2,1)+nside,icg)* + & domega(j,2,nres-2) + endif + if(itype(nres-1).ne.10) then + gcart(j,nres-2)=gcart(j,nres-2)+gloc(ialph(nres-1,1),icg)* + & dalpha(j,1,nres-1)+gloc(ialph(nres-1,1)+nside,icg)* + & domega(j,1,nres-1) + endif + enddo + endif +c Settind dE/ddnres-1 + do j=1,3 + gcart(j,nres-1)=gcart(j,nres-1)+gloc(nres-3,icg)*dphi(j,3,nres)+ + & gloc(2*nres-5,icg)*dtheta(j,2,nres) + if(itype(nres-1).ne.10) then + gcart(j,nres-1)=gcart(j,nres-1)+gloc(ialph(nres-1,1),icg)* + & dalpha(j,2,nres-1)+gloc(ialph(nres-1,1)+nside,icg)* + & domega(j,2,nres-1) + endif + enddo +c The side-chain vector derivatives + do i=2,nres-1 + if(itype(i).ne.10) then + do j=1,3 + gxcart(j,i)=gxcart(j,i)+gloc(ialph(i,1),icg)*dalpha(j,3,i) + & +gloc(ialph(i,1)+nside,icg)*domega(j,3,i) + enddo + endif + enddo +c---------------------------------------------------------------------- +C INTERTYP=1 SC...Ca...Ca...Ca +C INTERTYP=2 Ca...Ca...Ca...SC +C INTERTYP=3 SC...Ca...Ca...SC +c calculating dE/ddc1 + 18 continue +c do i=1,nres +c gloc(i,icg)=0.0D0 +c write (iout,*) "poczotkoawy",i,gloc_sc(1,i,icg) +c enddo + if (nres.lt.2) return + if ((nres.lt.3).and.(itype(1).eq.10)) return + if ((itype(1).ne.10).and.(itype(1).ne.21)) then + do j=1,3 +cc Derviative was calculated for oposite vector of side chain therefore +c there is "-" sign before gloc_sc + gxcart(j,1)=gxcart(j,1)-gloc_sc(1,0,icg)* + & dtauangle(j,1,1,3) + gcart(j,1)=gcart(j,1)+gloc_sc(1,0,icg)* + & dtauangle(j,1,2,3) + if ((itype(2).ne.10).and.(itype(2).ne.21)) then + gxcart(j,1)= gxcart(j,1) + & -gloc_sc(3,0,icg)*dtauangle(j,3,1,3) + gcart(j,1)=gcart(j,1)+gloc_sc(3,0,icg)* + & dtauangle(j,3,2,3) + endif + enddo + endif + if ((nres.ge.3).and.(itype(3).ne.10).and.(itype(3).ne.21)) + & then + do j=1,3 + gcart(j,1)=gcart(j,1)+gloc_sc(2,1,icg)*dtauangle(j,2,1,4) + enddo + endif +c As potetnial DO NOT depend on omicron anlge their derivative is +c ommited +c & +gloc_sc(intertyp,nres-2,icg)*dtheta(j,1,3) + +c Calculating the remainder of dE/ddc2 + do j=1,3 + if((itype(2).ne.10).and.(itype(2).ne.21)) then + if (itype(1).ne.10) gxcart(j,2)=gxcart(j,2)+ + & gloc_sc(3,0,icg)*dtauangle(j,3,3,3) + if ((itype(3).ne.10).and.(nres.ge.3).and.(itype(3).ne.21)) then + gxcart(j,2)=gxcart(j,2)-gloc_sc(3,1,icg)*dtauangle(j,3,1,4) +cc the - above is due to different vector direction + gcart(j,2)=gcart(j,2)+gloc_sc(3,1,icg)*dtauangle(j,3,2,4) + endif + if (nres.gt.3) then + gxcart(j,2)=gxcart(j,2)-gloc_sc(1,1,icg)*dtauangle(j,1,1,4) +cc the - above is due to different vector direction + gcart(j,2)=gcart(j,2)+gloc_sc(1,1,icg)*dtauangle(j,1,2,4) +c write(iout,*) gloc_sc(1,1,icg),dtauangle(j,1,2,4),"gcart" +c write(iout,*) gloc_sc(1,1,icg),dtauangle(j,1,1,4),"gx" + endif + endif + if ((itype(1).ne.10).and.(itype(1).ne.21)) then + gcart(j,2)=gcart(j,2)+gloc_sc(1,0,icg)*dtauangle(j,1,3,3) +c write(iout,*) gloc_sc(1,0,icg),dtauangle(j,1,3,3) + endif + if ((itype(3).ne.10).and.(nres.ge.3)) then + gcart(j,2)=gcart(j,2)+gloc_sc(2,1,icg)*dtauangle(j,2,2,4) +c write(iout,*) gloc_sc(2,1,icg),dtauangle(j,2,2,4) + endif + if ((itype(4).ne.10).and.(nres.ge.4)) then + gcart(j,2)=gcart(j,2)+gloc_sc(2,2,icg)*dtauangle(j,2,1,5) +c write(iout,*) gloc_sc(2,2,icg),dtauangle(j,2,1,5) + endif + +c write(iout,*) gcart(j,2),itype(2),itype(1),itype(3), "gcart2" + enddo +c If there are more than five residues + if(nres.ge.5) then + do i=3,nres-2 + do j=1,3 +c write(iout,*) "before", gcart(j,i) + if (itype(i).ne.10) then + gxcart(j,i)=gxcart(j,i)+gloc_sc(2,i-2,icg) + & *dtauangle(j,2,3,i+1) + & -gloc_sc(1,i-1,icg)*dtauangle(j,1,1,i+2) + gcart(j,i)=gcart(j,i)+gloc_sc(1,i-1,icg) + & *dtauangle(j,1,2,i+2) +c write(iout,*) "new",j,i, +c & gcart(j,i),gloc_sc(1,i-1,icg),dtauangle(j,1,2,i+2) + + if (itype(i-1).ne.10) then + gxcart(j,i)=gxcart(j,i)+gloc_sc(3,i-2,icg) + &*dtauangle(j,3,3,i+1) + endif + if (itype(i+1).ne.10) then + gxcart(j,i)=gxcart(j,i)-gloc_sc(3,i-1,icg) + &*dtauangle(j,3,1,i+2) + gcart(j,i)=gcart(j,i)+gloc_sc(3,i-1,icg) + &*dtauangle(j,3,2,i+2) + endif + endif + if (itype(i-1).ne.10) then + gcart(j,i)=gcart(j,i)+gloc_sc(1,i-2,icg)* + & dtauangle(j,1,3,i+1) + endif + if (itype(i+1).ne.10) then + gcart(j,i)=gcart(j,i)+gloc_sc(2,i-1,icg)* + & dtauangle(j,2,2,i+2) +c write(iout,*) "numer",i,gloc_sc(2,i-1,icg), +c & dtauangle(j,2,2,i+2) + endif + if (itype(i+2).ne.10) then + gcart(j,i)=gcart(j,i)+gloc_sc(2,i,icg)* + & dtauangle(j,2,1,i+3) + endif + enddo + enddo + endif +c Setting dE/ddnres-1 + if(nres.ge.4) then + do j=1,3 + if ((itype(nres-1).ne.10).and.(itype(nres-1).ne.21)) then + gxcart(j,nres-1)=gxcart(j,nres-1)+gloc_sc(2,nres-3,icg) + & *dtauangle(j,2,3,nres) +c write (iout,*) "gxcart(nres-1)", gloc_sc(2,nres-3,icg), +c & dtauangle(j,2,3,nres), gxcart(j,nres-1) + if (itype(nres-2).ne.10) then + gxcart(j,nres-1)=gxcart(j,nres-1)+gloc_sc(3,nres-3,icg) + & *dtauangle(j,3,3,nres) + endif + if ((itype(nres).ne.10).and.(itype(nres).ne.21)) then + gxcart(j,nres-1)=gxcart(j,nres-1)-gloc_sc(3,nres-2,icg) + & *dtauangle(j,3,1,nres+1) + gcart(j,nres-1)=gcart(j,nres-1)+gloc_sc(3,nres-2,icg) + & *dtauangle(j,3,2,nres+1) + endif + endif + if ((itype(nres-2).ne.10).and.(itype(nres-2).ne.21)) then + gcart(j,nres-1)=gcart(j,nres-1)+gloc_sc(1,nres-3,icg)* + & dtauangle(j,1,3,nres) + endif + if ((itype(nres).ne.10).and.(itype(nres).ne.21)) then + gcart(j,nres-1)=gcart(j,nres-1)+gloc_sc(2,nres-2,icg)* + & dtauangle(j,2,2,nres+1) +c write (iout,*) "gcart(nres-1)", gloc_sc(2,nres-2,icg), +c & dtauangle(j,2,2,nres+1), itype(nres-1),itype(nres) + endif + enddo + endif +c Settind dE/ddnres + if ((nres.ge.3).and.(itype(nres).ne.10))then + do j=1,3 + gxcart(j,nres)=gxcart(j,nres)+gloc_sc(3,nres-2,icg) + & *dtauangle(j,3,3,nres+1)+gloc_sc(2,nres-2,icg) + & *dtauangle(j,2,3,nres+1) + enddo + endif +c The side-chain vector derivatives + return + end + + diff --git a/source/unres/src_MD-DFA-restraints/intcartderiv.F b/source/unres/src_MD-DFA-restraints/intcartderiv.F new file mode 100644 index 0000000..c220540 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/intcartderiv.F @@ -0,0 +1,725 @@ + subroutine intcartderiv + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.SETUP' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.IOUNITS' + include 'COMMON.LOCAL' + include 'COMMON.SCCOR' + double precision dcostheta(3,2,maxres), + & dcosphi(3,3,maxres),dsinphi(3,3,maxres), + & dcosalpha(3,3,maxres),dcosomega(3,3,maxres), + & dsinomega(3,3,maxres),vo1(3),vo2(3),vo3(3), + & dummy(3),vp1(3),vp2(3),vp3(3),vpp1(3),n(3) + +#if defined(MPI) && defined(PARINTDER) + if (nfgtasks.gt.1 .and. me.eq.king) + & call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR) +#endif + pi4 = 0.5d0*pipol + pi34 = 3*pi4 + +c write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end +c Derivatives of theta's +#if defined(MPI) && defined(PARINTDER) +c We need dtheta(:,:,i-1) to compute dphi(:,:,i) + do i=max0(ithet_start-1,3),ithet_end +#else + do i=3,nres +#endif + cost=dcos(theta(i)) + sint=sqrt(1-cost*cost) + do j=1,3 + dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/ + & vbld(i-1) + dtheta(j,1,i)=-1/sint*dcostheta(j,1,i) + dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/ + & vbld(i) + dtheta(j,2,i)=-1/sint*dcostheta(j,2,i) + enddo + enddo + +#if defined(MPI) && defined(PARINTDER) +c We need dtheta(:,:,i-1) to compute dphi(:,:,i) + do i=max0(ithet_start-1,3),ithet_end +#else + do i=3,nres +#endif + if ((itype(i-1).ne.10).and.(itype(i-1).ne.21)) then + cost1=dcos(omicron(1,i)) + sint1=sqrt(1-cost1*cost1) + cost2=dcos(omicron(2,i)) + sint2=sqrt(1-cost2*cost2) + do j=1,3 +CC Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1) + dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ + & cost1*dc_norm(j,i-2))/ + & vbld(i-1) + domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i) + dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) + & +cost1*(dc_norm(j,i-1+nres)))/ + & vbld(i-1+nres) + domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i) +CC Calculate derivative over second omicron Sci-1,Cai-1 Cai +CC Looks messy but better than if in loop + dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) + & +cost2*dc_norm(j,i-1))/ + & vbld(i) + domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i) + dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) + & +cost2*(-dc_norm(j,i-1+nres)))/ + & vbld(i-1+nres) +c write(iout,*) "vbld", i,itype(i),vbld(i-1+nres) + domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i) + enddo + endif + enddo + + + +c Derivatives of phi: +c If phi is 0 or 180 degrees, then the formulas +c have to be derived by power series expansion of the +c conventional formulas around 0 and 180. +#ifdef PARINTDER + do i=iphi1_start,iphi1_end +#else + do i=4,nres +#endif +c the conventional case + sint=dsin(theta(i)) + sint1=dsin(theta(i-1)) + sing=dsin(phi(i)) + cost=dcos(theta(i)) + cost1=dcos(theta(i-1)) + cosg=dcos(phi(i)) + scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1)) + fac0=1.0d0/(sint1*sint) + fac1=cost*fac0 + fac2=cost1*fac0 + fac3=cosg*cost1/(sint1*sint1) + fac4=cosg*cost/(sint*sint) +c Obtaining the gamma derivatives from sine derivative + if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. + & phi(i).gt.pi34.and.phi(i).le.pi.or. + & phi(i).gt.-pi.and.phi(i).le.-pi34) then + call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1) + call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2) + call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3) + do j=1,3 + ctgt=cost/sint + ctgt1=cost1/sint1 + cosg_inv=1.0d0/cosg + dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) + & -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2) + dphi(j,1,i)=cosg_inv*dsinphi(j,1,i) + dsinphi(j,2,i)= + & -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) + & -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1) + dphi(j,2,i)=cosg_inv*dsinphi(j,2,i) +c Bug fixed 3/24/05 (AL) + dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) + & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i) +c & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1) + dphi(j,3,i)=cosg_inv*dsinphi(j,3,i) + enddo +c Obtaining the gamma derivatives from cosine derivative + else + do j=1,3 + dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* + & dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* + & dc_norm(j,i-3))/vbld(i-2) + dphi(j,1,i)=-1/sing*dcosphi(j,1,i) + dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* + & dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* + & dcostheta(j,1,i) + dphi(j,2,i)=-1/sing*dcosphi(j,2,i) + dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* + & dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* + & dc_norm(j,i-1))/vbld(i) + dphi(j,3,i)=-1/sing*dcosphi(j,3,i) + enddo + endif + enddo + +Calculate derivative of Tauangle +#ifdef PARINTDER + do i=itau_start,itau_end +#else + do i=3,nres +#endif + if ((itype(i-2).eq.21).or.(itype(i-2).eq.10)) cycle +cc dtauangle(j,intertyp,dervityp,residue number) +cc INTERTYP=1 SC...Ca...Ca..Ca +c the conventional case + sint=dsin(theta(i)) + sint1=dsin(omicron(2,i-1)) + sing=dsin(tauangle(1,i)) + cost=dcos(theta(i)) + cost1=dcos(omicron(2,i-1)) + cosg=dcos(tauangle(1,i)) + do j=1,3 + dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres) +cc write(iout,*) dc_norm2(j,i-2+nres),"dcnorm" + enddo + scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1)) + fac0=1.0d0/(sint1*sint) + fac1=cost*fac0 + fac2=cost1*fac0 + fac3=cosg*cost1/(sint1*sint1) + fac4=cosg*cost/(sint*sint) +cc write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4 +c Obtaining the gamma derivatives from sine derivative + if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. + & tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. + & tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then + call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1) + call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2) + call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3) + do j=1,3 + ctgt=cost/sint + ctgt1=cost1/sint1 + cosg_inv=1.0d0/cosg + dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) + &-(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) + & *vbld_inv(i-2+nres) + dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i) + dsintau(j,1,2,i)= + & -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) + & -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1) +c write(iout,*) "dsintau", dsintau(j,1,2,i) + dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i) +c Bug fixed 3/24/05 (AL) + dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) + & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i) +c & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1) + dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i) + enddo +c Obtaining the gamma derivatives from cosine derivative + else + do j=1,3 + dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* + & dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* + & (dc_norm2(j,i-2+nres)))/vbld(i-2+nres) + dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i) + dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* + & dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* + & dcostheta(j,1,i) + dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i) + dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* + & dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* + & dc_norm(j,i-1))/vbld(i) + dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i) +c write (iout,*) "else",i + enddo + endif +c do k=1,3 +c write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3) +c enddo + enddo +CC Second case Ca...Ca...Ca...SC +#ifdef PARINTDER + do i=itau_start,itau_end +#else + do i=4,nres +#endif + if ((itype(i-1).eq.21).or.(itype(i-1).eq.10)) cycle +c the conventional case + sint=dsin(omicron(1,i)) + sint1=dsin(theta(i-1)) + sing=dsin(tauangle(2,i)) + cost=dcos(omicron(1,i)) + cost1=dcos(theta(i-1)) + cosg=dcos(tauangle(2,i)) +c do j=1,3 +c dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres) +c enddo + scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres)) + fac0=1.0d0/(sint1*sint) + fac1=cost*fac0 + fac2=cost1*fac0 + fac3=cosg*cost1/(sint1*sint1) + fac4=cosg*cost/(sint*sint) +c Obtaining the gamma derivatives from sine derivative + if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. + & tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. + & tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then + call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1) + call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2) + call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3) + do j=1,3 + ctgt=cost/sint + ctgt1=cost1/sint1 + cosg_inv=1.0d0/cosg + dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) + & +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2) +c write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1), +c &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)" + dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i) + dsintau(j,2,2,i)= + & -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) + & -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1) +c write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1), +c & sing*ctgt*domicron(j,1,2,i), +c & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1) + dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i) +c Bug fixed 3/24/05 (AL) + dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) + & +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres) +c & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1) + dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i) + enddo +c Obtaining the gamma derivatives from cosine derivative + else + do j=1,3 + dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* + & dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* + & dc_norm(j,i-3))/vbld(i-2) + dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i) + dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* + & dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* + & dcosomicron(j,1,1,i) + dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i) + dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* + & dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* + & dc_norm(j,i-1+nres))/vbld(i-1+nres) + dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i) +c write(iout,*) i,j,"else", dtauangle(j,2,3,i) + enddo + endif + enddo + + +CCC third case SC...Ca...Ca...SC +#ifdef PARINTDER + + do i=itau_start,itau_end +#else + do i=3,nres +#endif +c the conventional case + if ((itype(i-1).eq.21).or.(itype(i-1).eq.10).or. + &(itype(i-2).eq.21).or.(itype(i-2).eq.10)) cycle + sint=dsin(omicron(1,i)) + sint1=dsin(omicron(2,i-1)) + sing=dsin(tauangle(3,i)) + cost=dcos(omicron(1,i)) + cost1=dcos(omicron(2,i-1)) + cosg=dcos(tauangle(3,i)) + do j=1,3 + dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres) +c dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres) + enddo + scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres)) + fac0=1.0d0/(sint1*sint) + fac1=cost*fac0 + fac2=cost1*fac0 + fac3=cosg*cost1/(sint1*sint1) + fac4=cosg*cost/(sint*sint) +c Obtaining the gamma derivatives from sine derivative + if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. + & tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. + & tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then + call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1) + call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2) + call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3) + do j=1,3 + ctgt=cost/sint + ctgt1=cost1/sint1 + cosg_inv=1.0d0/cosg + dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) + & -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) + & *vbld_inv(i-2+nres) + dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i) + dsintau(j,3,2,i)= + & -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) + & -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1) + dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i) +c Bug fixed 3/24/05 (AL) + dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) + & +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) + & *vbld_inv(i-1+nres) +c & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1) + dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i) + enddo +c Obtaining the gamma derivatives from cosine derivative + else + do j=1,3 + dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* + & dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* + & dc_norm2(j,i-2+nres))/vbld(i-2+nres) + dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i) + dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* + & dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* + & dcosomicron(j,1,1,i) + dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i) + dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* + & dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* + & dc_norm(j,i-1+nres))/vbld(i-1+nres) + dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i) +c write(iout,*) "else",i + enddo + endif + enddo +#ifdef CRYST_SC +c Derivatives of side-chain angles alpha and omega +#if defined(MPI) && defined(PARINTDER) + do i=ibond_start,ibond_end +#else + do i=2,nres-1 +#endif + if(itype(i).ne.10) then + fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1)))) + fac6=fac5/vbld(i) + fac7=fac5*fac5 + fac8=fac5/vbld(i+1) + fac9=fac5/vbld(i+nres) + scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres)) + scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres)) + cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))*( + & scalar(dC_norm(1,i),dC_norm(1,i+nres)) + & -scalar(dC_norm(1,i-1),dC_norm(1,i+nres))) + sina=sqrt(1-cosa*cosa) + sino=dsin(omeg(i)) + do j=1,3 + dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- + & dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1) + dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i) + dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- + & scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1) + dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i) + dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- + & dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ + & vbld(i+nres)) + dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i) + enddo +c obtaining the derivatives of omega from sines + if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. + & omeg(i).gt.pi34.and.omeg(i).le.pi.or. + & omeg(i).gt.-pi.and.omeg(i).le.-pi34) then + fac15=dcos(theta(i+1))/(dsin(theta(i+1))* + & dsin(theta(i+1))) + fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i))) + fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i))) + call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1) + call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2) + call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3) + coso_inv=1.0d0/dcos(omeg(i)) + do j=1,3 + dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) + & +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)-( + & sino*dc_norm(j,i-1))/vbld(i) + domega(j,1,i)=coso_inv*dsinomega(j,1,i) + dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) + & +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) + & -sino*dc_norm(j,i)/vbld(i+1) + domega(j,2,i)=coso_inv*dsinomega(j,2,i) + dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- + & fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ + & vbld(i+nres) + domega(j,3,i)=coso_inv*dsinomega(j,3,i) + enddo + else +c obtaining the derivatives of omega from cosines + fac10=sqrt(0.5d0*(1-dcos(theta(i+1)))) + fac11=sqrt(0.5d0*(1+dcos(theta(i+1)))) + fac12=fac10*sina + fac13=fac12*fac12 + fac14=sina*sina + do j=1,3 + dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* + & dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ + & (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* + & fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13 + domega(j,1,i)=-1/sino*dcosomega(j,1,i) + dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* + & dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* + & dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ + & (scala2-fac11*cosa)*(0.25d0*sina/fac10* + & dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i) + & ))/fac13 + domega(j,2,i)=-1/sino*dcosomega(j,2,i) + dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- + & scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ + & (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14 + domega(j,3,i)=-1/sino*dcosomega(j,3,i) + enddo + endif + endif + enddo +#endif +#if defined(MPI) && defined(PARINTDER) + if (nfgtasks.gt.1) then +#ifdef DEBUG + write (iout,*) "Gather dtheta" +cd call flush(iout) +c write (iout,*) "dtheta before gather" +c do i=1,nres +c write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2) +c enddo +#endif + call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank), + & MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET, + & king,FG_COMM,IERROR) +#ifdef DEBUG +cd write (iout,*) "Gather dphi" +cd call flush(iout) + write (iout,*) "dphi before gather" + do i=1,nres + write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3) + enddo +#endif + call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank), + & MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM, + & king,FG_COMM,IERROR) +cd write (iout,*) "Gather dalpha" +cd call flush(iout) +#ifdef CRYST_SC + call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank), + & MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM, + & king,FG_COMM,IERROR) +cd write (iout,*) "Gather domega" +cd call flush(iout) + call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank), + & MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM, + & king,FG_COMM,IERROR) +#endif + endif +#endif +#ifdef DEBUG + write (iout,*) "dtheta after gather" + do i=1,nres + write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),j=1,2) + enddo + write (iout,*) "dphi after gather" + do i=1,nres + write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3) + enddo +#endif + return + end + + subroutine checkintcartgrad + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.IOUNITS' + include 'COMMON.SETUP' + double precision dthetanum(3,2,maxres),dphinum(3,3,maxres) + & ,dalphanum(3,3,maxres), domeganum(3,3,maxres) + double precision theta_s(maxres),phi_s(maxres),alph_s(maxres), + & omeg_s(maxres),dc_norm_s(3) + double precision aincr /1.0d-5/ + + do i=1,nres + phi_s(i)=phi(i) + theta_s(i)=theta(i) + alph_s(i)=alph(i) + omeg_s(i)=omeg(i) + enddo +c Check theta gradient + write (iout,*) + & "Analytical (upper) and numerical (lower) gradient of theta" + write (iout,*) + do i=3,nres + do j=1,3 + dcji=dc(j,i-2) + dc(j,i-2)=dcji+aincr + call chainbuild_cart + call int_from_cart1(.false.) + dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr + dc(j,i-2)=dcji + dcji=dc(j,i-1) + dc(j,i-1)=dc(j,i-1)+aincr + call chainbuild_cart + dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr + dc(j,i-1)=dcji + enddo + write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3), + & (dtheta(j,2,i),j=1,3) + write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3), + & (dthetanum(j,2,i),j=1,3) + write (iout,'(5x,3f10.5,5x,3f10.5)') + & (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3), + & (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3) + write (iout,*) + enddo +c Check gamma gradient + write (iout,*) + & "Analytical (upper) and numerical (lower) gradient of gamma" + do i=4,nres + do j=1,3 + dcji=dc(j,i-3) + dc(j,i-3)=dcji+aincr + call chainbuild_cart + dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr + dc(j,i-3)=dcji + dcji=dc(j,i-2) + dc(j,i-2)=dcji+aincr + call chainbuild_cart + dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr + dc(j,i-2)=dcji + dcji=dc(j,i-1) + dc(j,i-1)=dc(j,i-1)+aincr + call chainbuild_cart + dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr + dc(j,i-1)=dcji + enddo + write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3), + & (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3) + write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3), + & (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3) + write (iout,'(5x,3(3f10.5,5x))') + & (dphinum(j,1,i)/dphi(j,1,i),j=1,3), + & (dphinum(j,2,i)/dphi(j,2,i),j=1,3), + & (dphinum(j,3,i)/dphi(j,3,i),j=1,3) + write (iout,*) + enddo +c Check alpha gradient + write (iout,*) + & "Analytical (upper) and numerical (lower) gradient of alpha" + do i=2,nres-1 + if(itype(i).ne.10) then + do j=1,3 + dcji=dc(j,i-1) + dc(j,i-1)=dcji+aincr + call chainbuild_cart + dalphanum(j,1,i)=(alph(i)-alph_s(i)) + & /aincr + dc(j,i-1)=dcji + dcji=dc(j,i) + dc(j,i)=dcji+aincr + call chainbuild_cart + dalphanum(j,2,i)=(alph(i)-alph_s(i)) + & /aincr + dc(j,i)=dcji + dcji=dc(j,i+nres) + dc(j,i+nres)=dc(j,i+nres)+aincr + call chainbuild_cart + dalphanum(j,3,i)=(alph(i)-alph_s(i)) + & /aincr + dc(j,i+nres)=dcji + enddo + endif + write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3), + & (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3) + write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3), + & (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3) + write (iout,'(5x,3(3f10.5,5x))') + & (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3), + & (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3), + & (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3) + write (iout,*) + enddo +c Check omega gradient + write (iout,*) + & "Analytical (upper) and numerical (lower) gradient of omega" + do i=2,nres-1 + if(itype(i).ne.10) then + do j=1,3 + dcji=dc(j,i-1) + dc(j,i-1)=dcji+aincr + call chainbuild_cart + domeganum(j,1,i)=(omeg(i)-omeg_s(i)) + & /aincr + dc(j,i-1)=dcji + dcji=dc(j,i) + dc(j,i)=dcji+aincr + call chainbuild_cart + domeganum(j,2,i)=(omeg(i)-omeg_s(i)) + & /aincr + dc(j,i)=dcji + dcji=dc(j,i+nres) + dc(j,i+nres)=dc(j,i+nres)+aincr + call chainbuild_cart + domeganum(j,3,i)=(omeg(i)-omeg_s(i)) + & /aincr + dc(j,i+nres)=dcji + enddo + endif + write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3), + & (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3) + write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3), + & (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3) + write (iout,'(5x,3(3f10.5,5x))') + & (domeganum(j,1,i)/domega(j,1,i),j=1,3), + & (domeganum(j,2,i)/domega(j,2,i),j=1,3), + & (domeganum(j,3,i)/domega(j,3,i),j=1,3) + write (iout,*) + enddo + return + end + + subroutine chainbuild_cart + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.SETUP' + include 'COMMON.CHAIN' + include 'COMMON.LOCAL' + include 'COMMON.TIME1' + include 'COMMON.IOUNITS' + +#ifdef MPI + if (nfgtasks.gt.1) then +c write (iout,*) "BCAST in chainbuild_cart" +c call flush(iout) +c Broadcast the order to build the chain and compute internal coordinates +c to the slaves. The slaves receive the order in ERGASTULUM. + time00=MPI_Wtime() +c write (iout,*) "CHAINBUILD_CART: DC before BCAST" +c do i=0,nres +c write (iout,'(i3,3f10.5,5x,3f10.5)') i,(dc(j,i),j=1,3), +c & (dc(j,i+nres),j=1,3) +c enddo + if (fg_rank.eq.0) + & call MPI_Bcast(7,1,MPI_INTEGER,king,FG_COMM,IERROR) + time_bcast7=time_bcast7+MPI_Wtime()-time00 + time01=MPI_Wtime() + call MPI_Bcast(dc(1,0),6*(nres+1),MPI_DOUBLE_PRECISION, + & king,FG_COMM,IERR) +c write (iout,*) "CHAINBUILD_CART: DC after BCAST" +c do i=0,nres +c write (iout,'(i3,3f10.5,5x,3f10.5)') i,(dc(j,i),j=1,3), +c & (dc(j,i+nres),j=1,3) +c enddo +c write (iout,*) "End BCAST in chainbuild_cart" +c call flush(iout) + time_bcast=time_bcast+MPI_Wtime()-time00 + time_bcastc=time_bcastc+MPI_Wtime()-time01 + endif +#endif + do j=1,3 + c(j,1)=dc(j,0) + enddo + do i=2,nres + do j=1,3 + c(j,i)=c(j,i-1)+dc(j,i-1) + enddo + enddo + do i=1,nres + do j=1,3 + c(j,i+nres)=c(j,i)+dc(j,i+nres) + enddo + enddo +c write (iout,*) "CHAINBUILD_CART" +c call cartprint + call int_from_cart1(.false.) + return + end diff --git a/source/unres/src_MD-DFA-restraints/intcor.f b/source/unres/src_MD-DFA-restraints/intcor.f new file mode 100644 index 0000000..a3cd5d0 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/intlocal.f b/source/unres/src_MD-DFA-restraints/intlocal.f new file mode 100644 index 0000000..2dbcc88 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/kinetic_lesyng.f b/source/unres/src_MD-DFA-restraints/kinetic_lesyng.f new file mode 100644 index 0000000..8535f5d --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/kinetic_lesyng.f @@ -0,0 +1,104 @@ + subroutine kinetic(KE_total) +c---------------------------------------------------------------- +c This subroutine calculates the total kinetic energy of the chain +c----------------------------------------------------------------- + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.MD' + include 'COMMON.IOUNITS' + double precision KE_total + + integer i,j,k + double precision KEt_p,KEt_sc,KEr_p,KEr_sc,incr(3), + & mag1,mag2,v(3) + + KEt_p=0.0d0 + KEt_sc=0.0d0 +c write (iout,*) "ISC",(isc(itype(i)),i=1,nres) +c The translational part for peptide virtual bonds + do j=1,3 + incr(j)=d_t(j,0) + enddo + do i=nnt,nct-1 +c write (iout,*) "Kinetic trp:",i,(incr(j),j=1,3) + do j=1,3 + v(j)=incr(j)+0.5d0*d_t(j,i) + enddo + vtot(i)=v(1)*v(1)+v(2)*v(2)+v(3)*v(3) + KEt_p=KEt_p+(v(1)*v(1)+v(2)*v(2)+v(3)*v(3)) + do j=1,3 + incr(j)=incr(j)+d_t(j,i) + enddo + enddo +c write(iout,*) 'KEt_p', KEt_p +c The translational part for the side chain virtual bond +c Only now we can initialize incr with zeros. It must be equal +c to the velocities of the first Calpha. + do j=1,3 + incr(j)=d_t(j,0) + enddo + do i=nnt,nct + iti=itype(i) + if (itype(i).eq.10) then + do j=1,3 + v(j)=incr(j) + enddo + else + do j=1,3 + v(j)=incr(j)+d_t(j,nres+i) + enddo + endif +c write (iout,*) "Kinetic trsc:",i,(incr(j),j=1,3) +c write (iout,*) "i",i," msc",msc(iti)," v",(v(j),j=1,3) + KEt_sc=KEt_sc+msc(iti)*(v(1)*v(1)+v(2)*v(2)+v(3)*v(3)) + vtot(i+nres)=v(1)*v(1)+v(2)*v(2)+v(3)*v(3) + do j=1,3 + incr(j)=incr(j)+d_t(j,i) + enddo + enddo +c goto 111 +c write(iout,*) 'KEt_sc', KEt_sc +c The part due to stretching and rotation of the peptide groups + KEr_p=0.0D0 + do i=nnt,nct-1 +c write (iout,*) "i",i +c write (iout,*) "i",i," mag1",mag1," mag2",mag2 + do j=1,3 + incr(j)=d_t(j,i) + enddo +c write (iout,*) "Kinetic rotp:",i,(incr(j),j=1,3) + KEr_p=KEr_p+(incr(1)*incr(1)+incr(2)*incr(2) + & +incr(3)*incr(3)) + enddo +c goto 111 +c write(iout,*) 'KEr_p', KEr_p +c The rotational part of the side chain virtual bond + KEr_sc=0.0D0 + do i=nnt,nct + iti=itype(i) + if (itype(i).ne.10) then + do j=1,3 + incr(j)=d_t(j,nres+i) + enddo +c write (iout,*) "Kinetic rotsc:",i,(incr(j),j=1,3) + KEr_sc=KEr_sc+Isc(iti)*(incr(1)*incr(1)+incr(2)*incr(2)+ + & incr(3)*incr(3)) + endif + enddo +c The total kinetic energy + 111 continue +c write(iout,*) 'KEr_sc', KEr_sc + KE_total=0.5d0*(mp*KEt_p+KEt_sc+0.25d0*Ip*KEr_p+KEr_sc) +c write (iout,*) "KE_total",KE_total + return + end + + + + diff --git a/source/unres/src_MD-DFA-restraints/lagrangian_lesyng.F b/source/unres/src_MD-DFA-restraints/lagrangian_lesyng.F new file mode 100644 index 0000000..8a9163a --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/lagrangian_lesyng.F @@ -0,0 +1,726 @@ + subroutine lagrangian +c------------------------------------------------------------------------- +c This subroutine contains the total lagrangain from which the accelerations +c are obtained. For numerical gradient checking, the derivetive of the +c lagrangian in the velocities and coordinates are calculated seperately +c------------------------------------------------------------------------- + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.MD' + include 'COMMON.IOUNITS' + include 'COMMON.CONTROL' + include 'COMMON.MUCA' + include 'COMMON.TIME1' + + integer i,j,ind + double precision zapas(MAXRES6),muca_factor + logical lprn /.false./ + common /cipiszcze/ itime + +#ifdef TIMING + time00=MPI_Wtime() +#endif + do j=1,3 + zapas(j)=-gcart(j,0) + enddo + ind=3 + if (lprn) then + write (iout,*) "Potential forces backbone" + endif + do i=nnt,nct-1 + if (lprn) write (iout,'(i5,3e15.5,5x,3e15.5)') + & i,(-gcart(j,i),j=1,3) + do j=1,3 + ind=ind+1 + zapas(ind)=-gcart(j,i) + enddo + enddo + if (lprn) write (iout,*) "Potential forces sidechain" + do i=nnt,nct + if (itype(i).ne.10) then + if (lprn) write (iout,'(i5,3e15.5,5x,3e15.5)') + & i,(-gcart(j,i),j=1,3) + do j=1,3 + ind=ind+1 + zapas(ind)=-gxcart(j,i) + enddo + endif + enddo + + call ginv_mult(zapas,d_a_work) + + do j=1,3 + d_a(j,0)=d_a_work(j) + enddo + ind=3 + do i=nnt,nct-1 + do j=1,3 + ind=ind+1 + d_a(j,i)=d_a_work(ind) + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + do j=1,3 + ind=ind+1 + d_a(j,i+nres)=d_a_work(ind) + enddo + endif + enddo + + if(lmuca) then + imtime=imtime+1 + if(mucadyn.gt.0) call muca_update(potE) + factor=muca_factor(potE)*t_bath*Rb + +cd print *,'lmuca ',factor,potE + do j=1,3 + d_a(j,0)=d_a(j,0)*factor + enddo + do i=nnt,nct-1 + do j=1,3 + d_a(j,i)=d_a(j,i)*factor + enddo + enddo + do i=nnt,nct + do j=1,3 + d_a(j,i+nres)=d_a(j,i+nres)*factor + enddo + enddo + + endif + + if (lprn) then + write(iout,*) 'acceleration 3D' + write (iout,'(i3,3f10.5,3x,3f10.5)') 0,(d_a(j,0),j=1,3) + do i=nnt,nct-1 + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3) + enddo + do i=nnt,nct + write (iout,'(i3,3f10.5,3x,3f10.5)') + & i+nres,(d_a(j,i+nres),j=1,3) + enddo + endif +#ifdef TIMING + time_lagrangian=time_lagrangian+MPI_Wtime()-time00 +#endif + return + end +c------------------------------------------------------------------ + subroutine setup_MD_matrices + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' + integer ierror +#endif + include 'COMMON.SETUP' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.MD' +#ifndef LANG0 + include 'COMMON.LANGEVIN' +#else + include 'COMMON.LANGEVIN.lang0' +#endif + include 'COMMON.IOUNITS' + include 'COMMON.TIME1' + integer i,j + logical lprn /.false./ + logical osob + double precision dtdi,massvec(maxres2),Gcopy(maxres2,maxres2), + & Ghalf(mmaxres2),sqreig(maxres2), invsqreig(maxres2), Gcopytmp, + & Gsqrptmp, Gsqrmtmp, Gvec2tmp,Gvectmp(maxres2,maxres2) + double precision work(8*maxres6) + integer iwork(maxres6) + common /przechowalnia/ Gcopy,Ghalf,invsqreig,Gvectmp +c +c Set up the matrix of the (dC,dX)-->(C,X) transformation (A), the +c inertia matrix (Gmat) and the inverse of the inertia matrix (Ginv) +c +c Determine the number of degrees of freedom (dimen) and the number of +c sites (dimen1) + dimen=(nct-nnt+1)+nside + dimen1=(nct-nnt)+(nct-nnt+1) + dimen3=dimen*3 +#ifdef MPI + if (nfgtasks.gt.1) then + time00=MPI_Wtime() + call MPI_Bcast(5,1,MPI_INTEGER,king,FG_COMM,IERROR) + time_Bcast=time_Bcast+MPI_Wtime()-time00 + call int_bounds(dimen,igmult_start,igmult_end) + igmult_start=igmult_start-1 + call MPI_Allgather(3*igmult_start,1,MPI_INTEGER, + & ng_start(0),1,MPI_INTEGER,FG_COMM,IERROR) + my_ng_count=igmult_end-igmult_start + call MPI_Allgather(3*my_ng_count,1,MPI_INTEGER,ng_counts(0),1, + & MPI_INTEGER,FG_COMM,IERROR) + write (iout,*) 'Processor:',fg_rank,' CG group',kolor, + & ' absolute rank',myrank,' igmult_start',igmult_start, + & ' igmult_end',igmult_end,' count',my_ng_count + write (iout,*) "ng_start",(ng_start(i),i=0,nfgtasks-1) + write (iout,*) "ng_counts",(ng_counts(i),i=0,nfgtasks-1) + call flush(iout) + else +#endif + igmult_start=1 + igmult_end=dimen + my_ng_count=dimen +#ifdef MPI + endif +#endif +c write (iout,*) "dimen",dimen," dimen1",dimen1," dimen3",dimen3 +c Zeroing out A and fricmat + do i=1,dimen + do j=1,dimen + A(i,j)=0.0D0 + enddo + enddo +c Diagonal elements of the dC part of A and the respective friction coefficients + ind=1 + ind1=0 + do i=nnt,nct-1 + ind=ind+1 + ind1=ind1+1 + coeff=0.25d0*IP + massvec(ind1)=mp + Gmat(ind,ind)=coeff + A(ind1,ind)=0.5d0 + enddo + +c Off-diagonal elements of the dC part of A + k=3 + do i=1,nct-nnt + do j=1,i + A(i,j)=1.0d0 + enddo + enddo +c Diagonal elements of the dX part of A and the respective friction coefficients + m=nct-nnt + m1=nct-nnt+1 + ind=0 + ind1=0 + do i=nnt,nct + ind=ind+1 + ii = ind+m + iti=itype(i) + massvec(ii)=msc(iti) + if (iti.ne.10) then + ind1=ind1+1 + ii1= ind1+m1 + A(ii,ii1)=1.0d0 + Gmat(ii1,ii1)=ISC(iti) + endif + enddo +c Off-diagonal elements of the dX part of A + ind=0 + k=nct-nnt + do i=nnt,nct + iti=itype(i) + ind=ind+1 + do j=nnt,i + ii = ind + jj = j-nnt+1 + A(k+ii,jj)=1.0d0 + enddo + enddo + if (lprn) then + write (iout,*) + write (iout,*) "Vector massvec" + do i=1,dimen1 + write (iout,*) i,massvec(i) + enddo + write (iout,'(//a)') "A" + call matout(dimen,dimen1,maxres2,maxres2,A) + endif + +c Calculate the G matrix (store in Gmat) + do k=1,dimen + do i=1,dimen + dtdi=0.0d0 + do j=1,dimen1 + dtdi=dtdi+A(j,k)*A(j,i)*massvec(j) + enddo + Gmat(k,i)=Gmat(k,i)+dtdi + enddo + enddo + + if (lprn) then + write (iout,'(//a)') "Gmat" + call matout(dimen,dimen,maxres2,maxres2,Gmat) + endif + do i=1,dimen + do j=1,dimen + Ginv(i,j)=0.0d0 + Gcopy(i,j)=Gmat(i,j) + enddo + Ginv(i,i)=1.0d0 + enddo +c Invert the G matrix + call MATINVERT(dimen,maxres2,Gcopy,Ginv,osob) + if (lprn) then + write (iout,'(//a)') "Ginv" + call matout(dimen,dimen,maxres2,maxres2,Ginv) + endif +#ifdef MPI + if (nfgtasks.gt.1) then + myginv_ng_count=maxres2*my_ng_count + call MPI_Allgather(maxres2*igmult_start,1,MPI_INTEGER, + & nginv_start(0),1,MPI_INTEGER,FG_COMM,IERROR) + call MPI_Allgather(myginv_ng_count,1,MPI_INTEGER, + & nginv_counts(0),1,MPI_INTEGER,FG_COMM,IERROR) + if (lprn .and. (me.eq.king .or. .not. out1file) ) then + write (iout,*) "nginv_start",(nginv_start(i),i=0,nfgtasks-1) + write (iout,*) "nginv_counts",(nginv_counts(i),i=0,nfgtasks-1) + call flush(iout) + endif +c call MPI_Scatterv(ginv(1,1),nginv_counts(0), +c & nginv_start(0),MPI_DOUBLE_PRECISION,ginv, +c & myginv_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERR) +c call MPI_Barrier(FG_COMM,IERR) + time00=MPI_Wtime() + call MPI_Scatterv(ginv(1,1),nginv_counts(0), + & nginv_start(0),MPI_DOUBLE_PRECISION,gcopy(1,1), + & myginv_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERR) +#ifdef TIMING + time_scatter_ginv=time_scatter_ginv+MPI_Wtime()-time00 +#endif + do i=1,dimen + do j=1,2*my_ng_count + ginv(j,i)=gcopy(i,j) + enddo + enddo +c write (iout,*) "Master's chunk of ginv" +c call MATOUT2(my_ng_count,dimen,maxres2,maxres2,ginv) + endif +#endif + if (osob) then + write (iout,*) "The G matrix is singular." + stop + endif +c Compute G**(-1/2) and G**(1/2) + ind=0 + do i=1,dimen + do j=1,i + ind=ind+1 + Ghalf(ind)=Gmat(i,j) + enddo + enddo + call gldiag(maxres2,dimen,dimen,Ghalf,work,Geigen,Gvec, + & ierr,iwork) + if (lprn) then + write (iout,'(//a)') + & "Eigenvectors and eigenvalues of the G matrix" + call eigout(dimen,dimen,maxres2,maxres2,Gvec,Geigen) + endif + + do i=1,dimen + sqreig(i)=dsqrt(Geigen(i)) + invsqreig(i)=1.d0/sqreig(i) + enddo + do i=1,dimen + do j=1,dimen + Gvectmp(i,j)=Gvec(j,i) + enddo + enddo + + do i=1,dimen + do j=1,dimen + Gsqrptmp=0.0d0 + Gsqrmtmp=0.0d0 + Gcopytmp=0.0d0 + do k=1,dimen +c Gvec2tmp=Gvec(i,k)*Gvec(j,k) + Gvec2tmp=Gvec(k,i)*Gvec(k,j) + Gsqrptmp=Gsqrptmp+Gvec2tmp*sqreig(k) + Gsqrmtmp=Gsqrmtmp+Gvec2tmp*invsqreig(k) + Gcopytmp=Gcopytmp+Gvec2tmp*Geigen(k) + enddo + Gsqrp(i,j)=Gsqrptmp + Gsqrm(i,j)=Gsqrmtmp + Gcopy(i,j)=Gcopytmp + enddo + enddo + + do i=1,dimen + do j=1,dimen + Gvec(i,j)=Gvectmp(j,i) + enddo + enddo + + if (lprn) then + write (iout,*) "Comparison of original and restored G" + do i=1,dimen + do j=1,dimen + write (iout,'(2i5,5f10.5)') i,j,Gmat(i,j),Gcopy(i,j), + & Gmat(i,j)-Gcopy(i,j),Gsqrp(i,j),Gsqrm(i,j) + enddo + enddo + endif + return + end +c------------------------------------------------------------------------------- + SUBROUTINE EIGOUT(NC,NR,LM2,LM3,A,B) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + double precision A(LM2,LM3),B(LM2) + KA=1 + KC=6 + 1 KB=MIN0(KC,NC) + WRITE(IOUT,600) (I,I=KA,KB) + WRITE(IOUT,601) (B(I),I=KA,KB) + WRITE(IOUT,602) + 2 N=0 + DO 3 I=1,NR + WRITE(IOUT,603) I,(A(I,J),J=KA,KB) + N=N+1 + IF(N.LT.10) GO TO 3 + WRITE(IOUT,602) + N=0 + 3 CONTINUE + 4 IF (KB.EQ.NC) RETURN + KA=KC+1 + KC=KC+6 + GO TO 1 + 600 FORMAT (// 9H ROOT NO.,I4,9I11) + 601 FORMAT (/5X,10(1PE11.4)) + 602 FORMAT (2H ) + 603 FORMAT (I5,10F11.5) + 604 FORMAT (1H1) + END +c------------------------------------------------------------------------------- + SUBROUTINE MATOUT(NC,NR,LM2,LM3,A) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + double precision A(LM2,LM3) + KA=1 + KC=6 + 1 KB=MIN0(KC,NC) + WRITE(IOUT,600) (I,I=KA,KB) + WRITE(IOUT,602) + 2 N=0 + DO 3 I=1,NR + WRITE(IOUT,603) I,(A(I,J),J=KA,KB) + N=N+1 + IF(N.LT.10) GO TO 3 + WRITE(IOUT,602) + N=0 + 3 CONTINUE + 4 IF (KB.EQ.NC) RETURN + KA=KC+1 + KC=KC+6 + GO TO 1 + 600 FORMAT (//5x,9I11) + 602 FORMAT (2H ) + 603 FORMAT (I5,10F11.3) + 604 FORMAT (1H1) + END +c------------------------------------------------------------------------------- + SUBROUTINE MATOUT1(NC,NR,LM2,LM3,A) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + double precision A(LM2,LM3) + KA=1 + KC=21 + 1 KB=MIN0(KC,NC) + WRITE(IOUT,600) (I,I=KA,KB) + WRITE(IOUT,602) + 2 N=0 + DO 3 I=1,NR + WRITE(IOUT,603) I,(A(I,J),J=KA,KB) + N=N+1 + IF(N.LT.3) GO TO 3 + WRITE(IOUT,602) + N=0 + 3 CONTINUE + 4 IF (KB.EQ.NC) RETURN + KA=KC+1 + KC=KC+21 + GO TO 1 + 600 FORMAT (//5x,7(3I5,2x)) + 602 FORMAT (2H ) + 603 FORMAT (I5,7(3F5.1,2x)) + 604 FORMAT (1H1) + END +c------------------------------------------------------------------------------- + SUBROUTINE MATOUT2(NC,NR,LM2,LM3,A) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + double precision A(LM2,LM3) + KA=1 + KC=12 + 1 KB=MIN0(KC,NC) + WRITE(IOUT,600) (I,I=KA,KB) + WRITE(IOUT,602) + 2 N=0 + DO 3 I=1,NR + WRITE(IOUT,603) I,(A(I,J),J=KA,KB) + N=N+1 + IF(N.LT.3) GO TO 3 + WRITE(IOUT,602) + N=0 + 3 CONTINUE + 4 IF (KB.EQ.NC) RETURN + KA=KC+1 + KC=KC+12 + GO TO 1 + 600 FORMAT (//5x,4(3I9,2x)) + 602 FORMAT (2H ) + 603 FORMAT (I5,4(3F9.3,2x)) + 604 FORMAT (1H1) + END +c--------------------------------------------------------------------------- + SUBROUTINE ginv_mult(z,d_a_tmp) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' + integer ierr +#endif + include 'COMMON.SETUP' + include 'COMMON.TIME1' + include 'COMMON.MD' + double precision z(dimen3),d_a_tmp(dimen3),temp(maxres6),time00 + &time01 +#ifdef MPI + if (nfgtasks.gt.1) then + if (fg_rank.eq.0) then +c The matching BROADCAST for fg processors is called in ERGASTULUM + time00=MPI_Wtime() + call MPI_Bcast(4,1,MPI_INTEGER,king,FG_COMM,IERROR) + time_Bcast=time_Bcast+MPI_Wtime()-time00 +c print *,"Processor",myrank," BROADCAST iorder in GINV_MULT" + endif +c write (2,*) "time00",time00 +c write (2,*) "Before Scatterv" +c call flush(2) +c write (2,*) "Whole z (for FG master)" +c do i=1,dimen +c write (2,*) i,z(i) +c enddo +c call MPI_Barrier(FG_COMM,IERROR) + time00=MPI_Wtime() + call MPI_Scatterv(z,ng_counts(0),ng_start(0), + & MPI_DOUBLE_PRECISION, + & z,3*my_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERR) +c write (2,*) "My chunk of z" +c do i=1,3*my_ng_count +c write (2,*) i,z(i) +c enddo +c write (2,*) "After SCATTERV" +c call flush(2) +c write (2,*) "MPI_Wtime",MPI_Wtime() + time_scatter=time_scatter+MPI_Wtime()-time00 +#ifdef TIMING + time_scatter_ginvmult=time_scatter_ginvmult+MPI_Wtime()-time00 +#endif +c write (2,*) "time_scatter",time_scatter +c write (2,*) "dimen",dimen," dimen3",dimen3," my_ng_count", +c & my_ng_count +c call flush(2) + time01=MPI_Wtime() + do k=0,2 + do i=1,dimen + ind=(i-1)*3+k+1 + temp(ind)=0.0d0 + do j=1,my_ng_count +c write (2,*) "k,i,j,ind",k,i,j,ind,(j-1)*3+k+1, +c & Ginv(i,j),z((j-1)*3+k+1), +c & Ginv(i,j)*z((j-1)*3+k+1) +c temp(ind)=temp(ind)+Ginv(i,j)*z((j-1)*3+k+1) + temp(ind)=temp(ind)+Ginv(j,i)*z((j-1)*3+k+1) + enddo + enddo + enddo + time_ginvmult=time_ginvmult+MPI_Wtime()-time01 +c write (2,*) "Before REDUCE" +c call flush(2) +c write (2,*) "z before reduce" +c do i=1,dimen +c write (2,*) i,temp(i) +c enddo + time00=MPI_Wtime() + call MPI_Reduce(temp(1),d_a_tmp(1),dimen3,MPI_DOUBLE_PRECISION, + & MPI_SUM,king,FG_COMM,IERR) + time_reduce=time_reduce+MPI_Wtime()-time00 +c write (2,*) "After REDUCE" +c call flush(2) + else +#endif +#ifdef TIMING + time01=MPI_Wtime() +#endif + do k=0,2 + do i=1,dimen + ind=(i-1)*3+k+1 + d_a_tmp(ind)=0.0d0 + do j=1,dimen +c write (2,*) "k,i,j,ind",k,i,j,ind,(j-1)*3+k+1 +c call flush(2) +c & Ginv(i,j),z((j-1)*3+k+1), +c & Ginv(i,j)*z((j-1)*3+k+1) + d_a_tmp(ind)=d_a_tmp(ind) + & +Ginv(j,i)*z((j-1)*3+k+1) +c d_a_tmp(ind)=d_a_tmp(ind) +c & +Ginv(i,j)*z((j-1)*3+k+1) + enddo + enddo + enddo +#ifdef TIMING + time_ginvmult=time_ginvmult+MPI_Wtime()-time01 +#endif +#ifdef MPI + endif +#endif + return + end +c--------------------------------------------------------------------------- +#ifdef GINV_MULT + SUBROUTINE ginv_mult_test(z,d_a_tmp) + include 'DIMENSIONS' + integer dimen +c include 'COMMON.MD' + double precision z(dimen),d_a_tmp(dimen) + double precision ztmp(dimen/3),dtmp(dimen/3) + +c do i=1,dimen +c d_a_tmp(i)=0.0d0 +c do j=1,dimen +c d_a_tmp(i)=d_a_tmp(i)+Ginv(i,j)*z(j) +c enddo +c enddo +c +c return + +!ibm* unroll(3) + do k=0,2 + do j=1,dimen/3 + ztmp(j)=z((j-1)*3+k+1) + enddo + + call alignx(16,ztmp(1)) + call alignx(16,dtmp(1)) + call alignx(16,Ginv(1,1)) + + do i=1,dimen/3 + dtmp(i)=0.0d0 + do j=1,dimen/3 + dtmp(i)=dtmp(i)+Ginv(i,j)*ztmp(j) + enddo + enddo + do i=1,dimen/3 + ind=(i-1)*3+k+1 + d_a_tmp(ind)=dtmp(i) + enddo + enddo + return + end +#endif +c--------------------------------------------------------------------------- + SUBROUTINE fricmat_mult(z,d_a_tmp) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' + integer IERROR +#endif + include 'COMMON.MD' + include 'COMMON.IOUNITS' + include 'COMMON.SETUP' + include 'COMMON.TIME1' +#ifndef LANG0 + include 'COMMON.LANGEVIN' +#else + include 'COMMON.LANGEVIN.lang0' +#endif + double precision z(dimen3),d_a_tmp(dimen3),temp(maxres6),time00 + &time01 +#ifdef MPI + if (nfgtasks.gt.1) then + if (fg_rank.eq.0) then +c The matching BROADCAST for fg processors is called in ERGASTULUM + time00=MPI_Wtime() + call MPI_Bcast(9,1,MPI_INTEGER,king,FG_COMM,IERROR) + time_Bcast=time_Bcast+MPI_Wtime()-time00 +c print *,"Processor",myrank," BROADCAST iorder in FRICMAT_MULT" + endif +c call MPI_Barrier(FG_COMM,IERROR) + time00=MPI_Wtime() + call MPI_Scatterv(z,ng_counts(0),ng_start(0), + & MPI_DOUBLE_PRECISION, + & z,3*my_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERR) +c write (2,*) "My chunk of z" +c do i=1,3*my_ng_count +c write (2,*) i,z(i) +c enddo + time_scatter=time_scatter+MPI_Wtime()-time00 +#ifdef TIMING + time_scatter_fmatmult=time_scatter_fmatmult+MPI_Wtime()-time00 +#endif + time01=MPI_Wtime() + do k=0,2 + do i=1,dimen + ind=(i-1)*3+k+1 + temp(ind)=0.0d0 + do j=1,my_ng_count + temp(ind)=temp(ind)-fricmat(j,i)*z((j-1)*3+k+1) + enddo + enddo + enddo + time_fricmatmult=time_fricmatmult+MPI_Wtime()-time01 +c write (2,*) "Before REDUCE" +c write (2,*) "d_a_tmp before reduce" +c do i=1,dimen3 +c write (2,*) i,temp(i) +c enddo +c call flush(2) + time00=MPI_Wtime() + call MPI_Reduce(temp(1),d_a_tmp(1),dimen3,MPI_DOUBLE_PRECISION, + & MPI_SUM,king,FG_COMM,IERR) + time_reduce=time_reduce+MPI_Wtime()-time00 +c write (2,*) "After REDUCE" +c call flush(2) + else +#endif +#ifdef TIMING + time01=MPI_Wtime() +#endif + do k=0,2 + do i=1,dimen + ind=(i-1)*3+k+1 + d_a_tmp(ind)=0.0d0 + do j=1,dimen + d_a_tmp(ind)=d_a_tmp(ind) + & -fricmat(j,i)*z((j-1)*3+k+1) + enddo + enddo + enddo +#ifdef TIMING + time_fricmatmult=time_fricmatmult+MPI_Wtime()-time01 +#endif +#ifdef MPI + endif +#endif +c write (iout,*) "Vector d_a" +c do i=1,dimen3 +c write (2,*) i,d_a_tmp(i) +c enddo + return + end diff --git a/source/unres/src_MD-DFA-restraints/local_move.f b/source/unres/src_MD-DFA-restraints/local_move.f new file mode 100644 index 0000000..7a7e125 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/local_move.f @@ -0,0 +1,972 @@ +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) ! 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) ! 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 +c i=move_res(R(0,1),0.D0*deg2rad,180.D0*deg2rad) + imov=nnt + i=move_res(0.D0*deg2rad,180.D0*deg2rad,imov) + print *,'RETURNED ',i + print *,(R(i,3)/vbl,i=0,2) + + return + end + +c------------------------------------------------------------- diff --git a/source/unres/src_MD-DFA-restraints/map.f b/source/unres/src_MD-DFA-restraints/map.f new file mode 100644 index 0000000..9dbe64e --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/map.f @@ -0,0 +1,90 @@ + subroutine map + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.MAP' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.DERIV' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.CONTROL' + include 'COMMON.TORCNSTR' + double precision energia(0:n_ene) + character*5 angid(4) /'PHI','THETA','ALPHA','OMEGA'/ + double precision ang_list(10) + double precision g(maxvar),x(maxvar) + integer nn(10) + write (iout,'(a,i3,a)')'Energy map constructed in the following ', + & nmap,' groups of variables:' + do i=1,nmap + write (iout,'(2a,i3,a,i3)') angid(kang(i)),' of residues ', + & res1(i),' to ',res2(i) + enddo + nmax=nstep(1) + do i=2,nmap + if (nmax.lt.nstep(i)) nmax=nstep(i) + enddo + ntot=nmax**nmap + iii=0 + write (istat,'(1h#,a14,29a15)') (" ",k=1,nmap), + & (ename(print_order(k)),k=1,nprint_ene),"ETOT","GNORM" + do i=0,ntot-1 + ii=i + do j=1,nmap + nn(j)=mod(ii,nmax)+1 + ii=ii/nmax + enddo + do j=1,nmap + if (nn(j).gt.nstep(j)) goto 10 + enddo + iii=iii+1 +Cd write (iout,*) i,iii,(nn(j),j=1,nmap) + do j=1,nmap + ang_list(j)=ang_from(j) + & +(nn(j)-1)*(ang_to(j)-ang_from(j))/nstep(j) + do k=res1(j),res2(j) + goto (1,2,3,4), kang(j) + 1 phi(k)=deg2rad*ang_list(j) + if (minim) phi0(k-res1(j)+1)=deg2rad*ang_list(j) + goto 5 + 2 theta(k)=deg2rad*ang_list(j) + goto 5 + 3 alph(k)=deg2rad*ang_list(j) + goto 5 + 4 omeg(k)=deg2rad*ang_list(j) + 5 continue + enddo ! k + enddo ! j + call chainbuild + call int_from_cart1(.false.) + if (minim) then + call geom_to_var(nvar,x) + call minimize(etot,x,iretcode,nfun) + print *,'SUMSL return code is',iretcode,' eval ',nfun +c call intout + else + call zerograd + call geom_to_var(nvar,x) + endif + call etotal(energia(0)) + etot = energia(0) + nf=1 + nfl=3 + call gradient(nvar,x,nf,g,uiparm,urparm,fdum) + gnorm=0.0d0 + do k=1,nvar + gnorm=gnorm+g(k)**2 + enddo + etot=energia(0) + + gnorm=dsqrt(gnorm) +c write (iout,'(6(1pe15.5))') (ang_list(k),k=1,nmap),etot,gnorm + write (istat,'(30e15.5)') (ang_list(k),k=1,nmap), + & (energia(print_order(ii)),ii=1,nprint_ene),etot,gnorm +c write (iout,*) 'POINT',I,' ANGLES:',(ang_list(k),k=1,nmap) +c call intout +c call enerprint(energia) + 10 continue + enddo ! i + return + end diff --git a/source/unres/src_MD-DFA-restraints/matmult.f b/source/unres/src_MD-DFA-restraints/matmult.f new file mode 100644 index 0000000..e9257cf --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/mc.F b/source/unres/src_MD-DFA-restraints/mc.F new file mode 100644 index 0000000..0f39d48 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/mc.F @@ -0,0 +1,819 @@ + subroutine monte_carlo +C Does Boltzmann and entropic sampling without energy minimization + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' +#ifdef MPL + include 'COMMON.INFO' +#endif + include 'COMMON.GEO' + include 'COMMON.CHAIN' + include 'COMMON.MCM' + include 'COMMON.MCE' + include 'COMMON.CONTACTS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.THREAD' + include 'COMMON.NAMES' + logical accepted,not_done,over,ovrtim,error,lprint + integer MoveType,nbond,nbins + integer conf_comp + double precision RandOrPert + double precision varia(maxvar),elowest,elowest1, + & ehighest,ehighest1,eold + double precision przes(3),obr(3,3) + double precision varold(maxvar) + logical non_conv + integer moves1(-1:MaxMoveType+1,0:MaxProcs-1), + & moves_acc1(-1:MaxMoveType+1,0:MaxProcs-1) +#ifdef MPL + double precision etot_temp,etot_all(0:MaxProcs) + external d_vadd,d_vmin,d_vmax + double precision entropy1(-max_ene:max_ene), + & nhist1(-max_ene:max_ene) + integer nbond_move1(maxres*(MaxProcs+1)), + & nbond_acc1(maxres*(MaxProcs+1)),itemp(2) +#endif + double precision var_lowest(maxvar) + double precision energia(0:n_ene),energia_ave(0:n_ene) +C + write(iout,'(a,i8,2x,a,f10.5)') + & 'pool_read_freq=',pool_read_freq,' pool_fraction=',pool_fraction + open (istat,file=statname) + WhatsUp=0 + indminn=-max_ene + indmaxx=max_ene + facee=1.0D0/(maxacc*delte) +C Number of bins in energy histogram + nbins=e_up/delte-1 + write (iout,*) 'NBINS=',nbins + conste=dlog(facee) +C Read entropy from previous simulations. + if (ent_read) then + read (ientin,*) indminn,indmaxx,emin,emax + print *,'indminn=',indminn,' indmaxx=',indmaxx,' emin=',emin, + & ' emax=',emax + do i=-max_ene,max_ene + entropy(i)=0.0D0 + enddo + read (ientin,*) (ijunk,ejunk,entropy(i),i=indminn,indmaxx) + indmin=indminn + indmax=indmaxx + write (iout,*) 'indminn=',indminn,' indmaxx=',indmaxx, + & ' emin=',emin,' emax=',emax + write (iout,'(/a)') 'Initial entropy' + do i=indminn,indmaxx + write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) + enddo + endif ! ent_read +C Read the pool of conformations + call read_pool + elowest=1.0D+10 + ehighest=-1.0D+10 +C---------------------------------------------------------------------------- +C Entropy-sampling simulations with continually updated entropy; +C set NSWEEP=1 for Boltzmann sampling. +C Loop thru simulations +C---------------------------------------------------------------------------- + DO ISWEEP=1,NSWEEP +C +C Initialize the IFINISH array. +C +#ifdef MPL + do i=1,nctasks + ifinish(i)=0 + enddo +#endif +c--------------------------------------------------------------------------- +C Initialize counters. +c--------------------------------------------------------------------------- +C Total number of generated confs. + ngen=0 +C Total number of moves. In general this won't be equal to the number of +C attempted moves, because we may want to reject some "bad" confs just by +C overlap check. + nmove=0 +C Total number of shift (nbond_move(1)), spike, crankshaft, three-bond,... +C motions. + do i=1,nres + nbond_move(i)=0 + nbond_acc(i)=0 + enddo +C Initialize total and accepted number of moves of various kind. + do i=-1,MaxMoveType + moves(i)=0 + moves_acc(i)=0 + enddo +C Total number of energy evaluations. + neneval=0 + nfun=0 +C---------------------------------------------------------------------------- +C Take a conformation from the pool +C---------------------------------------------------------------------------- + rewind(istat) + write (iout,*) 'emin=',emin,' emax=',emax + if (npool.gt.0) then + ii=iran_num(1,npool) + do i=1,nvar + varia(i)=xpool(i,ii) + enddo + write (iout,*) 'Took conformation',ii,' from the pool energy=', + & epool(ii) + call var_to_geom(nvar,varia) +C Print internal coordinates of the initial conformation + call intout + else if (isweep.gt.1) then + if (eold.lt.emax) then + do i=1,nvar + varia(i)=varold(i) + enddo + else + do i=1,nvar + varia(i)=var_lowest(i) + enddo + endif + call var_to_geom(nvar,varia) + endif +C---------------------------------------------------------------------------- +C Compute and print initial energies. +C---------------------------------------------------------------------------- + nsave=0 + Kwita=0 + WhatsUp=0 + write (iout,'(/80(1h*)/a,i2/80(1h*)/)') 'MCE iteration #',isweep + write (iout,'(/80(1h*)/a)') 'Initial energies:' + call chainbuild + call geom_to_var(nvar,varia) + call etotal(energia(0)) + etot = energia(0) + call enerprint(energia(0)) + if (refstr) then + call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup),nsup,przes, + & obr,non_conv) + rms=dsqrt(rms) + call contact(.false.,ncont,icont,co) + frac=contact_fract(ncont,ncont_ref,icont,icont_ref) + write (iout,'(a,f8.3,a,f8.3,a,f8.3)') + & 'RMS deviation from the reference structure:',rms, + & ' % of native contacts:',frac*100,' contact order',co + write (istat,'(i10,16(1pe14.5))') 0, + & (energia(print_order(i)),i=1,nprint_ene), + & etot,rms,frac,co + else + write (istat,'(i10,14(1pe14.5))') 0, + & (energia(print_order(i)),i=1,nprint_ene),etot + endif +c close(istat) + neneval=neneval+1 + if (.not. ent_read) then +C Initialize the entropy array +#ifdef MPL +C Collect total energies from other processors. + etot_temp=etot + etot_all(0)=etot + call mp_gather(etot_temp,etot_all,8,MasterID,cgGroupID) + if (MyID.eq.MasterID) then +C Get the lowest and the highest energy. + print *,'MASTER: etot_temp: ',(etot_all(i),i=0,nprocs-1), + & ' emin=',emin,' emax=',emax + emin=1.0D10 + emax=-1.0D10 + do i=0,nprocs + if (emin.gt.etot_all(i)) emin=etot_all(i) + if (emax.lt.etot_all(i)) emax=etot_all(i) + enddo + emax=emin+e_up + endif ! MyID.eq.MasterID + etot_all(1)=emin + etot_all(2)=emax + print *,'Processor',MyID,' calls MP_BCAST to send/recv etot_all' + call mp_bcast(etot_all(1),16,MasterID,cgGroupID) + print *,'Processor',MyID,' MP_BCAST to send/recv etot_all ended' + if (MyID.ne.MasterID) then + print *,'Processor:',MyID,etot_all(1),etot_all(2), + & etot_all(1),etot_all(2) + emin=etot_all(1) + emax=etot_all(2) + endif ! MyID.ne.MasterID + write (iout,*) 'After MP_GATHER etot_temp=', + & etot_temp,' emin=',emin +#else + emin=etot + emax=emin+e_up + indminn=0 + indmin=0 +#endif + IF (MULTICAN) THEN +C Multicanonical sampling - start from Boltzmann distribution + do i=-max_ene,max_ene + entropy(i)=(emin+i*delte)*betbol + enddo + ELSE +C Entropic sampling - start from uniform distribution of the density of states + do i=-max_ene,max_ene + entropy(i)=0.0D0 + enddo + ENDIF ! MULTICAN + write (iout,'(/a)') 'Initial entropy' + do i=indminn,indmaxx + write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) + enddo + if (isweep.eq.1) then + emax=emin+e_up + indminn=0 + indmin=0 + indmaxx=indminn+nbins + indmax=indmaxx + endif ! isweep.eq.1 + endif ! .not. ent_read +#ifdef MPL + call recv_stop_sig(Kwita) + if (whatsup.eq.1) then + call send_stop_sig(-2) + not_done=.false. + else if (whatsup.le.-2) then + not_done=.false. + else if (whatsup.eq.2) then + not_done=.false. + else + not_done=.true. + endif +#else + not_done=.true. +#endif + write (iout,'(/80(1h*)/20x,a/80(1h*))') + & 'Enter Monte Carlo procedure.' + close(igeom) + call briefout(0,etot) + do i=1,nvar + varold(i)=varia(i) + enddo + eold=etot + call entropia(eold,sold,indeold) +C NACC is the counter for the accepted conformations of a given processor + nacc=0 +C NACC_TOT counts the total number of accepted conformations + nacc_tot=0 +C Main loop. +c---------------------------------------------------------------------------- +C Zero out average energies + do i=0,n_ene + energia_ave(i)=0.0d0 + enddo +C Initialize energy histogram + do i=-max_ene,max_ene + nhist(i)=0.0D0 + enddo ! i +C Zero out iteration counter. + it=0 + do j=1,nvar + varold(j)=varia(j) + enddo +C Begin MC iteration loop. + do while (not_done) + it=it+1 +C Initialize local counter. + ntrial=0 ! # of generated non-overlapping confs. + noverlap=0 ! # of overlapping confs. + accepted=.false. + do while (.not. accepted .and. WhatsUp.eq.0 .and. Kwita.eq.0) + ntrial=ntrial+1 +C Retrieve the angles of previously accepted conformation + do j=1,nvar + varia(j)=varold(j) + enddo + call var_to_geom(nvar,varia) +C Rebuild the chain. + call chainbuild + MoveType=0 + nbond=0 + lprint=.true. +C Decide whether to take a conformation from the pool or generate/perturb one +C randomly + from_pool=ran_number(0.0D0,1.0D0) + if (npool.gt.0 .and. from_pool.lt.pool_fraction) then +C Throw a dice to choose the conformation from the pool + ii=iran_num(1,npool) + do i=1,nvar + varia(i)=xpool(i,ii) + enddo + call var_to_geom(nvar,varia) + call chainbuild +cd call intout +cd write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) + if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) + & write (iout,'(a,i3,a,f10.5)') + & 'Try conformation',ii,' from the pool energy=',epool(ii) + MoveType=-1 + moves(-1)=moves(-1)+1 + else +C Decide whether to generate a random conformation or perturb the old one + RandOrPert=ran_number(0.0D0,1.0D0) + if (RandOrPert.gt.RanFract) then + if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) + & write (iout,'(a)') 'Perturbation-generated conformation.' + call perturb(error,lprint,MoveType,nbond,0.1D0) + if (error) goto 20 + if (MoveType.lt.1 .or. MoveType.gt.MaxMoveType) then + write (iout,'(/a,i7,a/)') 'Error - unknown MoveType=', + & MoveType,' returned from PERTURB.' + goto 20 + endif + call chainbuild + else + MoveType=0 + moves(0)=moves(0)+1 + nstart_grow=iran_num(3,nres) + if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) + & write (iout,'(2a,i3)') 'Random-generated conformation', + & ' - chain regrown from residue',nstart_grow + call gen_rand_conf(nstart_grow,*30) + endif + call geom_to_var(nvar,varia) + endif ! pool +Cd write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) + ngen=ngen+1 + if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) + & write (iout,'(a,i5,a,i10,a,i10)') + & 'Processor',MyId,' trial move',ntrial,' total generated:',ngen + if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) + & write (*,'(a,i5,a,i10,a,i10)') + & 'Processor',MyId,' trial move',ntrial,' total generated:',ngen + call etotal(energia(0)) + etot = energia(0) + neneval=neneval+1 +cd call enerprint(energia(0)) +cd write(iout,*)'it=',it,' etot=',etot + if (etot-elowest.gt.overlap_cut) then + if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) + & write (iout,'(a,i5,a,1pe14.5)') 'Iteration',it, + & ' Overlap detected in the current conf.; energy is',etot + accepted=.false. + noverlap=noverlap+1 + if (noverlap.gt.maxoverlap) then + write (iout,'(a)') 'Too many overlapping confs.' + goto 20 + endif + else +C-------------------------------------------------------------------------- +C... Acceptance test +C-------------------------------------------------------------------------- + accepted=.false. + if (WhatsUp.eq.0) + & call accept_mc(it,etot,eold,scur,sold,varia,varold,accepted) + if (accepted) then + nacc=nacc+1 + nacc_tot=nacc_tot+1 + if (elowest.gt.etot) then + elowest=etot + do i=1,nvar + var_lowest(i)=varia(i) + enddo + endif + if (ehighest.lt.etot) ehighest=etot + moves_acc(MoveType)=moves_acc(MoveType)+1 + if (MoveType.eq.1) then + nbond_acc(nbond)=nbond_acc(nbond)+1 + endif +C Compare with reference structure. + if (refstr) then + call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup), + & nsup,przes,obr,non_conv) + rms=dsqrt(rms) + call contact(.false.,ncont,icont,co) + frac=contact_fract(ncont,ncont_ref,icont,icont_ref) + endif ! refstr +C +C Periodically save average energies and confs. +C + do i=0,n_ene + energia_ave(i)=energia_ave(i)+energia(i) + enddo + moves(MaxMoveType+1)=nmove + moves_acc(MaxMoveType+1)=nacc + IF ((it/save_frequency)*save_frequency.eq.it) THEN + do i=0,n_ene + energia_ave(i)=energia_ave(i)/save_frequency + enddo + etot_ave=energia_ave(0) +C#ifdef AIX +C open (istat,file=statname,position='append') +C#else +C open (istat,file=statname,access='append') +Cendif + if (print_mc.gt.0) + & write (iout,'(80(1h*)/20x,a,i20)') + & 'Iteration #',it + if (refstr .and. print_mc.gt.0) then + write (iout,'(a,f8.3,a,f8.3,a,f8.3)') + & 'RMS deviation from the reference structure:',rms, + & ' % of native contacts:',frac*100,' contact order:',co + endif + if (print_stat) then + if (refstr) then + write (istat,'(i10,10(1pe14.5))') it, + & (energia_ave(print_order(i)),i=1,nprint_ene), + & etot_ave,rms_ave,frac_ave + else + write (istat,'(i10,10(1pe14.5))') it, + & (energia_ave(print_order(i)),i=1,nprint_ene), + & etot_ave + endif + endif +c close(istat) + if (print_mc.gt.0) + & call statprint(nacc,nfun,iretcode,etot,elowest) +C Print internal coordinates. + if (print_int) call briefout(nacc,etot) + do i=0,n_ene + energia_ave(i)=0.0d0 + enddo + ENDIF ! ( (it/save_frequency)*save_frequency.eq.it) +C Update histogram + inde=icialosc((etot-emin)/delte) + nhist(inde)=nhist(inde)+1.0D0 +#ifdef MPL + if ( (it/message_frequency)*message_frequency.eq.it + & .and. (MyID.ne.MasterID) ) then + call recv_stop_sig(Kwita) + call send_MCM_info(message_frequency) + endif +#endif +C Store the accepted conf. and its energy. + eold=etot + sold=scur + do i=1,nvar + varold(i)=varia(i) + enddo +#ifdef MPL + if (Kwita.eq.0) call recv_stop_sig(kwita) +#endif + endif ! accepted + endif ! overlap +#ifdef MPL + if (MyID.eq.MasterID .and. + & (it/message_frequency)*message_frequency.eq.it) then + call receive_MC_info + if (nacc_tot.ge.maxacc) accepted=.true. + endif +#endif +C if ((ntrial.gt.maxtrial_iter +C & .or. (it/pool_read_freq)*pool_read_freq.eq.it) +C & .and. npool.gt.0) then +C Take a conformation from the pool +C ii=iran_num(1,npool) +C do i=1,nvar +C varold(i)=xpool(i,ii) +C enddo +C if (ntrial.gt.maxtrial_iter) +C & write (iout,*) 'Iteration',it,' max. # of trials exceeded.' +C write (iout,*) +C & 'Take conformation',ii,' from the pool energy=',epool(ii) +C if (print_mc.gt.2) +C & write (iout,'(10f8.3)') (rad2deg*varold(i),i=1,nvar) +C ntrial=0 +C eold=epool(ii) +C call entropia(eold,sold,indeold) +C accepted=.true. +C endif ! (ntrial.gt.maxtrial_iter .and. npool.gt.0) + 30 continue + enddo ! accepted +#ifdef MPL + if (MyID.eq.MasterID .and. + & (it/message_frequency)*message_frequency.eq.it) then + call receive_MC_info + endif + if (Kwita.eq.0) call recv_stop_sig(kwita) +#endif + if (ovrtim()) WhatsUp=-1 +cd write (iout,*) 'WhatsUp=',WhatsUp,' Kwita=',Kwita + not_done = (nacc_tot.lt.maxacc) .and. (WhatsUp.eq.0) + & .and. (Kwita.eq.0) +cd write (iout,*) 'not_done=',not_done +#ifdef MPL + if (Kwita.lt.0) then + print *,'Processor',MyID, + & ' has received STOP signal =',Kwita,' in EntSamp.' +cd print *,'not_done=',not_done + if (Kwita.lt.-1) WhatsUp=Kwita + if (MyID.ne.MasterID) call send_MCM_info(-1) + else if (nacc_tot.ge.maxacc) then + print *,'Processor',MyID,' calls send_stop_sig,', + & ' because a sufficient # of confs. have been collected.' +cd print *,'not_done=',not_done + call send_stop_sig(-1) + if (MyID.ne.MasterID) call send_MCM_info(-1) + else if (WhatsUp.eq.-1) then + print *,'Processor',MyID, + & ' calls send_stop_sig because of timeout.' +cd print *,'not_done=',not_done + call send_stop_sig(-2) + if (MyID.ne.MasterID) call send_MCM_info(-1) + endif +#endif + enddo ! not_done + +C----------------------------------------------------------------- +C... Construct energy histogram & update entropy +C----------------------------------------------------------------- + go to 21 + 20 WhatsUp=-3 +#ifdef MPL + write (iout,*) 'Processor',MyID, + & ' is broadcasting ERROR-STOP signal.' + write (*,*) 'Processor',MyID, + & ' is broadcasting ERROR-STOP signal.' + call send_stop_sig(-3) + if (MyID.ne.MasterID) call send_MCM_info(-1) +#endif + 21 continue + write (iout,'(/a)') 'Energy histogram' + do i=-100,100 + write (iout,'(i5,2f20.5)') i,emin+i*delte,nhist(i) + enddo +#ifdef MPL +C Wait until every processor has sent complete MC info. + if (MyID.eq.MasterID) then + not_done=.true. + do while (not_done) +C write (*,*) 'The IFINISH array:' +C write (*,*) (ifinish(i),i=1,nctasks) + not_done=.false. + do i=2,nctasks + not_done=not_done.or.(ifinish(i).ge.0) + enddo + if (not_done) call receive_MC_info + enddo + endif +C Make collective histogram from the work of all processors. + msglen=(2*max_ene+1)*8 + print *, + & 'Processor',MyID,' calls MP_REDUCE to send/receive histograms', + & ' msglen=',msglen + call mp_reduce(nhist,nhist1,msglen,MasterID,d_vadd, + & cgGroupID) + print *,'Processor',MyID,' MP_REDUCE accomplished for histogr.' + do i=-max_ene,max_ene + nhist(i)=nhist1(i) + enddo +C Collect min. and max. energy + print *, + &'Processor',MyID,' calls MP_REDUCE to send/receive energy borders' + call mp_reduce(elowest,elowest1,8,MasterID,d_vmin,cgGroupID) + call mp_reduce(ehighest,ehighest1,8,MasterID,d_vmax,cgGroupID) + print *,'Processor',MyID,' MP_REDUCE accomplished for energies.' + IF (MyID.eq.MasterID) THEN + elowest=elowest1 + ehighest=ehighest1 +#endif + write (iout,'(a,i10)') '# of accepted confs:',nacc_tot + write (iout,'(a,f10.5,a,f10.5)') 'Lowest energy:',elowest, + & ' Highest energy',ehighest + indmin=icialosc((elowest-emin)/delte) + imdmax=icialosc((ehighest-emin)/delte) + if (indmin.lt.indminn) then + emax=emin+indmin*delte+e_up + indmaxx=indmin+nbins + indminn=indmin + endif + if (.not.ent_read) ent_read=.true. + write(iout,*)'indminn=',indminn,' indmaxx=',indmaxx +C Update entropy (density of states) + do i=indmin,indmax + if (nhist(i).gt.0) then + entropy(i)=entropy(i)+dlog(nhist(i)+0.0D0) + endif + enddo + write (iout,'(/80(1h*)/a,i2/80(1h*)/)') + & 'End of macroiteration',isweep + write (iout,'(a,f10.5,a,f10.5)') 'Elowest=',elowest, + & ' Ehighest=',ehighest + write (iout,'(/a)') 'Energy histogram' + do i=indminn,indmaxx + write (iout,'(i5,2f20.5)') i,emin+i*delte,nhist(i) + enddo + write (iout,'(/a)') 'Entropy' + do i=indminn,indmaxx + write (iout,'(i5,2f20.5)') i,emin+i*delte,entropy(i) + enddo +C----------------------------------------------------------------- +C... End of energy histogram construction +C----------------------------------------------------------------- +#ifdef MPL + ELSE + if (.not. ent_read) ent_read=.true. + ENDIF ! MyID .eq. MaterID + if (MyID.eq.MasterID) then + itemp(1)=indminn + itemp(2)=indmaxx + endif + print *,'before mp_bcast processor',MyID,' indminn=',indminn, + & ' indmaxx=',indmaxx,' itemp=',itemp(1),itemp(2) + call mp_bcast(itemp(1),8,MasterID,cgGroupID) + call mp_bcast(emax,8,MasterID,cgGroupID) + print *,'after mp_bcast processor',MyID,' indminn=',indminn, + & ' indmaxx=',indmaxx,' itemp=',itemp(1),itemp(2) + if (MyID .ne. MasterID) then + indminn=itemp(1) + indmaxx=itemp(2) + endif + msglen=(indmaxx-indminn+1)*8 + print *,'processor',MyID,' calling mp_bcast msglen=',msglen, + & ' indminn=',indminn,' indmaxx=',indmaxx,' isweep=',isweep + call mp_bcast(entropy(indminn),msglen,MasterID,cgGroupID) + IF(MyID.eq.MasterID .and. .not. ovrtim() .and. WhatsUp.ge.0)THEN + open (ientout,file=entname,status='unknown') + write (ientout,'(2i5,2e25.17)') indminn,indmaxx,emin,emax + do i=indminn,indmaxx + write (ientout,'(i5,f10.5,f20.15)') i,emin+i*delte,entropy(i) + enddo + close(ientout) + ELSE + write (iout,*) 'Received from master:' + write (iout,*) 'indminn=',indminn,' indmaxx=',indmaxx, + & ' emin=',emin,' emax=',emax + write (iout,'(/a)') 'Entropy' + do i=indminn,indmaxx + write (iout,'(i5,2f10.5)') i,emin+i*delte,entropy(i) + enddo + ENDIF ! MyID.eq.MasterID + print *,'Processor',MyID,' calls MP_GATHER' + call mp_gather(nbond_move,nbond_move1,4*Nbm,MasterID, + & cgGroupID) + call mp_gather(nbond_acc,nbond_acc1,4*Nbm,MasterID, + & cgGroupID) + print *,'Processor',MyID,' MP_GATHER call accomplished' + if (MyID.eq.MasterID) then + + write (iout,'(/80(1h*)/20x,a)') 'Summary run statistics:' + call statprint(nacc_tot,nfun,iretcode,etot,elowest) + write (iout,'(a)') + & 'Statistics of multiple-bond motions. Total motions:' + write (iout,'(8i10)') (nbond_move(i),i=1,Nbm) + write (iout,'(a)') 'Accepted motions:' + write (iout,'(8i10)') (nbond_acc(i),i=1,Nbm) + + write (iout,'(a)') + & 'Statistics of multi-bond moves of respective processors:' + do iproc=1,Nprocs-1 + do i=1,Nbm + ind=iproc*nbm+i + nbond_move(i)=nbond_move(i)+nbond_move1(ind) + nbond_acc(i)=nbond_acc(i)+nbond_acc1(ind) + enddo + enddo + do iproc=0,NProcs-1 + write (iout,*) 'Processor',iproc,' nbond_move:', + & (nbond_move1(iproc*nbm+i),i=1,Nbm), + & ' nbond_acc:',(nbond_acc1(iproc*nbm+i),i=1,Nbm) + enddo + endif + call mp_gather(moves,moves1,4*(MaxMoveType+3),MasterID, + & cgGroupID) + call mp_gather(moves_acc,moves_acc1,4*(MaxMoveType+3), + & MasterID,cgGroupID) + if (MyID.eq.MasterID) then + do iproc=1,Nprocs-1 + do i=-1,MaxMoveType+1 + moves(i)=moves(i)+moves1(i,iproc) + moves_acc(i)=moves_acc(i)+moves_acc1(i,iproc) + enddo + enddo + nmove=0 + do i=0,MaxMoveType+1 + nmove=nmove+moves(i) + enddo + do iproc=0,NProcs-1 + write (iout,*) 'Processor',iproc,' moves', + & (moves1(i,iproc),i=0,MaxMoveType+1), + & ' moves_acc:',(moves_acc1(i,iproc),i=0,MaxMoveType+1) + enddo + endif +#else + open (ientout,file=entname,status='unknown') + write (ientout,'(2i5,2e25.17)') indminn,indmaxx,emin,emax + do i=indminn,indmaxx + write (ientout,'(i5,f10.5,f20.15)') i,emin+i*delte,entropy(i) + enddo + close(ientout) +#endif + write (iout,'(/80(1h*)/20x,a)') 'Summary run statistics:' + call statprint(nacc_tot,nfun,iretcode,etot,elowest) + write (iout,'(a)') + & 'Statistics of multiple-bond motions. Total motions:' + write (iout,'(8i10)') (nbond_move(i),i=1,Nbm) + write (iout,'(a)') 'Accepted motions:' + write (iout,'(8i10)') (nbond_acc(i),i=1,Nbm) + if (ovrtim() .or. WhatsUp.lt.0) return + +C--------------------------------------------------------------------------- + ENDDO ! ISWEEP +C--------------------------------------------------------------------------- + + runtime=tcpu() + + if (isweep.eq.nsweep .and. it.ge.maxacc) + &write (iout,'(/80(1h*)/20x,a/80(1h*)/)') 'All iterations done.' + return + end +c------------------------------------------------------------------------------ + subroutine accept_mc(it,ecur,eold,scur,sold,x,xold,accepted) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.MCM' + include 'COMMON.MCE' + include 'COMMON.IOUNITS' + include 'COMMON.VAR' +#ifdef MPL + include 'COMMON.INFO' +#endif + include 'COMMON.GEO' + double precision ecur,eold,xx,ran_number,bol + double precision x(maxvar),xold(maxvar) + logical accepted +C Check if the conformation is similar. +cd write (iout,*) 'Enter ACCEPTING' +cd write (iout,*) 'Old PHI angles:' +cd write (iout,*) (rad2deg*xold(i),i=1,nphi) +cd write (iout,*) 'Current angles' +cd write (iout,*) (rad2deg*x(i),i=1,nphi) +cd ddif=dif_ang(nphi,x,xold) +cd write (iout,*) 'Angle norm:',ddif +cd write (iout,*) 'ecur=',ecur,' emax=',emax + if (ecur.gt.emax) then + accepted=.false. + if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) + & write (iout,'(a)') 'Conformation rejected as too high in energy' + return + endif +C Else evaluate the entropy of the conf and compare it with that of the previous +C one. + call entropia(ecur,scur,indecur) +cd print *,'Processor',MyID,' ecur=',ecur,' indecur=',indecur, +cd & ' scur=',scur,' eold=',eold,' sold=',sold +cd print *,'deix=',deix,' dent=',dent,' delte=',delte + if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) then + write(iout,*)'it=',it,'ecur=',ecur,' indecur=',indecur, + & ' scur=',scur + write(iout,*)'eold=',eold,' sold=',sold + endif + if (scur.le.sold) then + accepted=.true. + else +C Else carry out acceptance test + xx=ran_number(0.0D0,1.0D0) + xxh=scur-sold + if (xxh.gt.50.0D0) then + bol=0.0D0 + else + bol=exp(-xxh) + endif + if (bol.gt.xx) then + accepted=.true. + if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) + & write (iout,'(a)') 'Conformation accepted.' + else + accepted=.false. + if (print_mc.gt.0 .and. (it/print_freq)*print_freq.eq.it) + & write (iout,'(a)') 'Conformation rejected.' + endif + endif + return + end +c-------------------------------------------------------------------------- + integer function icialosc(x) + double precision x + if (x.lt.0.0D0) then + icialosc=dint(x)-1 + else + icialosc=dint(x) + endif + return + end +c-------------------------------------------------------------------------- + subroutine entropia(ecur,scur,indecur) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.MCM' + include 'COMMON.MCE' + include 'COMMON.IOUNITS' + double precision ecur,scur + integer indecur + indecur=icialosc((ecur-emin)/delte) + if (iabs(indecur).gt.max_ene) then + if ((it/print_freq)*it.eq.it) write (iout,'(a,2i5)') + & 'Accepting: Index out of range:',indecur + scur=1000.0D0 + else if (indecur.ge.indmaxx) then + scur=entropy(indecur) + if (print_mc.gt.0 .and. (it/print_freq)*it.eq.it) + & write (iout,*)'Energy boundary reached', + & indmaxx,indecur,entropy(indecur) + else + deix=ecur-(emin+indecur*delte) + dent=entropy(indecur+1)-entropy(indecur) + scur=entropy(indecur)+(dent/delte)*deix + endif + return + end diff --git a/source/unres/src_MD-DFA-restraints/mcm.F b/source/unres/src_MD-DFA-restraints/mcm.F new file mode 100644 index 0000000..d9ca9ad --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/mcm.F @@ -0,0 +1,1481 @@ + subroutine mcm_setup + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.MCM' + include 'COMMON.CONTROL' + include 'COMMON.INTERACT' + include 'COMMON.NAMES' + include 'COMMON.CHAIN' + include 'COMMON.VAR' +C +C Set up variables used in MC/MCM. +C + write (iout,'(80(1h*)/20x,a/80(1h*))') 'MCM control parameters:' + write (iout,'(5(a,i7))') 'Maxacc:',maxacc,' MaxTrial:',MaxTrial, + & ' MaxRepm:',MaxRepm,' MaxGen:',MaxGen,' MaxOverlap:',MaxOverlap + write (iout,'(4(a,f8.1)/2(a,i3))') + & 'Tmin:',Tmin,' Tmax:',Tmax,' TstepH:',TstepH, + & ' TstepC:',TstepC,'NstepH:',NstepH,' NstepC:',NstepC + if (nwindow.gt.0) then + write (iout,'(a)') 'Perturbation windows:' + do i=1,nwindow + i1=winstart(i) + i2=winend(i) + it1=itype(i1) + it2=itype(i2) + write (iout,'(a,i3,a,i3,a,i3)') restyp(it1),i1,restyp(it2),i2, + & ' length',winlen(i) + enddo + endif +C Rbolt=8.3143D-3*2.388459D-01 kcal/(mol*K) + RBol=1.9858D-3 +C Number of "end bonds". + koniecl=0 +c koniecl=nphi + print *,'koniecl=',koniecl + write (iout,'(a)') 'Probabilities of move types:' + write (*,'(a)') 'Probabilities of move types:' + do i=1,MaxMoveType + write (iout,'(a,f10.5)') MovTypID(i), + & sumpro_type(i)-sumpro_type(i-1) + write (*,'(a,f10.5)') MovTypID(i), + & sumpro_type(i)-sumpro_type(i-1) + enddo + write (iout,*) +C Maximum length of N-bond segment to be moved +c nbm=nres-1-(2*koniecl-1) + if (nwindow.gt.0) then + maxwinlen=winlen(1) + do i=2,nwindow + if (winlen(i).gt.maxwinlen) maxwinlen=winlen(i) + enddo + nbm=min0(maxwinlen,6) + write (iout,'(a,i3,a,i3)') 'Nbm=',Nbm,' Maxwinlen=',Maxwinlen + else + nbm=min0(6,nres-2) + endif + sumpro_bond(0)=0.0D0 + sumpro_bond(1)=0.0D0 + do i=2,nbm + sumpro_bond(i)=sumpro_bond(i-1)+1.0D0/dfloat(i) + enddo + write (iout,'(a)') 'The SumPro_Bond array:' + write (iout,'(8f10.5)') (sumpro_bond(i),i=1,nbm) + write (*,'(a)') 'The SumPro_Bond array:' + write (*,'(8f10.5)') (sumpro_bond(i),i=1,nbm) +C Maximum number of side chains moved simultaneously +c print *,'nnt=',nnt,' nct=',nct + ngly=0 + do i=nnt,nct + if (itype(i).eq.10) ngly=ngly+1 + enddo + mmm=nct-nnt-ngly+1 + if (mmm.gt.0) then + MaxSideMove=min0((nct-nnt+1)/2,mmm) + endif +c print *,'MaxSideMove=',MaxSideMove +C Max. number of generated confs (not used at present). + maxgen=10000 +C Set initial temperature + Tcur=Tmin + betbol=1.0D0/(Rbol*Tcur) + write (iout,'(a,f8.1,a,f10.5)') 'Initial temperature:',Tcur, + & ' BetBol:',betbol + write (iout,*) 'RanFract=',ranfract + return + end +c------------------------------------------------------------------------------ +#ifndef MPI + subroutine do_mcm(i_orig) +C Monte-Carlo-with-Minimization calculations - serial code. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.CHAIN' + include 'COMMON.MCM' + include 'COMMON.CONTACTS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.CACHE' +crc include 'COMMON.DEFORM' +crc include 'COMMON.DEFORM1' + include 'COMMON.NAMES' + logical accepted,over,ovrtim,error,lprint,not_done,my_conf, + & enelower,non_conv + integer MoveType,nbond,conf_comp + integer ifeed(max_cache) + double precision varia(maxvar),varold(maxvar),elowest,eold, + & przes(3),obr(3,3) + double precision energia(0:n_ene) + double precision coord1(maxres,3) + +C--------------------------------------------------------------------------- +C Initialize counters. +C--------------------------------------------------------------------------- +C Total number of generated confs. + ngen=0 +C Total number of moves. In general this won't be equal to the number of +C attempted moves, because we may want to reject some "bad" confs just by +C overlap check. + nmove=0 +C Total number of temperature jumps. + ntherm=0 +C Total number of shift (nbond_move(1)), spike, crankshaft, three-bond,... +C motions. + ncache=0 + do i=1,nres + nbond_move(i)=0 + enddo +C Initialize total and accepted number of moves of various kind. + do i=0,MaxMoveType + moves(i)=0 + moves_acc(i)=0 + enddo +C Total number of energy evaluations. + neneval=0 + nfun=0 + nsave=0 + + write (iout,*) 'RanFract=',RanFract + + WhatsUp=0 + Kwita=0 + +c---------------------------------------------------------------------------- +C Compute and print initial energies. +c---------------------------------------------------------------------------- + call intout + write (iout,'(/80(1h*)/a)') 'Initial energies:' + call chainbuild + nf=0 + + call etotal(energia(0)) + etot = energia(0) +C Minimize the energy of the first conformation. + if (minim) then + call geom_to_var(nvar,varia) +! write (iout,*) 'The VARIA array' +! write (iout,'(8f10.4)') (rad2deg*varia(i),i=1,nvar) + call minimize(etot,varia,iretcode,nfun) + call var_to_geom(nvar,varia) + call chainbuild + write (iout,*) 'etot from MINIMIZE:',etot +! write (iout,*) 'Tha VARIA array' +! write (iout,'(8f10.4)') (rad2deg*varia(i),i=1,nvar) + + call etotal(energia(0)) + etot=energia(0) + call enerprint(energia(0)) + endif + if (refstr) then + call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup),nsup,przes, + & obr,non_conv) + rms=dsqrt(rms) + call contact(.false.,ncont,icont,co) + frac=contact_fract(ncont,ncont_ref,icont,icont_ref) + write (iout,'(a,f8.3,a,f8.3,a,f8.3)') + & 'RMS deviation from the reference structure:',rms, + & ' % of native contacts:',frac*100,' contact order:',co + if (print_stat) + & write (istat,'(i5,17(1pe14.5))') 0, + & (energia(print_order(i)),i=1,nprint_ene), + & etot,rms,frac,co + else + if (print_stat) write (istat,'(i5,16(1pe14.5))') 0, + & (energia(print_order(i)),i=1,nprint_ene),etot + endif + if (print_stat) close(istat) + neneval=neneval+nfun+1 + write (iout,'(/80(1h*)/20x,a/80(1h*))') + & 'Enter Monte Carlo procedure.' + if (print_int) then + close(igeom) + call briefout(0,etot) + endif + eold=etot + do i=1,nvar + varold(i)=varia(i) + enddo + elowest=etot + call zapis(varia,etot) + nacc=0 ! total # of accepted confs of the current processor. + nacc_tot=0 ! total # of accepted confs of all processors. + + not_done = (iretcode.ne.11) + +C---------------------------------------------------------------------------- +C Main loop. +c---------------------------------------------------------------------------- + it=0 + nout=0 + do while (not_done) + it=it+1 + write (iout,'(80(1h*)/20x,a,i7)') + & 'Beginning iteration #',it +C Initialize local counter. + ntrial=0 ! # of generated non-overlapping confs. + accepted=.false. + do while (.not. accepted) + +C Retrieve the angles of previously accepted conformation + noverlap=0 ! # of overlapping confs. + do j=1,nvar + varia(j)=varold(j) + enddo + call var_to_geom(nvar,varia) +C Rebuild the chain. + call chainbuild +C Heat up the system, if necessary. + call heat(over) +C If temperature cannot be further increased, stop. + if (over) goto 20 + MoveType=0 + nbond=0 + lprint=.true. +cd write (iout,'(a)') 'Old variables:' +cd write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) +C Decide whether to generate a random conformation or perturb the old one + RandOrPert=ran_number(0.0D0,1.0D0) + if (RandOrPert.gt.RanFract) then + if (print_mc.gt.0) + & write (iout,'(a)') 'Perturbation-generated conformation.' + call perturb(error,lprint,MoveType,nbond,1.0D0) + if (error) goto 20 + if (MoveType.lt.1 .or. MoveType.gt.MaxMoveType) then + write (iout,'(/a,i7,a/)') 'Error - unknown MoveType=', + & MoveType,' returned from PERTURB.' + goto 20 + endif + call chainbuild + else + MoveType=0 + moves(0)=moves(0)+1 + nstart_grow=iran_num(3,nres) + if (print_mc.gt.0) + & write (iout,'(2a,i3)') 'Random-generated conformation', + & ' - chain regrown from residue',nstart_grow + call gen_rand_conf(nstart_grow,*30) + endif + call geom_to_var(nvar,varia) +cd write (iout,'(a)') 'New variables:' +cd write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) + ngen=ngen+1 + + call etotal(energia(0)) + etot=energia(0) +c call enerprint(energia(0)) +c write (iout,'(2(a,1pe14.5))') 'Etot=',Etot,' Elowest=',Elowest + if (etot-elowest.gt.overlap_cut) then + if(iprint.gt.1.or.etot.lt.1d20) + & write (iout,'(a,1pe14.5)') + & 'Overlap detected in the current conf.; energy is',etot + neneval=neneval+1 + accepted=.false. + noverlap=noverlap+1 + if (noverlap.gt.maxoverlap) then + write (iout,'(a)') 'Too many overlapping confs.' + goto 20 + endif + else + if (minim) then + call minimize(etot,varia,iretcode,nfun) +cd write (iout,*) 'etot from MINIMIZE:',etot +cd write (iout,'(a)') 'Variables after minimization:' +cd write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) + + call etotal(energia(0)) + etot = energia(0) + neneval=neneval+nfun+2 + endif +c call enerprint(energia(0)) + write (iout,'(a,i6,a,1pe16.6)') 'Conformation:',ngen, + & ' energy:',etot +C-------------------------------------------------------------------------- +C... Do Metropolis test +C-------------------------------------------------------------------------- + accepted=.false. + my_conf=.false. + + if (WhatsUp.eq.0 .and. Kwita.eq.0) then + call metropolis(nvar,varia,varold,etot,eold,accepted, + & my_conf,EneLower) + endif + write (iout,*) 'My_Conf=',My_Conf,' EneLower=',EneLower + if (accepted) then + + nacc=nacc+1 + nacc_tot=nacc_tot+1 + if (elowest.gt.etot) elowest=etot + moves_acc(MoveType)=moves_acc(MoveType)+1 + if (MoveType.eq.1) then + nbond_acc(nbond)=nbond_acc(nbond)+1 + endif +C Check against conformation repetitions. + irepet=conf_comp(varia,etot) + if (print_stat) then +#if defined(AIX) || defined(PGI) + open (istat,file=statname,position='append') +#else + open (istat,file=statname,access='append') +#endif + endif + call statprint(nacc,nfun,iretcode,etot,elowest) + if (refstr) then + call var_to_geom(nvar,varia) + call chainbuild + call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup), + & nsup,przes,obr,non_conv) + rms=dsqrt(rms) + call contact(.false.,ncont,icont,co) + frac=contact_fract(ncont,ncont_ref,icont,icont_ref) + write (iout,'(a,f8.3,a,f8.3)') + & 'RMS deviation from the reference structure:',rms, + & ' % of native contacts:',frac*100,' contact order',co + endif ! refstr + if (My_Conf) then + nout=nout+1 + write (iout,*) 'Writing new conformation',nout + if (refstr) then + write (istat,'(i5,16(1pe14.5))') nout, + & (energia(print_order(i)),i=1,nprint_ene), + & etot,rms,frac + else + if (print_stat) + & write (istat,'(i5,17(1pe14.5))') nout, + & (energia(print_order(i)),i=1,nprint_ene),etot + endif ! refstr + if (print_stat) close(istat) +C Print internal coordinates. + if (print_int) call briefout(nout,etot) +C Accumulate the newly accepted conf in the coord1 array, if it is different +C from all confs that are already there. + call compare_s1(n_thr,max_thread2,etot,varia,ii, + & enetb1,coord1,rms_deform,.true.,iprint) + write (iout,*) 'After compare_ss: n_thr=',n_thr + if (ii.eq.1 .or. ii.eq.3) then + write (iout,'(8f10.4)') + & (rad2deg*coord1(i,n_thr),i=1,nvar) + endif + else + write (iout,*) 'Conformation from cache, not written.' + endif ! My_Conf + + if (nrepm.gt.maxrepm) then + write (iout,'(a)') 'Too many conformation repetitions.' + goto 20 + endif +C Store the accepted conf. and its energy. + eold=etot + do i=1,nvar + varold(i)=varia(i) + enddo + if (irepet.eq.0) call zapis(varia,etot) +C Lower the temperature, if necessary. + call cool + + else + + ntrial=ntrial+1 + endif ! accepted + endif ! overlap + + 30 continue + enddo ! accepted +C Check for time limit. + if (ovrtim()) WhatsUp=-1 + not_done = (nacc_tot.lt.maxacc) .and. (WhatsUp.eq.0) + & .and. (Kwita.eq.0) + + enddo ! not_done + goto 21 + 20 WhatsUp=-3 + + 21 continue + runtime=tcpu() + write (iout,'(/80(1h*)/20x,a)') 'Summary run statistics:' + call statprint(nacc,nfun,iretcode,etot,elowest) + write (iout,'(a)') + & 'Statistics of multiple-bond motions. Total motions:' + write (iout,'(16i5)') (nbond_move(i),i=1,Nbm) + write (iout,'(a)') 'Accepted motions:' + write (iout,'(16i5)') (nbond_acc(i),i=1,Nbm) + if (it.ge.maxacc) + &write (iout,'(/80(1h*)/20x,a/80(1h*)/)') 'All iterations done.' + + return + end +#endif +#ifdef MPI +c------------------------------------------------------------------------------ + subroutine do_mcm(i_orig) +C Monte-Carlo-with-Minimization calculations - parallel code. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'mpif.h' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.CHAIN' + include 'COMMON.MCM' + include 'COMMON.CONTACTS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.INFO' + include 'COMMON.CACHE' +crc include 'COMMON.DEFORM' +crc include 'COMMON.DEFORM1' +crc include 'COMMON.DEFORM2' + include 'COMMON.MINIM' + include 'COMMON.NAMES' + logical accepted,over,ovrtim,error,lprint,not_done,similar, + & enelower,non_conv,flag,finish + integer MoveType,nbond,conf_comp + double precision varia(maxvar),varold(maxvar),elowest,eold, + & x1(maxvar), varold1(maxvar), przes(3),obr(3,3) + integer iparentx(max_threadss2) + integer iparentx1(max_threadss2) + integer imtasks(150),imtasks_n + double precision energia(0:n_ene) + + print *,'Master entered DO_MCM' + nodenum = nprocs + + finish=.false. + imtasks_n=0 + do i=1,nodenum-1 + imtasks(i)=0 + enddo +C--------------------------------------------------------------------------- +C Initialize counters. +C--------------------------------------------------------------------------- +C Total number of generated confs. + ngen=0 +C Total number of moves. In general this won`t be equal to the number of +C attempted moves, because we may want to reject some "bad" confs just by +C overlap check. + nmove=0 +C Total number of temperature jumps. + ntherm=0 +C Total number of shift (nbond_move(1)), spike, crankshaft, three-bond,... +C motions. + ncache=0 + do i=1,nres + nbond_move(i)=0 + enddo +C Initialize total and accepted number of moves of various kind. + do i=0,MaxMoveType + moves(i)=0 + moves_acc(i)=0 + enddo +C Total number of energy evaluations. + neneval=0 + nfun=0 + nsave=0 +c write (iout,*) 'RanFract=',RanFract + WhatsUp=0 + Kwita=0 +c---------------------------------------------------------------------------- +C Compute and print initial energies. +c---------------------------------------------------------------------------- + call intout + write (iout,'(/80(1h*)/a)') 'Initial energies:' + call chainbuild + nf=0 + call etotal(energia(0)) + etot = energia(0) + call enerprint(energia(0)) +C Request energy computation from slave processors. + call geom_to_var(nvar,varia) +! write (iout,*) 'The VARIA array' +! write (iout,'(8f10.4)') (rad2deg*varia(i),i=1,nvar) + call minimize(etot,varia,iretcode,nfun) + call var_to_geom(nvar,varia) + call chainbuild + write (iout,*) 'etot from MINIMIZE:',etot +! write (iout,*) 'Tha VARIA array' +! write (iout,'(8f10.4)') (rad2deg*varia(i),i=1,nvar) + neneval=0 + eneglobal=1.0d99 + if (print_mc .gt. 0) write (iout,'(/80(1h*)/20x,a/80(1h*))') + & 'Enter Monte Carlo procedure.' + if (print_mc .gt. 0) write (iout,'(i5,1pe14.5)' ) i_orig,etot + eold=etot + do i=1,nvar + varold(i)=varia(i) + enddo + elowest=etot + call zapis(varia,etot) +c diagnostics + call var_to_geom(nvar,varia) + call chainbuild + call etotal(energia(0)) + if (print_mc.gt.0) write (iout,*) 'Initial energy:',etot +c end diagnostics + nacc=0 ! total # of accepted confs of the current processor. + nacc_tot=0 ! total # of accepted confs of all processors. + not_done=.true. +C---------------------------------------------------------------------------- +C Main loop. +c---------------------------------------------------------------------------- + it=0 + nout=0 + LOOP1:do while (not_done) + it=it+1 + if (print_mc.gt.0) write (iout,'(80(1h*)/20x,a,i7)') + & 'Beginning iteration #',it +C Initialize local counter. + ntrial=0 ! # of generated non-overlapping confs. + noverlap=0 ! # of overlapping confs. + accepted=.false. + LOOP2:do while (.not. accepted) + + LOOP3:do while (imtasks_n.lt.nodenum-1.and..not.finish) + do i=1,nodenum-1 + if(imtasks(i).eq.0) then + is=i + exit + endif + enddo +C Retrieve the angles of previously accepted conformation + do j=1,nvar + varia(j)=varold(j) + enddo + call var_to_geom(nvar,varia) +C Rebuild the chain. + call chainbuild +C Heat up the system, if necessary. + call heat(over) +C If temperature cannot be further increased, stop. + if (over) then + finish=.true. + endif + MoveType=0 + nbond=0 +c write (iout,'(a)') 'Old variables:' +c write (iout,'(10f8.1)') (rad2deg*varia(i),i=1,nvar) +C Decide whether to generate a random conformation or perturb the old one + RandOrPert=ran_number(0.0D0,1.0D0) + if (RandOrPert.gt.RanFract) then + if (print_mc.gt.0) + & write (iout,'(a)') 'Perturbation-generated conformation.' + call perturb(error,lprint,MoveType,nbond,1.0D0) +c print *,'after perturb',error,finish + if (error) finish = .true. + if (MoveType.lt.1 .or. MoveType.gt.MaxMoveType) then + write (iout,'(/a,i7,a/)') 'Error - unknown MoveType=', + & MoveType,' returned from PERTURB.' + finish=.true. + write (*,'(/a,i7,a/)') 'Error - unknown MoveType=', + & MoveType,' returned from PERTURB.' + endif + call chainbuild + else + MoveType=0 + moves(0)=moves(0)+1 + nstart_grow=iran_num(3,nres) + if (print_mc.gt.0) + & write (iout,'(2a,i3)') 'Random-generated conformation', + & ' - chain regrown from residue',nstart_grow + call gen_rand_conf(nstart_grow,*30) + endif + call geom_to_var(nvar,varia) + ngen=ngen+1 +c print *,'finish=',finish + if (etot-elowest.gt.overlap_cut) then + if (print_mc.gt.1) write (iout,'(a,1pe14.5)') + & 'Overlap detected in the current conf.; energy is',etot + if(iprint.gt.1.or.etot.lt.1d19) print *, + & 'Overlap detected in the current conf.; energy is',etot + neneval=neneval+1 + accepted=.false. + noverlap=noverlap+1 + if (noverlap.gt.maxoverlap) then + write (iout,*) 'Too many overlapping confs.', + & ' etot, elowest, overlap_cut', etot, elowest, overlap_cut + finish=.true. + endif + else if (.not. finish) then +C Distribute tasks to processors +c print *,'Master sending order' + call MPI_SEND(12, 1, MPI_INTEGER, is, tag, + & CG_COMM, ierr) +c write (iout,*) '12: tag=',tag +c print *,'Master sent order to processor',is + call MPI_SEND(it, 1, MPI_INTEGER, is, tag, + & CG_COMM, ierr) +c write (iout,*) 'it: tag=',tag + call MPI_SEND(eold, 1, MPI_DOUBLE_PRECISION, is, tag, + & CG_COMM, ierr) +c write (iout,*) 'eold: tag=',tag + call MPI_SEND(varia(1), nvar, MPI_DOUBLE_PRECISION, + & is, tag, + & CG_COMM, ierr) +c write (iout,*) 'varia: tag=',tag + call MPI_SEND(varold(1), nvar, MPI_DOUBLE_PRECISION, + & is, tag, + & CG_COMM, ierr) +c write (iout,*) 'varold: tag=',tag +#ifdef AIX + call flush_(iout) +#else + call flush(iout) +#endif + imtasks(is)=1 + imtasks_n=imtasks_n+1 +C End distribution + endif ! overlap + enddo LOOP3 + + flag = .false. + LOOP_RECV:do while(.not.flag) + do is=1, nodenum-1 + call MPI_IPROBE(is,tag,CG_COMM,flag,status,ierr) + if(flag) then + call MPI_RECV(iitt, 1, MPI_INTEGER, is, tag, + & CG_COMM, status, ierr) + call MPI_RECV(eold1, 1, MPI_DOUBLE_PRECISION, is, tag, + & CG_COMM, status, ierr) + call MPI_RECV(etot, 1, MPI_DOUBLE_PRECISION, is, tag, + & CG_COMM, status, ierr) + call MPI_RECV(varia(1), nvar, MPI_DOUBLE_PRECISION,is,tag, + & CG_COMM, status, ierr) + call MPI_RECV(varold1(1), nvar, MPI_DOUBLE_PRECISION, is, + & tag, CG_COMM, status, ierr) + call MPI_RECV(ii_grnum_d, 1, MPI_INTEGER, is, tag, + & CG_COMM, status, ierr) + call MPI_RECV(ii_ennum_d, 1, MPI_INTEGER, is, tag, + & CG_COMM, status, ierr) + call MPI_RECV(ii_hesnum_d, 1, MPI_INTEGER, is, tag, + & CG_COMM, status, ierr) + i_grnum_d=i_grnum_d+ii_grnum_d + i_ennum_d=i_ennum_d+ii_ennum_d + neneval = neneval+ii_ennum_d + i_hesnum_d=i_hesnum_d+ii_hesnum_d + i_minimiz=i_minimiz+1 + imtasks(is)=0 + imtasks_n=imtasks_n-1 + exit + endif + enddo + enddo LOOP_RECV + + if(print_mc.gt.0) write (iout,'(a,i6,a,i6,a,i6,a,1pe16.6)') + & 'From Worker #',is,' iitt',iitt, + & ' Conformation:',ngen,' energy:',etot +C-------------------------------------------------------------------------- +C... Do Metropolis test +C-------------------------------------------------------------------------- + call metropolis(nvar,varia,varold1,etot,eold1,accepted, + & similar,EneLower) + if(iitt.ne.it.and..not.similar) then + call metropolis(nvar,varia,varold,etot,eold,accepted, + & similar,EneLower) + accepted=enelower + endif + if(etot.lt.eneglobal)eneglobal=etot +c if(mod(it,100).eq.0) + write(iout,*)'CHUJOJEB ',neneval,eneglobal + if (accepted) then +C Write the accepted conformation. + nout=nout+1 + if (refstr) then + call var_to_geom(nvar,varia) + call chainbuild + call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup), + & nsup,przes,obr,non_conv) + rms=dsqrt(rms) + call contact(.false.,ncont,icont,co) + frac=contact_fract(ncont,ncont_ref,icont,icont_ref) + write (iout,'(a,f8.3,a,f8.3,a,f8.3)') + & 'RMS deviation from the reference structure:',rms, + & ' % of native contacts:',frac*100,' contact order:',co + endif ! refstr + if (print_mc.gt.0) + & write (iout,*) 'Writing new conformation',nout + if (print_stat) then + call var_to_geom(nvar,varia) +#if defined(AIX) || defined(PGI) + open (istat,file=statname,position='append') +#else + open (istat,file=statname,access='append') +#endif + if (refstr) then + write (istat,'(i5,16(1pe14.5))') nout, + & (energia(print_order(i)),i=1,nprint_ene), + & etot,rms,frac + else + write (istat,'(i5,16(1pe14.5))') nout, + & (energia(print_order(i)),i=1,nprint_ene),etot + endif ! refstr + close(istat) + endif ! print_stat +C Print internal coordinates. + if (print_int) call briefout(nout,etot) + nacc=nacc+1 + nacc_tot=nacc_tot+1 + if (elowest.gt.etot) elowest=etot + moves_acc(MoveType)=moves_acc(MoveType)+1 + if (MoveType.eq.1) then + nbond_acc(nbond)=nbond_acc(nbond)+1 + endif +C Check against conformation repetitions. + irepet=conf_comp(varia,etot) + if (nrepm.gt.maxrepm) then + if (print_mc.gt.0) + & write (iout,'(a)') 'Too many conformation repetitions.' + finish=.true. + endif +C Store the accepted conf. and its energy. + eold=etot + do i=1,nvar + varold(i)=varia(i) + enddo + if (irepet.eq.0) call zapis(varia,etot) +C Lower the temperature, if necessary. + call cool + else + ntrial=ntrial+1 + endif ! accepted + 30 continue + if(finish.and.imtasks_n.eq.0)exit LOOP2 + enddo LOOP2 ! accepted +C Check for time limit. + not_done = (it.lt.max_mcm_it) .and. (nacc_tot.lt.maxacc) + if(.not.not_done .or. finish) then + if(imtasks_n.gt.0) then + not_done=.true. + else + not_done=.false. + endif + finish=.true. + endif + enddo LOOP1 ! not_done + runtime=tcpu() + if (print_mc.gt.0) then + write (iout,'(/80(1h*)/20x,a)') 'Summary run statistics:' + call statprint(nacc,nfun,iretcode,etot,elowest) + write (iout,'(a)') + & 'Statistics of multiple-bond motions. Total motions:' + write (iout,'(16i5)') (nbond_move(i),i=1,Nbm) + write (iout,'(a)') 'Accepted motions:' + write (iout,'(16i5)') (nbond_acc(i),i=1,Nbm) + if (it.ge.maxacc) + &write (iout,'(/80(1h*)/20x,a/80(1h*)/)') 'All iterations done.' + endif +#ifdef AIX + call flush_(iout) +#else + call flush(iout) +#endif + do is=1,nodenum-1 + call MPI_SEND(999, 1, MPI_INTEGER, is, tag, + & CG_COMM, ierr) + enddo + return + end +c------------------------------------------------------------------------------ + subroutine execute_slave(nodeinfo,iprint) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'mpif.h' + include 'COMMON.TIME1' + include 'COMMON.IOUNITS' +crc include 'COMMON.DEFORM' +crc include 'COMMON.DEFORM1' +crc include 'COMMON.DEFORM2' + include 'COMMON.LOCAL' + include 'COMMON.VAR' + include 'COMMON.INFO' + include 'COMMON.MINIM' + character*10 nodeinfo + double precision x(maxvar),x1(maxvar) + nodeinfo='chujwdupe' +c print *,'Processor:',MyID,' Entering execute_slave' + tag=0 +c call MPI_SEND(nodeinfo, 10, MPI_CHARACTER, 0, tag, +c & CG_COMM, ierr) + +1001 call MPI_RECV(i_switch, 1, MPI_INTEGER, 0, tag, + & CG_COMM, status, ierr) +c write(iout,*)'12: tag=',tag + if(iprint.ge.2)print *, MyID,' recv order ',i_switch + if (i_switch.eq.12) then + i_grnum_d=0 + i_ennum_d=0 + i_hesnum_d=0 + call MPI_RECV(iitt, 1, MPI_INTEGER, 0, tag, + & CG_COMM, status, ierr) +c write(iout,*)'12: tag=',tag + call MPI_RECV(ener, 1, MPI_DOUBLE_PRECISION, 0, tag, + & CG_COMM, status, ierr) +c write(iout,*)'ener: tag=',tag + call MPI_RECV(x(1), nvar, MPI_DOUBLE_PRECISION, 0, tag, + & CG_COMM, status, ierr) +c write(iout,*)'x: tag=',tag + call MPI_RECV(x1(1), nvar, MPI_DOUBLE_PRECISION, 0, tag, + & CG_COMM, status, ierr) +c write(iout,*)'x1: tag=',tag +#ifdef AIX + call flush_(iout) +#else + call flush(iout) +#endif +c print *,'calling minimize' + call minimize(energyx,x,iretcode,nfun) + if(iprint.gt.0) + & write(iout,100)'minimized energy = ',energyx, + & ' # funeval:',nfun,' iret ',iretcode + write(*,100)'minimized energy = ',energyx, + & ' # funeval:',nfun,' iret ',iretcode + 100 format(a20,f10.5,a12,i5,a6,i2) + if(iretcode.eq.10) then + do iminrep=2,3 + if(iprint.gt.1) + & write(iout,*)' ... not converged - trying again ',iminrep + call minimize(energyx,x,iretcode,nfun) + if(iprint.gt.1) + & write(iout,*)'minimized energy = ',energyx, + & ' # funeval:',nfun,' iret ',iretcode + if(iretcode.ne.10)go to 812 + enddo + if(iretcode.eq.10) then + if(iprint.gt.1) + & write(iout,*)' ... not converged again - giving up' + go to 812 + endif + endif +812 continue +c print *,'Sending results' + call MPI_SEND(iitt, 1, MPI_INTEGER, 0, tag, + & CG_COMM, ierr) + call MPI_SEND(ener, 1, MPI_DOUBLE_PRECISION, 0, tag, + & CG_COMM, ierr) + call MPI_SEND(energyx, 1, MPI_DOUBLE_PRECISION, 0, tag, + & CG_COMM, ierr) + call MPI_SEND(x(1), nvar, MPI_DOUBLE_PRECISION, 0, tag, + & CG_COMM, ierr) + call MPI_SEND(x1(1), nvar, MPI_DOUBLE_PRECISION, 0, tag, + & CG_COMM, ierr) + call MPI_SEND(i_grnum_d, 1, MPI_INTEGER, 0, tag, + & CG_COMM, ierr) + call MPI_SEND(nfun, 1, MPI_INTEGER, 0, tag, + & CG_COMM, ierr) + call MPI_SEND(i_hesnum_d, 1, MPI_INTEGER, 0, tag, + & CG_COMM, ierr) +c print *,'End sending' + go to 1001 + endif + + return + end +#endif +c------------------------------------------------------------------------------ + subroutine statprint(it,nfun,iretcode,etot,elowest) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CONTROL' + include 'COMMON.MCM' + if (minim) then + write (iout, + & '(80(1h*)/a,i5,a,1pe14.5,a,1pe14.5/a,i3,a,i10,a,i5,a,i5)') + & 'Finished iteration #',it,' energy is',etot, + & ' lowest energy:',elowest, + & 'SUMSL return code:',iretcode, + & ' # of energy evaluations:',neneval, + & '# of temperature jumps:',ntherm, + & ' # of minima repetitions:',nrepm + else + write (iout,'(80(1h*)/a,i8,a,1pe14.5,a,1pe14.5)') + & 'Finished iteration #',it,' energy is',etot, + & ' lowest energy:',elowest + endif + write (iout,'(/4a)') + & 'Kind of move ',' total',' accepted', + & ' fraction' + write (iout,'(58(1h-))') + do i=-1,MaxMoveType + if (moves(i).eq.0) then + fr_mov_i=0.0d0 + else + fr_mov_i=dfloat(moves_acc(i))/dfloat(moves(i)) + endif + write(iout,'(a,2i15,f10.5)')MovTypID(i),moves(i),moves_acc(i), + & fr_mov_i + enddo + write (iout,'(a,2i15,f10.5)') 'total ',nmove,nacc_tot, + & dfloat(nacc_tot)/dfloat(nmove) + write (iout,'(58(1h-))') + write (iout,'(a,1pe12.4)') 'Elapsed time:',tcpu() + return + end +c------------------------------------------------------------------------------ + subroutine heat(over) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.MCM' + include 'COMMON.IOUNITS' + logical over +C Check if there`s a need to increase temperature. + if (ntrial.gt.maxtrial) then + if (NstepH.gt.0) then + if (dabs(Tcur-TMax).lt.1.0D-7) then + if (print_mc.gt.0) + & write (iout,'(/80(1h*)/a,f8.3,a/80(1h*))') + & 'Upper limit of temperature reached. Terminating.' + over=.true. + Tcur=Tmin + else + Tcur=Tcur*TstepH + if (Tcur.gt.Tmax) Tcur=Tmax + betbol=1.0D0/(Rbol*Tcur) + if (print_mc.gt.0) + & write (iout,'(/80(1h*)/a,f8.3,a,f10.5/80(1h*))') + & 'System heated up to ',Tcur,' K; BetBol:',betbol + ntherm=ntherm+1 + ntrial=0 + over=.false. + endif + else + if (print_mc.gt.0) + & write (iout,'(a)') + & 'Maximum number of trials in a single MCM iteration exceeded.' + over=.true. + Tcur=Tmin + endif + else + over=.false. + endif + return + end +c------------------------------------------------------------------------------ + subroutine cool + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.MCM' + include 'COMMON.IOUNITS' + if (nstepC.gt.0 .and. dabs(Tcur-Tmin).gt.1.0D-7) then + Tcur=Tcur/TstepC + if (Tcur.lt.Tmin) Tcur=Tmin + betbol=1.0D0/(Rbol*Tcur) + if (print_mc.gt.0) + & write (iout,'(/80(1h*)/a,f8.3,a,f10.5/80(1h*))') + & 'System cooled down up to ',Tcur,' K; BetBol:',betbol + endif + return + end +C--------------------------------------------------------------------------- + subroutine zapis(varia,etot) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MP + include 'mpif.h' + include 'COMMON.INFO' +#endif + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.MCM' + include 'COMMON.IOUNITS' + integer itemp(maxsave) + double precision varia(maxvar) + logical lprint + lprint=.false. + if (lprint) then + write (iout,'(a,i5,a,i5)') 'Enter ZAPIS NSave=',Nsave, + & ' MaxSave=',MaxSave + write (iout,'(a)') 'Current energy and conformation:' + write (iout,'(1pe14.5)') etot + write (iout,'(10f8.3)') (rad2deg*varia(i),i=1,nvar) + endif +C Shift the contents of the esave and varsave arrays if filled up. + call add2cache(maxvar,maxsave,nsave,nvar,MyID,itemp, + & etot,varia,esave,varsave) + if (lprint) then + write (iout,'(a)') 'Energies and the VarSave array.' + do i=1,nsave + write (iout,'(i5,1pe14.5)') i,esave(i) + write (iout,'(10f8.3)') (rad2deg*varsave(j,i),j=1,nvar) + enddo + endif + return + end +C--------------------------------------------------------------------------- + subroutine perturb(error,lprint,MoveType,nbond,max_phi) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + parameter (MMaxSideMove=100) + include 'COMMON.MCM' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' +crc include 'COMMON.DEFORM1' + logical error,lprint,fail + integer MoveType,nbond,end_select,ind_side(MMaxSideMove) + double precision max_phi + double precision psi,gen_psi + external iran_num + integer iran_num + integer ifour + data ifour /4/ + error=.false. + lprint=.false. +C Perturb the conformation according to a randomly selected move. + call SelectMove(MoveType) +c write (iout,*) 'MoveType=',MoveType + itrial=0 + goto (100,200,300,400,500) MoveType +C------------------------------------------------------------------------------ +C Backbone N-bond move. +C Select the number of bonds (length of the segment to perturb). + 100 continue + if (itrial.gt.1000) then + write (iout,'(a)') 'Too many attempts at multiple-bond move.' + error=.true. + return + endif + bond_prob=ran_number(0.0D0,sumpro_bond(nbm)) +c print *,'sumpro_bond(nbm)=',sumpro_bond(nbm), +c & ' Bond_prob=',Bond_Prob + do i=1,nbm-1 +c print *,i,Bond_Prob,sumpro_bond(i),sumpro_bond(i+1) + if (bond_prob.ge.sumpro_bond(i) .and. + & bond_prob.le.sumpro_bond(i+1)) then + nbond=i+1 + goto 10 + endif + enddo + write (iout,'(2a)') 'In PERTURB: Error - number of bonds', + & ' to move out of range.' + error=.true. + return + 10 continue + if (nwindow.gt.0) then +C Select the first residue to perturb + iwindow=iran_num(1,nwindow) + print *,'iwindow=',iwindow + iiwin=1 + do while (winlen(iwindow).lt.nbond) + iwindow=iran_num(1,nwindow) + iiwin=iiwin+1 + if (iiwin.gt.1000) then + write (iout,'(a)') 'Cannot select moveable residues.' + error=.true. + return + endif + enddo + nstart=iran_num(winstart(iwindow),winend(iwindow)) + else + nstart = iran_num(koniecl+2,nres-nbond-koniecl) +cd print *,'nres=',nres,' nbond=',nbond,' koniecl=',koniecl, +cd & ' nstart=',nstart + endif + psi = gen_psi() + if (psi.eq.0.0) then + error=.true. + return + endif + if (print_mc.gt.1) write (iout,'(a,i4,a,i4,a,f8.3)') + & 'PERTURB: nbond=',nbond,' nstart=',nstart,' psi=',psi*rad2deg +cd print *,'nstart=',nstart + call bond_move(nbond,nstart,psi,.false.,error) + if (error) then + write (iout,'(2a)') + & 'Could not define reference system in bond_move, ', + & 'choosing ahother segment.' + itrial=itrial+1 + goto 100 + endif + nbond_move(nbond)=nbond_move(nbond)+1 + moves(1)=moves(1)+1 + nmove=nmove+1 + return +C------------------------------------------------------------------------------ +C Backbone endmove. Perturb a SINGLE angle of a residue close to the end of +C the chain. + 200 continue + lprint=.true. +c end_select=iran_num(1,2*koniecl) +c if (end_select.gt.koniecl) then +c end_select=nphi-(end_select-koniecl) +c else +c end_select=koniecl+3 +c endif +c if (nwindow.gt.0) then +c iwin=iran_num(1,nwindow) +c i1=max0(4,winstart(iwin)) +c i2=min0(winend(imin)+2,nres) +c end_select=iran_num(i1,i2) +c else +c iselect = iran_num(1,nmov_var) +c jj = 0 +c do i=1,nphi +c if (isearch_tab(i).eq.1) jj = jj+1 +c if (jj.eq.iselect) then +c end_select=i+3 +c exit +c endif +c enddo +c endif + end_select = iran_num(4,nres) + psi=max_phi*gen_psi() + if (psi.eq.0.0D0) then + error=.true. + return + endif + phi(end_select)=pinorm(phi(end_select)+psi) + if (print_mc.gt.1) write (iout,'(a,i4,a,f8.3,a,f8.3)') + & 'End angle',end_select,' moved by ',psi*rad2deg,' new angle:', + & phi(end_select)*rad2deg +c if (end_select.gt.3) +c & theta(end_select-1)=gen_theta(itype(end_select-2), +c & phi(end_select-1),phi(end_select)) +c if (end_select.lt.nres) +c & theta(end_select)=gen_theta(itype(end_select-1), +c & phi(end_select),phi(end_select+1)) +cd print *,'nres=',nres,' end_select=',end_select +cd print *,'theta',end_select-1,theta(end_select-1) +cd print *,'theta',end_select,theta(end_select) + moves(2)=moves(2)+1 + nmove=nmove+1 + lprint=.false. + return +C------------------------------------------------------------------------------ +C Side chain move. +C Select the number of SCs to perturb. + 300 isctry=0 + 301 nside_move=iran_num(1,MaxSideMove) +c print *,'nside_move=',nside_move,' MaxSideMove',MaxSideMove +C Select the indices. + do i=1,nside_move + icount=0 + 111 inds=iran_num(nnt,nct) + icount=icount+1 + if (icount.gt.1000) then + write (iout,'(a)')'Error - cannot select side chains to move.' + error=.true. + return + endif + if (itype(inds).eq.10) goto 111 + do j=1,i-1 + if (inds.eq.ind_side(j)) goto 111 + enddo + do j=1,i-1 + if (inds.lt.ind_side(j)) then + indx=j + goto 112 + endif + enddo + indx=i + 112 do j=i,indx+1,-1 + ind_side(j)=ind_side(j-1) + enddo + 113 ind_side(indx)=inds + enddo +C Carry out perturbation. + do i=1,nside_move + ii=ind_side(i) + iti=itype(ii) + call gen_side(iti,theta(ii+1),alph(ii),omeg(ii),fail) + if (fail) then + isctry=isctry+1 + if (isctry.gt.1000) then + write (iout,'(a)') 'Too many errors in SC generation.' + error=.true. + return + endif + goto 301 + endif + if (print_mc.gt.1) write (iout,'(2a,i4,a,2f8.3)') + & 'Side chain ',restyp(iti),ii,' moved to ', + & alph(ii)*rad2deg,omeg(ii)*rad2deg + enddo + moves(3)=moves(3)+1 + nmove=nmove+1 + return +C------------------------------------------------------------------------------ +C THETA move + 400 end_select=iran_num(3,nres) + theta_new=gen_theta(itype(end_select),phi(end_select), + & phi(end_select+1)) + if (print_mc.gt.1) write (iout,'(a,i3,a,f8.3,a,f8.3)') + & 'Theta ',end_select,' moved from',theta(end_select)*rad2deg, + & ' to ',theta_new*rad2deg + theta(end_select)=theta_new + moves(4)=moves(4)+1 + nmove=nmove+1 + return +C------------------------------------------------------------------------------ +C Error returned from SelectMove. + 500 error=.true. + return + end +C------------------------------------------------------------------------------ + subroutine SelectMove(MoveType) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.MCM' + include 'COMMON.IOUNITS' + what_move=ran_number(0.0D0,sumpro_type(MaxMoveType)) + do i=1,MaxMoveType + if (what_move.ge.sumpro_type(i-1).and. + & what_move.lt.sumpro_type(i)) then + MoveType=i + return + endif + enddo + write (iout,'(a)') + & 'Fatal error in SelectMoveType: cannot select move.' + MoveType=MaxMoveType+1 + return + end +c---------------------------------------------------------------------------- + double precision function gen_psi() + implicit none + integer i + double precision x,ran_number + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + x=0.0D0 + do i=1,100 + x=ran_number(-pi,pi) + if (dabs(x).gt.angmin) then + gen_psi=x + return + endif + enddo + write (iout,'(a)')'From Gen_Psi: Cannot generate angle increment.' + gen_psi=0.0D0 + return + end +c---------------------------------------------------------------------------- + subroutine metropolis(n,xcur,xold,ecur,eold,accepted,similar, + & enelower) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.MCM' + include 'COMMON.IOUNITS' + include 'COMMON.VAR' + include 'COMMON.GEO' +crc include 'COMMON.DEFORM' + double precision ecur,eold,xx,ran_number,bol + double precision xcur(n),xold(n) + double precision ecut1 ,ecut2 ,tola + logical accepted,similar,not_done,enelower + logical lprn + data ecut1 /-1.0D-5/,ecut2 /5.0D-3/,tola/5.0D0/ +! ecut1=-5*enedif +! ecut2=50*enedif +! tola=5.0d0 +C Set lprn=.true. for debugging. + lprn=.false. + if (lprn) + &write(iout,*)'enedif',enedif,' ecut1',ecut1,' ecut2',ecut2 + similar=.false. + enelower=.false. + accepted=.false. +C Check if the conformation is similar. + difene=ecur-eold + reldife=difene/dmax1(dabs(eold),dabs(ecur),1.0D0) + if (lprn) then + write (iout,*) 'Metropolis' + write(iout,*)'ecur,eold,difene,reldife',ecur,eold,difene,reldife + endif +C If energy went down remarkably, we accept the new conformation +C unconditionally. +cjp if (reldife.lt.ecut1) then + if (difene.lt.ecut1) then + accepted=.true. + EneLower=.true. + if (lprn) write (iout,'(a)') + & 'Conformation accepted, because energy has lowered remarkably.' +! elseif (reldife.lt.ecut2 .and. dif_ang(nphi,xcur,xold).lt.tola) +cjp elseif (reldife.lt.ecut2) + elseif (difene.lt.ecut2) + & then +C Reject the conf. if energy has changed insignificantly and there is not +C much change in conformation. + if (lprn) + & write (iout,'(2a)') 'Conformation rejected, because it is', + & ' similar to the preceding one.' + accepted=.false. + similar=.true. + else +C Else carry out Metropolis test. + EneLower=.false. + xx=ran_number(0.0D0,1.0D0) + xxh=betbol*difene + if (lprn) + & write (iout,*) 'betbol=',betbol,' difene=',difene,' xxh=',xxh + if (xxh.gt.50.0D0) then + bol=0.0D0 + else + bol=exp(-xxh) + endif + if (lprn) write (iout,*) 'bol=',bol,' xx=',xx + if (bol.gt.xx) then + accepted=.true. + if (lprn) write (iout,'(a)') + & 'Conformation accepted, because it passed Metropolis test.' + else + accepted=.false. + if (lprn) write (iout,'(a)') + & 'Conformation rejected, because it did not pass Metropolis test.' + endif + endif +#ifdef AIX + call flush_(iout) +#else + call flush(iout) +#endif + return + end +c------------------------------------------------------------------------------ + integer function conf_comp(x,ene) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.MCM' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + double precision etol , angtol + double precision x(maxvar) + double precision dif_ang,difa + data etol /0.1D0/, angtol /20.0D0/ + do ii=nsave,1,-1 +c write (iout,*) 'ii=',ii,'ene=',ene,esave(ii),dabs(ene-esave(ii)) + if (dabs(ene-esave(ii)).lt.etol) then + difa=dif_ang(nphi,x,varsave(1,ii)) +c do i=1,nphi +c write(iout,'(i3,3f8.3)')i,rad2deg*x(i), +c & rad2deg*varsave(i,ii) +c enddo +c write(iout,*) 'ii=',ii,' difa=',difa,' angtol=',angtol + if (difa.le.angtol) then + if (print_mc.gt.0) then + write (iout,'(a,i5,2(a,1pe15.4))') + & 'Current conformation matches #',ii, + & ' in the store array ene=',ene,' esave=',esave(ii) +c write (*,'(a,i5,a)') 'Current conformation matches #',ii, +c & ' in the store array.' + endif ! print_mc.gt.0 + if (print_mc.gt.1) then + do i=1,nphi + write(iout,'(i3,3f8.3)')i,rad2deg*x(i), + & rad2deg*varsave(i,ii) + enddo + endif ! print_mc.gt.1 + nrepm=nrepm+1 + conf_comp=ii + return + endif + endif + enddo + conf_comp=0 + return + end +C---------------------------------------------------------------------------- + double precision function dif_ang(n,x,y) + implicit none + integer i,n + double precision x(n),y(n) + double precision w,wa,dif,difa + double precision pinorm + include 'COMMON.GEO' + wa=0.0D0 + difa=0.0D0 + do i=1,n + dif=dabs(pinorm(y(i)-x(i))) + if (dabs(dif-dwapi).lt.dif) dif=dabs(dif-dwapi) + w=1.0D0-(2.0D0*(i-1)/(n-1)-1.0D0)**2+1.0D0/n + wa=wa+w + difa=difa+dif*dif*w + enddo + dif_ang=rad2deg*dsqrt(difa/wa) + return + end +c-------------------------------------------------------------------------- + subroutine add2cache(n1,n2,ncache,nvar,SourceID,CachSrc, + & ecur,xcur,ecache,xcache) + implicit none + include 'COMMON.GEO' + include 'COMMON.IOUNITS' + integer n1,n2,ncache,nvar,SourceID,CachSrc(n2) + integer i,ii,j + double precision ecur,xcur(nvar),ecache(n2),xcache(n1,n2) +cd write (iout,*) 'Enter ADD2CACHE ncache=',ncache ,' ecur',ecur +cd write (iout,'(10f8.3)') (rad2deg*xcur(i),i=1,nvar) +cd write (iout,*) 'Old CACHE array:' +cd do i=1,ncache +cd write (iout,*) 'i=',i,' ecache=',ecache(i),' CachSrc',CachSrc(i) +cd write (iout,'(10f8.3)') (rad2deg*xcache(j,i),j=1,nvar) +cd enddo + + i=ncache + do while (i.gt.0 .and. ecur.lt.ecache(i)) + i=i-1 + enddo + i=i+1 +cd write (iout,*) 'i=',i,' ncache=',ncache + if (ncache.eq.n2) then + write (iout,*) 'Cache dimension exceeded',ncache,n2 + write (iout,*) 'Highest-energy conformation will be removed.' + ncache=ncache-1 + endif + do ii=ncache,i,-1 + ecache(ii+1)=ecache(ii) + CachSrc(ii+1)=CachSrc(ii) + do j=1,nvar + xcache(j,ii+1)=xcache(j,ii) + enddo + enddo + ecache(i)=ecur + CachSrc(i)=SourceID + do j=1,nvar + xcache(j,i)=xcur(j) + enddo + ncache=ncache+1 +cd write (iout,*) 'New CACHE array:' +cd do i=1,ncache +cd write (iout,*) 'i=',i,' ecache=',ecache(i),' CachSrc',CachSrc(i) +cd write (iout,'(10f8.3)') (rad2deg*xcache(j,i),j=1,nvar) +cd enddo + return + end +c-------------------------------------------------------------------------- + subroutine rm_from_cache(i,n1,n2,ncache,nvar,CachSrc,ecache, + & xcache) + implicit none + include 'COMMON.GEO' + include 'COMMON.IOUNITS' + integer n1,n2,ncache,nvar,CachSrc(n2) + integer i,ii,j + double precision ecache(n2),xcache(n1,n2) + +cd write (iout,*) 'Enter RM_FROM_CACHE' +cd write (iout,*) 'Old CACHE array:' +cd do ii=1,ncache +cd write (iout,*)'i=',ii,' ecache=',ecache(ii),' CachSrc',CachSrc(ii) +cd write (iout,'(10f8.3)') (rad2deg*xcache(j,ii),j=1,nvar) +cd enddo + + do ii=i+1,ncache + ecache(ii-1)=ecache(ii) + CachSrc(ii-1)=CachSrc(ii) + do j=1,nvar + xcache(j,ii-1)=xcache(j,ii) + enddo + enddo + ncache=ncache-1 +cd write (iout,*) 'New CACHE array:' +cd do i=1,ncache +cd write (iout,*) 'i=',i,' ecache=',ecache(i),' CachSrc',CachSrc(i) +cd write (iout,'(10f8.3)') (rad2deg*xcache(j,i),j=1,nvar) +cd enddo + return + end diff --git a/source/unres/src_MD-DFA-restraints/minim_mcmf.F b/source/unres/src_MD-DFA-restraints/minim_mcmf.F new file mode 100644 index 0000000..beb3d4c --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/minim_mcmf.F @@ -0,0 +1,121 @@ +#ifdef MPI + subroutine minim_mcmf + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2)) + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.MINIM' + include 'mpif.h' + external func,gradient,fdum + real ran1,ran2,ran3 + include 'COMMON.SETUP' + include 'COMMON.GEO' + include 'COMMON.CHAIN' + include 'COMMON.FFIELD' + dimension muster(mpi_status_size) + dimension var(maxvar),erg(mxch*(mxch+1)/2+1) + double precision d(maxvar),v(1:lv+1),garbage(maxvar) + dimension indx(6) + dimension iv(liv) + dimension idum(1),rdum(1) + double precision przes(3),obrot(3,3) + logical non_conv + data rad /1.745329252d-2/ + common /przechowalnia/ v + + ichuj=0 + 10 continue + ichuj = ichuj + 1 + call mpi_recv(indx,6,mpi_integer,king,idint,CG_COMM, + * muster,ierr) + if (indx(1).eq.0) return +c print *, 'worker ',me,' received order ',n,ichuj + call mpi_recv(var,nvar,mpi_double_precision, + * king,idreal,CG_COMM,muster,ierr) + call mpi_recv(ene0,1,mpi_double_precision, + * king,idreal,CG_COMM,muster,ierr) +c print *, 'worker ',me,' var read ' + + + call deflt(2,iv,liv,lv,v) +* 12 means fresh start, dont call deflt + iv(1)=12 +* max num of fun calls + if (maxfun.eq.0) maxfun=500 + iv(17)=maxfun +* max num of iterations + if (maxmin.eq.0) maxmin=1000 + iv(18)=maxmin +* controls output + iv(19)=2 +* selects output unit +c iv(21)=iout + iv(21)=0 +* 1 means to print out result + iv(22)=0 +* 1 means to print out summary stats + iv(23)=0 +* 1 means to print initial x and d + iv(24)=0 +* min val for v(radfac) default is 0.1 + v(24)=0.1D0 +* max val for v(radfac) default is 4.0 + v(25)=2.0D0 +* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) +* the sumsl default is 0.1 + v(26)=0.1D0 +* false conv if (act fnctn decrease) .lt. v(34) +* the sumsl default is 100*machep + v(34)=v(34)/100.0D0 +* absolute convergence + if (tolf.eq.0.0D0) tolf=1.0D-4 + v(31)=tolf +* relative convergence + if (rtolf.eq.0.0D0) rtolf=1.0D-4 + v(32)=rtolf +* controls initial step size + v(35)=1.0D-1 +* large vals of d correspond to small components of step + do i=1,nphi + d(i)=1.0D-1 + enddo + do i=nphi+1,nvar + d(i)=1.0D-1 + enddo +c minimize energy + + call func(nvar,var,nf,eee,idum,rdum,fdum) + if(eee.gt.1.0d18) then +c print *,'MINIM_JLEE: ',me,' CHUJ NASTAPIL' +c print *,' energy before SUMSL =',eee +c print *,' aborting local minimization' + iv(1)=-1 + v(10)=eee + nf=1 + go to 201 + endif + + call sumsl(nvar,d,var,func,gradient,iv,liv,lv,v,idum,rdum,fdum) +c find which conformation was returned from sumsl + nf=iv(7)+1 + 201 continue +c total # of ftn evaluations (for iwf=0, it includes all minimizations). + indx(4)=nf + indx(5)=iv(1) + eee=v(10) + + call mpi_send(indx,6,mpi_integer,king,idint,CG_COMM, + * ierr) +c print '(a5,i3,15f10.5)', 'ENEX0',indx(1),v(10) + call mpi_send(var,nvar,mpi_double_precision, + * king,idreal,CG_COMM,ierr) + call mpi_send(eee,1,mpi_double_precision,king,idreal, + * CG_COMM,ierr) + call mpi_send(ene0,1,mpi_double_precision,king,idreal, + * CG_COMM,ierr) + go to 10 + + return + end +#endif diff --git a/source/unres/src_MD-DFA-restraints/minimize_p.F b/source/unres/src_MD-DFA-restraints/minimize_p.F new file mode 100644 index 0000000..c7922c7 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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 + call etotal_short(edum) +c write (2,*) "After etotal_short" +c write (2,*) "dimen",dimen," dimen3",dimen3 +c call flush(2) + else if (iorder.eq.3) then + call zerograd + call etotal_long(edum) +c write (2,*) "After etotal_long" +c write (2,*) "dimen",dimen," dimen3",dimen3 +c call flush(2) + else if (iorder.eq.1) then + call sum_gradient +c write (2,*) "After sum_gradient" +c write (2,*) "dimen",dimen," dimen3",dimen3 +c call flush(2) + else if (iorder.eq.4) then + call ginv_mult(z,d_a_tmp) + else if (iorder.eq.5) then +c Setup MD things for a slave + dimen=(nct-nnt+1)+nside + dimen1=(nct-nnt)+(nct-nnt+1) + dimen3=dimen*3 +c write (2,*) "dimen",dimen," dimen3",dimen3 +c call flush(2) + call int_bounds(dimen,igmult_start,igmult_end) + igmult_start=igmult_start-1 + call MPI_Allgather(3*igmult_start,1,MPI_INTEGER, + & ng_start(0),1,MPI_INTEGER,FG_COMM,IERROR) + my_ng_count=igmult_end-igmult_start + call MPI_Allgather(3*my_ng_count,1,MPI_INTEGER,ng_counts(0),1, + & MPI_INTEGER,FG_COMM,IERROR) +c write (2,*) "ng_start",(ng_start(i),i=0,nfgtasks-1) +c write (2,*) "ng_counts",(ng_counts(i),i=0,nfgtasks-1) + myginv_ng_count=maxres2*my_ng_count +c write (2,*) "igmult_start",igmult_start," igmult_end", +c & igmult_end," my_ng_count",my_ng_count +c call flush(2) + call MPI_Allgather(maxres2*igmult_start,1,MPI_INTEGER, + & nginv_start(0),1,MPI_INTEGER,FG_COMM,IERROR) + call MPI_Allgather(myginv_ng_count,1,MPI_INTEGER, + & nginv_counts(0),1,MPI_INTEGER,FG_COMM,IERROR) +c write (2,*) "nginv_start",(nginv_start(i),i=0,nfgtasks-1) +c write (2,*) "nginv_counts",(nginv_counts(i),i=0,nfgtasks-1) +c call flush(2) +c call MPI_Barrier(FG_COMM,IERROR) + time00=MPI_Wtime() + call MPI_Scatterv(ginv(1,1),nginv_counts(0), + & nginv_start(0),MPI_DOUBLE_PRECISION,gcopy(1,1), + & myginv_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERR) +#ifdef TIMING + time_scatter_ginv=time_scatter_ginv+MPI_Wtime()-time00 +#endif + do i=1,dimen + do j=1,2*my_ng_count + ginv(j,i)=gcopy(i,j) + enddo + enddo +c write (2,*) "dimen",dimen," dimen3",dimen3 +c write (2,*) "End MD setup" +c call flush(2) +c write (iout,*) "My chunk of ginv_block" +c call MATOUT2(my_ng_count,dimen3,maxres2,maxers2,ginv_block) + else if (iorder.eq.6) then + call int_from_cart1(.false.) + else if (iorder.eq.7) then + call chainbuild_cart + else if (iorder.eq.8) then + call intcartderiv + else if (iorder.eq.9) then + call fricmat_mult(z,d_a_tmp) + else if (iorder.eq.10) then + call setup_fricmat + endif + enddo + write (*,*) 'Processor',fg_rank,' CG group',kolor, + & ' absolute rank',myrank,' leves ERGASTULUM.' + write(*,*)'Processor',fg_rank,' wait times for respective orders', + & (' order[',i,']',time_order(i),i=0,10) + return + end +#endif +************************************************************************ + subroutine func(n,x,nf,f,uiparm,urparm,ufparm) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.DERIV' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + common /chuju/ jjj + double precision energia(0:n_ene) + integer jjj + double precision ufparm + external ufparm + integer uiparm(1) + real*8 urparm(1) + dimension x(maxvar) +c if (jjj.gt.0) then +c write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n) +c endif + nfl=nf + icg=mod(nf,2)+1 +cd print *,'func',nf,nfl,icg + call var_to_geom(n,x) + call zerograd + call chainbuild +cd write (iout,*) 'ETOTAL called from FUNC' + call etotal(energia(0)) + call sum_gradient + f=energia(0) +c if (jjj.gt.0) then +c write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n) +c write (iout,*) 'f=',etot +c jjj=0 +c endif + return + end +************************************************************************ + subroutine func_restr(n,x,nf,f,uiparm,urparm,ufparm) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.DERIV' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + common /chuju/ jjj + double precision energia(0:n_ene) + integer jjj + double precision ufparm + external ufparm + integer uiparm(1) + real*8 urparm(1) + dimension x(maxvar) +c if (jjj.gt.0) then +c write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n) +c endif + nfl=nf + icg=mod(nf,2)+1 + call var_to_geom_restr(n,x) + call zerograd + call chainbuild +cd write (iout,*) 'ETOTAL called from FUNC' + call etotal(energia(0)) + call sum_gradient + f=energia(0) +c if (jjj.gt.0) then +c write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n) +c write (iout,*) 'f=',etot +c jjj=0 +c endif + return + end +c------------------------------------------------------- + subroutine x2xx(x,xx,n) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + double precision xx(maxvar),x(maxvar) + + do i=1,nvar + varall(i)=x(i) + enddo + + ig=0 + igall=0 + do i=4,nres + igall=igall+1 + if (mask_phi(i).eq.1) then + ig=ig+1 + xx(ig)=x(igall) + endif + enddo + + do i=3,nres + igall=igall+1 + if (mask_theta(i).eq.1) then + ig=ig+1 + xx(ig)=x(igall) + endif + enddo + + do ij=1,2 + do i=2,nres-1 + if (itype(i).ne.10) then + igall=igall+1 + if (mask_side(i).eq.1) then + ig=ig+1 + xx(ig)=x(igall) + endif + endif + enddo + enddo + + n=ig + + return + end + + subroutine xx2x(x,xx) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + double precision xx(maxvar),x(maxvar) + + do i=1,nvar + x(i)=varall(i) + enddo + + ig=0 + igall=0 + do i=4,nres + igall=igall+1 + if (mask_phi(i).eq.1) then + ig=ig+1 + x(igall)=xx(ig) + endif + enddo + + do i=3,nres + igall=igall+1 + if (mask_theta(i).eq.1) then + ig=ig+1 + x(igall)=xx(ig) + endif + enddo + + do ij=1,2 + do i=2,nres-1 + if (itype(i).ne.10) then + igall=igall+1 + if (mask_side(i).eq.1) then + ig=ig+1 + x(igall)=xx(ig) + endif + endif + enddo + enddo + + return + end + +c---------------------------------------------------------- + subroutine minim_dc(etot,iretcode,nfun) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2)) +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.SETUP' + include 'COMMON.IOUNITS' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.MINIM' + include 'COMMON.CHAIN' + dimension iv(liv) + double precision minval,x(maxvar),d(maxvar),v(1:lv),xx(maxvar) +c common /przechowalnia/ v + + double precision energia(0:n_ene) + external func_dc,grad_dc,fdum + logical not_done,change,reduce + double precision g(maxvar),f1 + + call deflt(2,iv,liv,lv,v) +* 12 means fresh start, dont call deflt + iv(1)=12 +* max num of fun calls + if (maxfun.eq.0) maxfun=500 + iv(17)=maxfun +* max num of iterations + if (maxmin.eq.0) maxmin=1000 + iv(18)=maxmin +* controls output + iv(19)=2 +* selects output unit + iv(21)=0 + if (print_min_ini+print_min_stat+print_min_res.gt.0) iv(21)=iout +* 1 means to print out result + iv(22)=print_min_res +* 1 means to print out summary stats + iv(23)=print_min_stat +* 1 means to print initial x and d + iv(24)=print_min_ini +* min val for v(radfac) default is 0.1 + v(24)=0.1D0 +* max val for v(radfac) default is 4.0 + v(25)=2.0D0 +c v(25)=4.0D0 +* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) +* the sumsl default is 0.1 + v(26)=0.1D0 +* false conv if (act fnctn decrease) .lt. v(34) +* the sumsl default is 100*machep + v(34)=v(34)/100.0D0 +* absolute convergence + if (tolf.eq.0.0D0) tolf=1.0D-4 + v(31)=tolf +* relative convergence + if (rtolf.eq.0.0D0) rtolf=1.0D-4 + v(32)=rtolf +* controls initial step size + v(35)=1.0D-1 +* large vals of d correspond to small components of step + do i=1,6*nres + d(i)=1.0D-1 + enddo + + k=0 + do i=1,nres-1 + do j=1,3 + k=k+1 + x(k)=dc(j,i) + enddo + enddo + do i=2,nres-1 + if (ialph(i,1).gt.0) then + do j=1,3 + k=k+1 + x(k)=dc(j,i+nres) + enddo + endif + enddo + + call sumsl(k,d,x,func_dc,grad_dc,iv,liv,lv,v,idum,rdum,fdum) + + k=0 + do i=1,nres-1 + do j=1,3 + k=k+1 + dc(j,i)=x(k) + enddo + enddo + do i=2,nres-1 + if (ialph(i,1).gt.0) then + do j=1,3 + k=k+1 + dc(j,i+nres)=x(k) + enddo + endif + enddo + call chainbuild_cart + +cd call zerograd +cd nf=0 +cd call func_dc(k,x,nf,f,idum,rdum,fdum) +cd call grad_dc(k,x,nf,g,idum,rdum,fdum) +cd +cd do i=1,k +cd x(i)=x(i)+1.0D-5 +cd call func_dc(k,x,nf,f1,idum,rdum,fdum) +cd x(i)=x(i)-1.0D-5 +cd print '(i5,2f15.5)',i,g(i),(f1-f)/1.0D-5 +cd enddo + + etot=v(10) + iretcode=iv(1) + nfun=iv(6) + return + end + + subroutine func_dc(n,x,nf,f,uiparm,urparm,ufparm) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.SETUP' + include 'COMMON.DERIV' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + double precision energia(0:n_ene) + double precision ufparm + external ufparm + integer uiparm(1) + real*8 urparm(1) + dimension x(maxvar) + nfl=nf +cbad icg=mod(nf,2)+1 + icg=1 + + k=0 + do i=1,nres-1 + do j=1,3 + k=k+1 + dc(j,i)=x(k) + enddo + enddo + do i=2,nres-1 + if (ialph(i,1).gt.0) then + do j=1,3 + k=k+1 + dc(j,i+nres)=x(k) + enddo + endif + enddo + call chainbuild_cart + + call zerograd + call etotal(energia(0)) + f=energia(0) + +cd print *,'func_dc ',nf,nfl,f + + return + end + + subroutine grad_dc(n,x,nf,g,uiparm,urparm,ufparm) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.SETUP' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.MD' + include 'COMMON.IOUNITS' + external ufparm + integer uiparm(1),k + double precision urparm(1) + dimension x(maxvar),g(maxvar) +c +c +c +cbad icg=mod(nf,2)+1 + icg=1 +cd print *,'grad_dc ',nf,nfl,nf-nfl+1,icg + if (nf-nfl+1) 20,30,40 + 20 call func_dc(n,x,nf,f,uiparm,urparm,ufparm) +cd print *,20 + if (nf.eq.0) return + goto 40 + 30 continue +cd print *,30 + k=0 + do i=1,nres-1 + do j=1,3 + k=k+1 + dc(j,i)=x(k) + enddo + enddo + do i=2,nres-1 + if (ialph(i,1).gt.0) then + do j=1,3 + k=k+1 + dc(j,i+nres)=x(k) + enddo + endif + enddo + call chainbuild_cart + +C +C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. +C + 40 call cartgrad +cd print *,40 + k=0 + do i=1,nres-1 + do j=1,3 + k=k+1 + g(k)=gcart(j,i) + enddo + enddo + do i=2,nres-1 + if (ialph(i,1).gt.0) then + do j=1,3 + k=k+1 + g(k)=gxcart(j,i) + enddo + endif + enddo + + return + end diff --git a/source/unres/src_MD-DFA-restraints/misc.f b/source/unres/src_MD-DFA-restraints/misc.f new file mode 100644 index 0000000..e189839 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/moments.f b/source/unres/src_MD-DFA-restraints/moments.f new file mode 100644 index 0000000..5adbf21 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/moments.f @@ -0,0 +1,328 @@ + subroutine inertia_tensor +c Calculating the intertia tensor for the entire protein in order to +c remove the perpendicular components of velocity matrix which cause +c the molecule to rotate. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + + double precision Im(3,3),Imcp(3,3),cm(3),pr(3),M_SC, + & eigvec(3,3),Id(3,3),eigval(3),L(3),vp(3),vrot(3), + & vpp(3,0:MAXRES),vs_p(3),pr1(3,3), + & pr2(3,3),pp(3),incr(3),v(3),mag,mag2 + common /gucio/ cm + integer iti,inres + do i=1,3 + do j=1,3 + Im(i,j)=0.0d0 + pr1(i,j)=0.0d0 + pr2(i,j)=0.0d0 + enddo + L(i)=0.0d0 + cm(i)=0.0d0 + vrot(i)=0.0d0 + enddo +c calculating the center of the mass of the protein + do i=nnt,nct-1 + do j=1,3 + cm(j)=cm(j)+c(j,i)+0.5d0*dc(j,i) + enddo + enddo + do j=1,3 + cm(j)=mp*cm(j) + enddo + M_SC=0.0d0 + do i=nnt,nct + iti=itype(i) + M_SC=M_SC+msc(iti) + inres=i+nres + do j=1,3 + cm(j)=cm(j)+msc(iti)*c(j,inres) + enddo + enddo + do j=1,3 + cm(j)=cm(j)/(M_SC+(nct-nnt)*mp) + enddo + + do i=nnt,nct-1 + do j=1,3 + pr(j)=c(j,i)+0.5d0*dc(j,i)-cm(j) + enddo + Im(1,1)=Im(1,1)+mp*(pr(2)*pr(2)+pr(3)*pr(3)) + Im(1,2)=Im(1,2)-mp*pr(1)*pr(2) + Im(1,3)=Im(1,3)-mp*pr(1)*pr(3) + Im(2,3)=Im(2,3)-mp*pr(2)*pr(3) + Im(2,2)=Im(2,2)+mp*(pr(3)*pr(3)+pr(1)*pr(1)) + Im(3,3)=Im(3,3)+mp*(pr(1)*pr(1)+pr(2)*pr(2)) + enddo + + do i=nnt,nct + iti=itype(i) + inres=i+nres + do j=1,3 + pr(j)=c(j,inres)-cm(j) + enddo + Im(1,1)=Im(1,1)+msc(iti)*(pr(2)*pr(2)+pr(3)*pr(3)) + Im(1,2)=Im(1,2)-msc(iti)*pr(1)*pr(2) + Im(1,3)=Im(1,3)-msc(iti)*pr(1)*pr(3) + Im(2,3)=Im(2,3)-msc(iti)*pr(2)*pr(3) + Im(2,2)=Im(2,2)+msc(iti)*(pr(3)*pr(3)+pr(1)*pr(1)) + Im(3,3)=Im(3,3)+msc(iti)*(pr(1)*pr(1)+pr(2)*pr(2)) + enddo + + do i=nnt,nct-1 + Im(1,1)=Im(1,1)+Ip*(1-dc_norm(1,i)*dc_norm(1,i))* + & vbld(i+1)*vbld(i+1)*0.25d0 + Im(1,2)=Im(1,2)+Ip*(-dc_norm(1,i)*dc_norm(2,i))* + & vbld(i+1)*vbld(i+1)*0.25d0 + Im(1,3)=Im(1,3)+Ip*(-dc_norm(1,i)*dc_norm(3,i))* + & vbld(i+1)*vbld(i+1)*0.25d0 + Im(2,3)=Im(2,3)+Ip*(-dc_norm(2,i)*dc_norm(3,i))* + & vbld(i+1)*vbld(i+1)*0.25d0 + Im(2,2)=Im(2,2)+Ip*(1-dc_norm(2,i)*dc_norm(2,i))* + & vbld(i+1)*vbld(i+1)*0.25d0 + Im(3,3)=Im(3,3)+Ip*(1-dc_norm(3,i)*dc_norm(3,i))* + & vbld(i+1)*vbld(i+1)*0.25d0 + enddo + + + do i=nnt,nct + if (itype(i).ne.10) then + iti=itype(i) + inres=i+nres + Im(1,1)=Im(1,1)+Isc(iti)*(1-dc_norm(1,inres)* + & dc_norm(1,inres))*vbld(inres)*vbld(inres) + Im(1,2)=Im(1,2)-Isc(iti)*(dc_norm(1,inres)* + & dc_norm(2,inres))*vbld(inres)*vbld(inres) + Im(1,3)=Im(1,3)-Isc(iti)*(dc_norm(1,inres)* + & dc_norm(3,inres))*vbld(inres)*vbld(inres) + Im(2,3)=Im(2,3)-Isc(iti)*(dc_norm(2,inres)* + & dc_norm(3,inres))*vbld(inres)*vbld(inres) + Im(2,2)=Im(2,2)+Isc(iti)*(1-dc_norm(2,inres)* + & dc_norm(2,inres))*vbld(inres)*vbld(inres) + Im(3,3)=Im(3,3)+Isc(iti)*(1-dc_norm(3,inres)* + & dc_norm(3,inres))*vbld(inres)*vbld(inres) + endif + enddo + + call angmom(cm,L) +c write(iout,*) "The angular momentum before adjustment:" +c write(iout,*) (L(j),j=1,3) + + Im(2,1)=Im(1,2) + Im(3,1)=Im(1,3) + Im(3,2)=Im(2,3) + +c Copying the Im matrix for the djacob subroutine + do i=1,3 + do j=1,3 + Imcp(i,j)=Im(i,j) + Id(i,j)=0.0d0 + enddo + enddo + +c Finding the eigenvectors and eignvalues of the inertia tensor + call djacob(3,3,10000,1.0d-10,Imcp,eigvec,eigval) +c write (iout,*) "Eigenvalues & Eigenvectors" +c write (iout,'(5x,3f10.5)') (eigval(i),i=1,3) +c write (iout,*) +c do i=1,3 +c write (iout,'(i5,3f10.5)') i,(eigvec(i,j),j=1,3) +c enddo +c Constructing the diagonalized matrix + do i=1,3 + if (dabs(eigval(i)).gt.1.0d-15) then + Id(i,i)=1.0d0/eigval(i) + else + Id(i,i)=0.0d0 + endif + enddo + do i=1,3 + do j=1,3 + Imcp(i,j)=eigvec(j,i) + enddo + enddo + do i=1,3 + do j=1,3 + do k=1,3 + pr1(i,j)=pr1(i,j)+Id(i,k)*Imcp(k,j) + enddo + enddo + enddo + do i=1,3 + do j=1,3 + do k=1,3 + pr2(i,j)=pr2(i,j)+eigvec(i,k)*pr1(k,j) + enddo + enddo + enddo +c Calculating the total rotational velocity of the molecule + do i=1,3 + do j=1,3 + vrot(i)=vrot(i)+pr2(i,j)*L(j) + enddo + enddo +c Resetting the velocities + do i=nnt,nct-1 + call vecpr(vrot(1),dc(1,i),vp) + do j=1,3 + d_t(j,i)=d_t(j,i)-vp(j) + enddo + enddo + do i=nnt,nct + if(itype(i).ne.10) then + inres=i+nres + call vecpr(vrot(1),dc(1,inres),vp) + do j=1,3 + d_t(j,inres)=d_t(j,inres)-vp(j) + enddo + endif + enddo + call angmom(cm,L) +c write(iout,*) "The angular momentum after adjustment:" +c write(iout,*) (L(j),j=1,3) + return + end +c---------------------------------------------------------------------------- + subroutine angmom(cm,L) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + + double precision L(3),cm(3),pr(3),vp(3),vrot(3),incr(3),v(3), + & pp(3) + integer iti,inres +c Calculate the angular momentum + do j=1,3 + L(j)=0.0d0 + enddo + do j=1,3 + incr(j)=d_t(j,0) + enddo + do i=nnt,nct-1 + do j=1,3 + pr(j)=c(j,i)+0.5d0*dc(j,i)-cm(j) + enddo + do j=1,3 + v(j)=incr(j)+0.5d0*d_t(j,i) + enddo + do j=1,3 + incr(j)=incr(j)+d_t(j,i) + enddo + call vecpr(pr(1),v(1),vp) + do j=1,3 + L(j)=L(j)+mp*vp(j) + enddo + do j=1,3 + pr(j)=0.5d0*dc(j,i) + pp(j)=0.5d0*d_t(j,i) + enddo + call vecpr(pr(1),pp(1),vp) + do j=1,3 + L(j)=L(j)+Ip*vp(j) + enddo + enddo + do j=1,3 + incr(j)=d_t(j,0) + enddo + do i=nnt,nct + iti=itype(i) + inres=i+nres + do j=1,3 + pr(j)=c(j,inres)-cm(j) + enddo + if (itype(i).ne.10) then + do j=1,3 + v(j)=incr(j)+d_t(j,inres) + enddo + else + do j=1,3 + v(j)=incr(j) + enddo + endif + call vecpr(pr(1),v(1),vp) +c write (iout,*) "i",i," iti",iti," pr",(pr(j),j=1,3), +c & " v",(v(j),j=1,3)," vp",(vp(j),j=1,3) + do j=1,3 + L(j)=L(j)+msc(iti)*vp(j) + enddo +c write (iout,*) "L",(l(j),j=1,3) + if (itype(i).ne.10) then + do j=1,3 + v(j)=incr(j)+d_t(j,inres) + enddo + call vecpr(dc(1,inres),d_t(1,inres),vp) + do j=1,3 + L(j)=L(j)+Isc(iti)*vp(j) + enddo + endif + do j=1,3 + incr(j)=incr(j)+d_t(j,i) + enddo + enddo + return + end +c------------------------------------------------------------------------------ + subroutine vcm_vel(vcm) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.MD' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + double precision vcm(3),vv(3),summas,amas + do j=1,3 + vcm(j)=0.0d0 + vv(j)=d_t(j,0) + enddo + summas=0.0d0 + do i=nnt,nct + if (i.lt.nct) then + summas=summas+mp + do j=1,3 + vcm(j)=vcm(j)+mp*(vv(j)+0.5d0*d_t(j,i)) + enddo + endif + amas=msc(itype(i)) + summas=summas+amas + if (itype(i).ne.10) then + do j=1,3 + vcm(j)=vcm(j)+amas*(vv(j)+d_t(j,i+nres)) + enddo + else + do j=1,3 + vcm(j)=vcm(j)+amas*vv(j) + enddo + endif + do j=1,3 + vv(j)=vv(j)+d_t(j,i) + enddo + enddo +c write (iout,*) "vcm",(vcm(j),j=1,3)," summas",summas + do j=1,3 + vcm(j)=vcm(j)/summas + enddo + return + end diff --git a/source/unres/src_MD-DFA-restraints/muca_md.f b/source/unres/src_MD-DFA-restraints/muca_md.f new file mode 100644 index 0000000..c10a6a7 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/muca_md.f @@ -0,0 +1,334 @@ + subroutine muca_delta(remd_t_bath,remd_ene,i,iex,delta) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.MUCA' + include 'COMMON.MD' + double precision remd_t_bath(maxprocs) + double precision remd_ene(maxprocs) + double precision muca_ene + double precision betai,betaiex,delta + + betai=1.0/(Rb*remd_t_bath(i)) + betaiex=1.0/(Rb*remd_t_bath(iex)) + + delta=betai*(muca_ene(remd_ene(iex),i,remd_t_bath)- + & muca_ene(remd_ene(i),i,remd_t_bath)) + & -betaiex*(muca_ene(remd_ene(iex),iex,remd_t_bath)- + & muca_ene(remd_ene(i),iex,remd_t_bath)) + + return + end + + double precision function muca_ene(energy,i,remd_t_bath) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.MUCA' + include 'COMMON.MD' + double precision y,yp,energy + double precision remd_t_bath(maxprocs) + integer i + + if (energy.lt.elowi(i)) then + call splint(emuca,nemuca,nemuca2,nmuca,elowi(i),y,yp) + muca_ene=remd_t_bath(i)*Rb*(yp*(energy-elowi(i))+y) + elseif (energy.gt.ehighi(i)) then + call splint(emuca,nemuca,nemuca2,nmuca,ehighi(i),y,yp) + muca_ene=remd_t_bath(i)*Rb*(yp*(energy-ehighi(i))+y) + else + call splint(emuca,nemuca,nemuca2,nmuca,energy,y,yp) + muca_ene=remd_t_bath(i)*Rb*y + endif + return + end + + subroutine read_muca + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.MUCA' + include 'COMMON.CONTROL' + include 'COMMON.MD' + include 'COMMON.REMD' + include 'COMMON.SETUP' + include 'COMMON.IOUNITS' + double precision yp1,ypn,yp,x,muca_factor,y,muca_ene + imtime=0 + do i=1,4*maxres + hist(i)=0 + enddo + if (modecalc.eq.14.and..not.remd_tlist) then + print *,"MUCAREMD works only with TLIST" + stop + endif + open(89,file='muca.input') + read(89,*) + read(89,*) + if (modecalc.eq.14) then + read(89,*) (elowi(i),ehighi(i),i=1,nrep) + if (remd_mlist) then + k=0 + do i=1,nrep + do j=1,remd_m(i) + i2rep(k)=i + k=k+1 + enddo + enddo + elow=elowi(i2rep(me)) + ehigh=ehighi(i2rep(me)) + elowi(me+1)=elow + ehighi(me+1)=ehigh + else + elow=elowi(me+1) + ehigh=ehighi(me+1) + endif + else + read(89,*) elow,ehigh + elowi(1)=elow + ehighi(1)=ehigh + endif + i=0 + do while(.true.) + i=i+1 + read(89,*,end=100) emuca(i),nemuca(i) +cd nemuca(i)=nemuca(i)*remd_t(me+1)*Rb + enddo + 100 continue + nmuca=i-1 + hbin=emuca(nmuca)-emuca(nmuca-1) + write (iout,*) 'hbin',hbin + write (iout,*) me,'elow,ehigh',elow,ehigh + yp1=0 + ypn=0 + call spline(emuca,nemuca,nmuca,yp1,ypn,nemuca2) + factor_min=0.0d0 + factor_min=muca_factor(ehigh) + call print_muca + return + end + + + subroutine print_muca + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.MUCA' + include 'COMMON.CONTROL' + include 'COMMON.MD' + include 'COMMON.REMD' + include 'COMMON.SETUP' + include 'COMMON.IOUNITS' + double precision yp1,ypn,yp,x,muca_factor,y,muca_ene + double precision dummy(maxprocs) + + if (remd_mlist) then + k=0 + do i=1,nrep + do j=1,remd_m(i) + i2rep(k)=i + k=k+1 + enddo + enddo + endif + + do i=1,nmuca +c print *,'nemuca ',emuca(i),nemuca(i) + do j=0,4 + x=emuca(i)+hbin/5*j + if (modecalc.eq.14) then + if (remd_mlist) then + yp=muca_factor(x)*remd_t(i2rep(me))*Rb + dummy(me+1)=remd_t(i2rep(me)) + y=muca_ene(x,me+1,dummy) + else + yp=muca_factor(x)*remd_t(me+1)*Rb + y=muca_ene(x,me+1,remd_t) + endif + write (iout,'(i4,i12,a12,2f15.5,a10,f15.5)') me,imtime, + & 'muca factor ',x,yp,' muca ene',y + else + yp=muca_factor(x)*t_bath*Rb + dummy(1)=t_bath + y=muca_ene(x,1,dummy) + write (iout,'(i4,i12,a12,2f15.5,a10,f15.5)') me,imtime, + & 'muca factor ',x,yp,' muca ene',y + endif + enddo + enddo + if(mucadyn.gt.0) then + do i=1,nmuca + write(iout,'(a13,i8,2f12.5)') 'nemuca after ', + & imtime,emuca(i),nemuca(i) + enddo + endif + return + end + + subroutine muca_update(energy) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.MUCA' + include 'COMMON.CONTROL' + include 'COMMON.MD' + include 'COMMON.REMD' + include 'COMMON.SETUP' + include 'COMMON.IOUNITS' + double precision energy + double precision yp1,ypn + integer k + logical lnotend + + k=int((energy-emuca(1))/hbin)+1 + + IF(muca_smooth.eq.1.or.muca_smooth.eq.3) THEN + if(energy.ge.ehigh) + & write (iout,*) 'MUCA reject',energy,emuca(k) + if(energy.ge.ehigh.and.(energy-ehigh).lt.hbin) then + write (iout,*) 'MUCA ehigh',energy,emuca(k) + do i=k,nmuca + hist(i)=hist(i)+1 + enddo + endif + if(k.gt.0.and.energy.lt.ehigh) hist(k)=hist(k)+1 + ELSE + if(k.gt.0.and.k.lt.4*maxres) hist(k)=hist(k)+1 + ENDIF + if(mod(imtime,mucadyn).eq.0) then + + do i=1,nmuca + IF(muca_smooth.eq.2.or.muca_smooth.eq.3) THEN + nemuca(i)=nemuca(i)+dlog(hist(i)+1) + ELSE + if (hist(i).gt.0) hist(i)=dlog(hist(i)) + nemuca(i)=nemuca(i)+hist(i) + ENDIF + hist(i)=0 + write(iout,'(a24,i8,2f12.5)')'nemuca before smoothing ', + & imtime,emuca(i),nemuca(i) + enddo + + + lnotend=.true. + ismooth=0 + ist=2 + ien=nmuca-1 + IF(muca_smooth.eq.1.or.muca_smooth.eq.3) THEN +c lnotend=.false. +c do i=1,nmuca-1 +c do j=i+1,nmuca +c if(nemuca(j).lt.nemuca(i)) lnotend=.true. +c enddo +c enddo + do while(lnotend) + ismooth=ismooth+1 + write (iout,*) 'MUCA update smoothing',ist,ien + do i=ist,ien + nemuca(i)=(nemuca(i-1)+nemuca(i)+nemuca(i+1))/3 + enddo + lnotend=.false. + ist=0 + ien=0 + do i=1,nmuca-1 + do j=i+1,nmuca + if(nemuca(j).lt.nemuca(i)) then + lnotend=.true. + if(ist.eq.0) ist=i-1 + if(ien.lt.j+1) ien=j+1 + endif + enddo + enddo + enddo + ENDIF + + write (iout,*) 'MUCA update ',imtime,' smooth= ',ismooth + yp1=0 + ypn=0 + call spline(emuca,nemuca,nmuca,yp1,ypn,nemuca2) + call print_muca + + endif + return + end + + double precision function muca_factor(energy) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.MUCA' + double precision y,yp,energy + + if (energy.lt.elow) then + call splint(emuca,nemuca,nemuca2,nmuca,elow,y,yp) + elseif (energy.gt.ehigh) then + call splint(emuca,nemuca,nemuca2,nmuca,ehigh,y,yp) + else + call splint(emuca,nemuca,nemuca2,nmuca,energy,y,yp) + endif + + if(yp.ge.factor_min) then + muca_factor=yp + else + muca_factor=factor_min + endif +cd print *,'energy, muca_factor',energy,muca_factor + return + end + + + SUBROUTINE spline(x,y,n,yp1,ypn,y2) + INTEGER n,NMAX + REAL*8 yp1,ypn,x(n),y(n),y2(n) + PARAMETER (NMAX=500) + INTEGER i,k + REAL*8 p,qn,sig,un,u(NMAX) + if (yp1.gt..99e30) then + y2(1)=0. + u(1)=0. + else + y2(1)=-0.5 + u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1) + endif + do i=2,n-1 + sig=(x(i)-x(i-1))/(x(i+1)-x(i-1)) + p=sig*y2(i-1)+2. + y2(i)=(sig-1.)/p + u(i)=(6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1)) + * /(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p + enddo + if (ypn.gt..99e30) then + qn=0. + un=0. + else + qn=0.5 + un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1))) + endif + y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.) + do k=n-1,1,-1 + y2(k)=y2(k)*y2(k+1)+u(k) + enddo + return + END + + + SUBROUTINE splint(xa,ya,y2a,n,x,y,yp) + INTEGER n + REAL*8 x,y,xa(n),y2a(n),ya(n),yp + INTEGER k,khi,klo + REAL*8 a,b,h + klo=1 + khi=n + 1 if (khi-klo.gt.1) then + k=(khi+klo)/2 + if (xa(k).gt.x) then + khi=k + else + klo=k + endif + goto 1 + endif + h=xa(khi)-xa(klo) + if (h.eq.0.) pause 'bad xa input in splint' + a=(xa(khi)-x)/h + b=(x-xa(klo))/h + y=a*ya(klo)+b*ya(khi)+ + * ((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6. + yp=-ya(klo)/h+ya(khi)/h-3*(a**2)*y2a(klo)*h/6. + + +(3*(b**2)-1)*y2a(khi)*h/6. + return + END diff --git a/source/unres/src_MD-DFA-restraints/parmread.F b/source/unres/src_MD-DFA-restraints/parmread.F new file mode 100644 index 0000000..030d64e --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/parmread.F @@ -0,0 +1,1036 @@ + subroutine parmread +C +C Read the parameters of the probability distributions of the virtual-bond +C valence angles and the side chains and energy parameters. +C +C Important! Energy-term weights ARE NOT read here; they are read from the +C main input file instead, because NO defaults have yet been set for these +C parameters. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include "mpif.h" + integer IERROR +#endif + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.SCCOR' + include 'COMMON.SCROT' + include 'COMMON.FFIELD' + include 'COMMON.NAMES' + include 'COMMON.SBRIDGE' + include 'COMMON.MD' + include 'COMMON.SETUP' + character*1 t1,t2,t3 + character*1 onelett(4) /"G","A","P","D"/ + logical lprint,LaTeX + dimension blower(3,3,maxlob) + dimension b(13) + character*3 lancuch,ucase +C +C For printing parameters after they are read set the following in the UNRES +C C-shell script: +C +C setenv PRINT_PARM YES +C +C To print parameters in LaTeX format rather than as ASCII tables: +C +C setenv LATEX YES +C + call getenv_loc("PRINT_PARM",lancuch) + lprint = (ucase(lancuch).eq."YES" .or. ucase(lancuch).eq."Y") + call getenv_loc("LATEX",lancuch) + LaTeX = (ucase(lancuch).eq."YES" .or. ucase(lancuch).eq."Y") +C + dwa16=2.0d0**(1.0d0/6.0d0) + itypro=20 +C Assign virtual-bond length + vbl=3.8D0 + vblinv=1.0D0/vbl + vblinv2=vblinv*vblinv +c +c Read the virtual-bond parameters, masses, and moments of inertia +c and Stokes' radii of the peptide group and side chains +c +#ifdef CRYST_BOND + read (ibond,*) vbldp0,akp,mp,ip,pstok + do i=1,ntyp + nbondterm(i)=1 + read (ibond,*) vbldsc0(1,i),aksc(1,i),msc(i),isc(i),restok(i) + dsc(i) = vbldsc0(1,i) + if (i.eq.10) then + dsc_inv(i)=0.0D0 + else + dsc_inv(i)=1.0D0/dsc(i) + endif + enddo +#else + read (ibond,*) junk,vbldp0,akp,rjunk,mp,ip,pstok + do i=1,ntyp + read (ibond,*) nbondterm(i),(vbldsc0(j,i),aksc(j,i),abond0(j,i), + & j=1,nbondterm(i)),msc(i),isc(i),restok(i) + dsc(i) = vbldsc0(1,i) + if (i.eq.10) then + dsc_inv(i)=0.0D0 + else + dsc_inv(i)=1.0D0/dsc(i) + endif + enddo +#endif + if (lprint) then + write(iout,'(/a/)')"Dynamic constants of the interaction sites:" + write (iout,'(a10,a3,6a10)') 'Type','N','VBL','K','A0','mass', + & 'inertia','Pstok' + write(iout,'(a10,i3,6f10.5)') "p",1,vbldp0,akp,0.0d0,mp,ip,pstok + do i=1,ntyp + write (iout,'(a10,i3,6f10.5)') restyp(i),nbondterm(i), + & vbldsc0(1,i),aksc(1,i),abond0(1,i),msc(i),isc(i),restok(i) + do j=2,nbondterm(i) + write (iout,'(13x,3f10.5)') + & vbldsc0(j,i),aksc(j,i),abond0(j,i) + enddo + enddo + endif +#ifdef CRYST_THETA +C +C Read the parameters of the probability distribution/energy expression +C of the virtual-bond valence angles theta +C + do i=1,ntyp + read (ithep,*,err=111,end=111) a0thet(i),(athet(j,i),j=1,2), + & (bthet(j,i),j=1,2) + read (ithep,*,err=111,end=111) (polthet(j,i),j=0,3) + read (ithep,*,err=111,end=111) (gthet(j,i),j=1,3) + read (ithep,*,err=111,end=111) theta0(i),sig0(i),sigc0(i) + sigc0(i)=sigc0(i)**2 + enddo + close (ithep) + if (lprint) then + if (.not.LaTeX) then + write (iout,'(a)') + & 'Parameters of the virtual-bond valence angles:' + write (iout,'(/a/9x,5a/79(1h-))') 'Fourier coefficients:', + & ' ATHETA0 ',' A1 ',' A2 ', + & ' B1 ',' B2 ' + do i=1,ntyp + write(iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i, + & a0thet(i),(athet(j,i),j=1,2),(bthet(j,i),j=1,2) + enddo + write (iout,'(/a/9x,5a/79(1h-))') + & 'Parameters of the expression for sigma(theta_c):', + & ' ALPH0 ',' ALPH1 ',' ALPH2 ', + & ' ALPH3 ',' SIGMA0C ' + do i=1,ntyp + write (iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i, + & (polthet(j,i),j=0,3),sigc0(i) + enddo + write (iout,'(/a/9x,5a/79(1h-))') + & 'Parameters of the second gaussian:', + & ' THETA0 ',' SIGMA0 ',' G1 ', + & ' G2 ',' G3 ' + do i=1,ntyp + write (iout,'(a3,i4,2x,5(1pe14.5))') restyp(i),i,theta0(i), + & sig0(i),(gthet(j,i),j=1,3) + enddo + else + write (iout,'(a)') + & 'Parameters of the virtual-bond valence angles:' + write (iout,'(/a/9x,5a/79(1h-))') + & 'Coefficients of expansion', + & ' theta0 ',' a1*10^2 ',' a2*10^2 ', + & ' b1*10^1 ',' b2*10^1 ' + do i=1,ntyp + write(iout,'(a3,1h&,2x,5(f8.3,1h&))') restyp(i), + & a0thet(i),(100*athet(j,i),j=1,2),(10*bthet(j,i),j=1,2) + enddo + write (iout,'(/a/9x,5a/79(1h-))') + & 'Parameters of the expression for sigma(theta_c):', + & ' alpha0 ',' alph1 ',' alph2 ', + & ' alhp3 ',' sigma0c ' + do i=1,ntyp + write (iout,'(a3,1h&,2x,5(1pe12.3,1h&))') restyp(i), + & (polthet(j,i),j=0,3),sigc0(i) + enddo + write (iout,'(/a/9x,5a/79(1h-))') + & 'Parameters of the second gaussian:', + & ' theta0 ',' sigma0*10^2 ',' G1*10^-1', + & ' G2 ',' G3*10^1 ' + do i=1,ntyp + write (iout,'(a3,1h&,2x,5(f8.3,1h&))') restyp(i),theta0(i), + & 100*sig0(i),gthet(1,i)*0.1D0,gthet(2,i),gthet(3,i)*10.0D0 + enddo + endif + endif +#else +C +C Read the parameters of Utheta determined from ab initio surfaces +C Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203 +C + read (ithep,*,err=111,end=111) nthetyp,ntheterm,ntheterm2, + & ntheterm3,nsingle,ndouble + nntheterm=max0(ntheterm,ntheterm2,ntheterm3) + read (ithep,*,err=111,end=111) (ithetyp(i),i=1,ntyp1) + do i=1,maxthetyp + do j=1,maxthetyp + do k=1,maxthetyp + aa0thet(i,j,k)=0.0d0 + do l=1,ntheterm + aathet(l,i,j,k)=0.0d0 + enddo + do l=1,ntheterm2 + do m=1,nsingle + bbthet(m,l,i,j,k)=0.0d0 + ccthet(m,l,i,j,k)=0.0d0 + ddthet(m,l,i,j,k)=0.0d0 + eethet(m,l,i,j,k)=0.0d0 + enddo + enddo + do l=1,ntheterm3 + do m=1,ndouble + do mm=1,ndouble + ffthet(mm,m,l,i,j,k)=0.0d0 + ggthet(mm,m,l,i,j,k)=0.0d0 + enddo + enddo + enddo + enddo + enddo + enddo + do i=1,nthetyp + do j=1,nthetyp + do k=1,nthetyp + read (ithep,'(3a)',end=111,err=111) res1,res2,res3 + read (ithep,*,end=111,err=111) aa0thet(i,j,k) + read (ithep,*,end=111,err=111)(aathet(l,i,j,k),l=1,ntheterm) + read (ithep,*,end=111,err=111) + & ((bbthet(lll,ll,i,j,k),lll=1,nsingle), + & (ccthet(lll,ll,i,j,k),lll=1,nsingle), + & (ddthet(lll,ll,i,j,k),lll=1,nsingle), + & (eethet(lll,ll,i,j,k),lll=1,nsingle),ll=1,ntheterm2) + read (ithep,*,end=111,err=111) + & (((ffthet(llll,lll,ll,i,j,k),ffthet(lll,llll,ll,i,j,k), + & ggthet(llll,lll,ll,i,j,k),ggthet(lll,llll,ll,i,j,k), + & llll=1,lll-1),lll=2,ndouble),ll=1,ntheterm3) + enddo + enddo + enddo +C +C For dummy ends assign glycine-type coefficients of theta-only terms; the +C coefficients of theta-and-gamma-dependent terms are zero. +C + do i=1,nthetyp + do j=1,nthetyp + do l=1,ntheterm + aathet(l,i,j,nthetyp+1)=aathet(l,i,j,1) + aathet(l,nthetyp+1,i,j)=aathet(l,1,i,j) + enddo + aa0thet(i,j,nthetyp+1)=aa0thet(i,j,1) + aa0thet(nthetyp+1,i,j)=aa0thet(1,i,j) + enddo + do l=1,ntheterm + aathet(l,nthetyp+1,i,nthetyp+1)=aathet(l,1,i,1) + enddo + aa0thet(nthetyp+1,i,nthetyp+1)=aa0thet(1,i,1) + enddo +C +C Control printout of the coefficients of virtual-bond-angle potentials +C + if (lprint) then + write (iout,'(//a)') 'Parameter of virtual-bond-angle potential' + do i=1,nthetyp+1 + do j=1,nthetyp+1 + do k=1,nthetyp+1 + write (iout,'(//4a)') + & 'Type ',onelett(i),onelett(j),onelett(k) + write (iout,'(//a,10x,a)') " l","a[l]" + write (iout,'(i2,1pe15.5)') 0,aa0thet(i,j,k) + write (iout,'(i2,1pe15.5)') + & (l,aathet(l,i,j,k),l=1,ntheterm) + do l=1,ntheterm2 + write (iout,'(//2h m,4(9x,a,3h[m,,i1,1h]))') + & "b",l,"c",l,"d",l,"e",l + do m=1,nsingle + write (iout,'(i2,4(1pe15.5))') m, + & bbthet(m,l,i,j,k),ccthet(m,l,i,j,k), + & ddthet(m,l,i,j,k),eethet(m,l,i,j,k) + enddo + enddo + do l=1,ntheterm3 + write (iout,'(//3hm,n,4(6x,a,5h[m,n,,i1,1h]))') + & "f+",l,"f-",l,"g+",l,"g-",l + do m=2,ndouble + do n=1,m-1 + write (iout,'(i1,1x,i1,4(1pe15.5))') n,m, + & ffthet(n,m,l,i,j,k),ffthet(m,n,l,i,j,k), + & ggthet(n,m,l,i,j,k),ggthet(m,n,l,i,j,k) + enddo + enddo + enddo + enddo + enddo + enddo + call flush(iout) + endif + write (2,*) "Start reading THETA_PDB" + do i=1,ntyp + read (ithep_pdb,*,err=111,end=111) a0thet(i),(athet(j,i),j=1,2), + & (bthet(j,i),j=1,2) + read (ithep_pdb,*,err=111,end=111) (polthet(j,i),j=0,3) + read (ithep_pdb,*,err=111,end=111) (gthet(j,i),j=1,3) + read (ithep_pdb,*,err=111,end=111) theta0(i),sig0(i),sigc0(i) + sigc0(i)=sigc0(i)**2 + enddo + write (2,*) "End reading THETA_PDB" + close (ithep_pdb) +#endif + close(ithep) +#ifdef CRYST_SC +C +C Read the parameters of the probability distribution/energy expression +C of the side chains. +C + do i=1,ntyp + read (irotam,'(3x,i3,f8.3)',end=112,err=112) nlob(i),dsc(i) + if (i.eq.10) then + dsc_inv(i)=0.0D0 + else + dsc_inv(i)=1.0D0/dsc(i) + endif + if (i.ne.10) then + do j=1,nlob(i) + do k=1,3 + do l=1,3 + blower(l,k,j)=0.0D0 + enddo + enddo + enddo + bsc(1,i)=0.0D0 + read(irotam,*,end=112,err=112)(censc(k,1,i),k=1,3), + & ((blower(k,l,1),l=1,k),k=1,3) + do j=2,nlob(i) + read (irotam,*,end=112,err=112) bsc(j,i) + read (irotam,*,end=112,err=112) (censc(k,j,i),k=1,3), + & ((blower(k,l,j),l=1,k),k=1,3) + enddo + do j=1,nlob(i) + do k=1,3 + do l=1,k + akl=0.0D0 + do m=1,3 + akl=akl+blower(k,m,j)*blower(l,m,j) + enddo + gaussc(k,l,j,i)=akl + gaussc(l,k,j,i)=akl + enddo + enddo + enddo + endif + enddo + close (irotam) + if (lprint) then + write (iout,'(/a)') 'Parameters of side-chain local geometry' + do i=1,ntyp + nlobi=nlob(i) + if (nlobi.gt.0) then + if (LaTeX) then + write (iout,'(/3a,i2,a,f8.3)') 'Residue type: ',restyp(i), + & ' # of gaussian lobes:',nlobi,' dsc:',dsc(i) + write (iout,'(1h&,a,3(2h&&,f8.3,2h&&))') + & 'log h',(bsc(j,i),j=1,nlobi) + write (iout,'(1h&,a,3(1h&,f8.3,1h&,f8.3,1h&,f8.3,1h&))') + & 'x',((censc(k,j,i),k=1,3),j=1,nlobi) + do k=1,3 + write (iout,'(2h& ,5(2x,1h&,3(f7.3,1h&)))') + & ((gaussc(k,l,j,i),l=1,3),j=1,nlobi) + enddo + else + write (iout,'(/a,8x,i1,4(25x,i1))') 'Lobe:',(j,j=1,nlobi) + write (iout,'(a,f10.4,4(16x,f10.4))') + & 'Center ',(bsc(j,i),j=1,nlobi) + write (iout,'(5(2x,3f8.4))') ((censc(k,j,i),k=1,3), + & j=1,nlobi) + write (iout,'(a)') + endif + endif + enddo + endif +#else +C +C Read scrot parameters for potentials determined from all-atom AM1 calculations +C added by Urszula Kozlowska 07/11/2007 +C + do i=1,ntyp + read (irotam,*,end=112,err=112) + if (i.eq.10) then + read (irotam,*,end=112,err=112) + else + do j=1,65 + read(irotam,*,end=112,err=112) sc_parmin(j,i) + enddo + endif + enddo +C +C Read the parameters of the probability distribution/energy expression +C of the side chains. +C + do i=1,ntyp + read (irotam_pdb,'(3x,i3,f8.3)',end=112,err=112) nlob(i),dsc(i) + if (i.eq.10) then + dsc_inv(i)=0.0D0 + else + dsc_inv(i)=1.0D0/dsc(i) + endif + if (i.ne.10) then + do j=1,nlob(i) + do k=1,3 + do l=1,3 + blower(l,k,j)=0.0D0 + enddo + enddo + enddo + bsc(1,i)=0.0D0 + read(irotam_pdb,*,end=112,err=112)(censc(k,1,i),k=1,3), + & ((blower(k,l,1),l=1,k),k=1,3) + do j=2,nlob(i) + read (irotam_pdb,*,end=112,err=112) bsc(j,i) + read (irotam_pdb,*,end=112,err=112) (censc(k,j,i),k=1,3), + & ((blower(k,l,j),l=1,k),k=1,3) + enddo + do j=1,nlob(i) + do k=1,3 + do l=1,k + akl=0.0D0 + do m=1,3 + akl=akl+blower(k,m,j)*blower(l,m,j) + enddo + gaussc(k,l,j,i)=akl + gaussc(l,k,j,i)=akl + enddo + enddo + enddo + endif + enddo + close (irotam_pdb) +#endif + close(irotam) + +#ifdef CRYST_TOR +C +C Read torsional parameters in old format +C + read (itorp,*,end=113,err=113) ntortyp,nterm_old + if (lprint)write (iout,*) 'ntortyp,nterm',ntortyp,nterm_old + read (itorp,*,end=113,err=113) (itortyp(i),i=1,ntyp) + do i=1,ntortyp + do j=1,ntortyp + read (itorp,'(a)') + do k=1,nterm_old + read (itorp,*,end=113,err=113) kk,v1(k,j,i),v2(k,j,i) + enddo + enddo + enddo + close (itorp) + if (lprint) then + write (iout,'(/a/)') 'Torsional constants:' + do i=1,ntortyp + do j=1,ntortyp + write (iout,'(2i3,6f10.5)') i,j,(v1(k,i,j),k=1,nterm_old) + write (iout,'(6x,6f10.5)') (v2(k,i,j),k=1,nterm_old) + enddo + enddo + endif +#else +C +C Read torsional parameters +C + read (itorp,*,end=113,err=113) ntortyp + read (itorp,*,end=113,err=113) (itortyp(i),i=1,ntyp) +c write (iout,*) 'ntortyp',ntortyp + do i=1,ntortyp + do j=1,ntortyp + read (itorp,*,end=113,err=113) nterm(i,j),nlor(i,j) + v0ij=0.0d0 + si=-1.0d0 + do k=1,nterm(i,j) + read (itorp,*,end=113,err=113) kk,v1(k,i,j),v2(k,i,j) + v0ij=v0ij+si*v1(k,i,j) + si=-si + enddo + do k=1,nlor(i,j) + read (itorp,*,end=113,err=113) kk,vlor1(k,i,j), + & vlor2(k,i,j),vlor3(k,i,j) + v0ij=v0ij+vlor1(k,i,j)/(1+vlor3(k,i,j)**2) + enddo + v0(i,j)=v0ij + enddo + enddo + close (itorp) + if (lprint) then + write (iout,'(/a/)') 'Torsional constants:' + do i=1,ntortyp + do j=1,ntortyp + write (iout,*) 'ityp',i,' jtyp',j + write (iout,*) 'Fourier constants' + do k=1,nterm(i,j) + write (iout,'(2(1pe15.5))') v1(k,i,j),v2(k,i,j) + enddo + write (iout,*) 'Lorenz constants' + do k=1,nlor(i,j) + write (iout,'(3(1pe15.5))') + & vlor1(k,i,j),vlor2(k,i,j),vlor3(k,i,j) + enddo + enddo + enddo + endif +C +C 6/23/01 Read parameters for double torsionals +C + do i=1,ntortyp + do j=1,ntortyp + do k=1,ntortyp + read (itordp,'(3a1)',end=114,err=114) t1,t2,t3 + if (t1.ne.onelett(i) .or. t2.ne.onelett(j) + & .or. t3.ne.onelett(k)) then + write (iout,*) "Error in double torsional parameter file", + & i,j,k,t1,t2,t3 +#ifdef MPI + call MPI_Finalize(Ierror) +#endif + stop "Error in double torsional parameter file" + endif + read (itordp,*,end=114,err=114) ntermd_1(i,j,k), + & ntermd_2(i,j,k) + read (itordp,*,end=114,err=114) (v1c(1,l,i,j,k),l=1, + & ntermd_1(i,j,k)) + read (itordp,*,end=114,err=114) (v1s(1,l,i,j,k),l=1, + & ntermd_1(i,j,k)) + read (itordp,*,end=114,err=114) (v1c(2,l,i,j,k),l=1, + & ntermd_1(i,j,k)) + read (itordp,*,end=114,err=114) (v1s(2,l,i,j,k),l=1, + & ntermd_1(i,j,k)) + read (itordp,*,end=114,err=114) ((v2c(l,m,i,j,k), + & v2c(m,l,i,j,k),v2s(l,m,i,j,k),v2s(m,l,i,j,k), + & m=1,l-1),l=1,ntermd_2(i,j,k)) + enddo + enddo + enddo + if (lprint) then + write (iout,*) + write (iout,*) 'Constants for double torsionals' + do i=1,ntortyp + do j=1,ntortyp + do k=1,ntortyp + write (iout,*) 'ityp',i,' jtyp',j,' ktyp',k, + & ' nsingle',ntermd_1(i,j,k),' ndouble',ntermd_2(i,j,k) + write (iout,*) + write (iout,*) 'Single angles:' + do l=1,ntermd_1(i,j,k) + write (iout,'(i5,2f10.5,5x,2f10.5)') l, + & v1c(1,l,i,j,k),v1s(1,l,i,j,k), + & v1c(2,l,i,j,k),v1s(2,l,i,j,k) + enddo + write (iout,*) + write (iout,*) 'Pairs of angles:' + write (iout,'(3x,20i10)') (l,l=1,ntermd_2(i,j,k)) + do l=1,ntermd_2(i,j,k) + write (iout,'(i5,20f10.5)') + & l,(v2c(l,m,i,j,k),m=1,ntermd_2(i,j,k)) + enddo + write (iout,*) + write (iout,'(3x,20i10)') (l,l=1,ntermd_2(i,j,k)) + do l=1,ntermd_2(i,j,k) + write (iout,'(i5,20f10.5)') + & l,(v2s(l,m,i,j,k),m=1,ntermd_2(i,j,k)) + enddo + write (iout,*) + enddo + enddo + enddo + endif +#endif +C Read of Side-chain backbone correlation parameters +C Modified 11 May 2012 by Adasko +CCC +C + read (isccor,*,end=1113,err=1113) nsccortyp + read (isccor,*,end=1113,err=1113) (isccortyp(i),i=1,ntyp) +c write (iout,*) 'ntortyp',ntortyp + maxinter=3 +cc maxinter is maximum interaction sites + do l=1,maxinter + do i=1,nsccortyp + do j=1,nsccortyp + read (isccor,*,end=1113,err=1113) nterm_sccor(i,j), + & nlor_sccor(i,j) + v0ijsccor=0.0d0 + si=-1.0d0 + + do k=1,nterm_sccor(i,j) + read (isccor,*,end=1113,err=1113) kk,v1sccor(k,l,i,j) + & ,v2sccor(k,l,i,j) + v0ijsccor=v0ijsccor+si*v1sccor(k,l,i,j) + si=-si + enddo + do k=1,nlor_sccor(i,j) + read (isccor,*,end=1113,err=1113) kk,vlor1sccor(k,i,j), + & vlor2sccor(k,i,j),vlor3sccor(k,i,j) + v0ijsccor=v0ijsccor+vlor1sccor(k,i,j)/ + &(1+vlor3sccor(k,i,j)**2) + enddo + v0sccor(i,j)=v0ijsccor + enddo + enddo + enddo + close (isccor) + + if (lprint) then + write (iout,'(/a/)') 'Torsional constants:' + do i=1,nsccortyp + do j=1,nsccortyp + write (iout,*) 'ityp',i,' jtyp',j + write (iout,*) 'Fourier constants' + do k=1,nterm_sccor(i,j) + write (iout,'(2(1pe15.5))') v1sccor(k,l,i,j),v2sccor(k,l,i,j) + enddo + write (iout,*) 'Lorenz constants' + do k=1,nlor_sccor(i,j) + write (iout,'(3(1pe15.5))') + & vlor1sccor(k,i,j),vlor2sccor(k,i,j),vlor3sccor(k,i,j) + enddo + enddo + enddo + endif +C +C +C 9/18/99 (AL) Read coefficients of the Fourier expansion of the local +C interaction energy of the Gly, Ala, and Pro prototypes. +C + if (lprint) then + write (iout,*) + write (iout,*) "Coefficients of the cumulants" + endif + read (ifourier,*) nloctyp + do i=1,nloctyp + read (ifourier,*,end=115,err=115) + read (ifourier,*,end=115,err=115) (b(ii),ii=1,13) + if (lprint) then + write (iout,*) 'Type',i + write (iout,'(a,i2,a,f10.5)') ('b(',ii,')=',b(ii),ii=1,13) + endif + B1(1,i) = b(3) + B1(2,i) = b(5) +c b1(1,i)=0.0d0 +c b1(2,i)=0.0d0 + B1tilde(1,i) = b(3) + B1tilde(2,i) =-b(5) +c b1tilde(1,i)=0.0d0 +c b1tilde(2,i)=0.0d0 + B2(1,i) = b(2) + B2(2,i) = b(4) +c b2(1,i)=0.0d0 +c b2(2,i)=0.0d0 + CC(1,1,i)= b(7) + CC(2,2,i)=-b(7) + CC(2,1,i)= b(9) + CC(1,2,i)= b(9) +c CC(1,1,i)=0.0d0 +c CC(2,2,i)=0.0d0 +c CC(2,1,i)=0.0d0 +c CC(1,2,i)=0.0d0 + Ctilde(1,1,i)=b(7) + Ctilde(1,2,i)=b(9) + Ctilde(2,1,i)=-b(9) + Ctilde(2,2,i)=b(7) +c Ctilde(1,1,i)=0.0d0 +c Ctilde(1,2,i)=0.0d0 +c Ctilde(2,1,i)=0.0d0 +c Ctilde(2,2,i)=0.0d0 + DD(1,1,i)= b(6) + DD(2,2,i)=-b(6) + DD(2,1,i)= b(8) + DD(1,2,i)= b(8) +c DD(1,1,i)=0.0d0 +c DD(2,2,i)=0.0d0 +c DD(2,1,i)=0.0d0 +c DD(1,2,i)=0.0d0 + Dtilde(1,1,i)=b(6) + Dtilde(1,2,i)=b(8) + Dtilde(2,1,i)=-b(8) + Dtilde(2,2,i)=b(6) +c Dtilde(1,1,i)=0.0d0 +c Dtilde(1,2,i)=0.0d0 +c Dtilde(2,1,i)=0.0d0 +c Dtilde(2,2,i)=0.0d0 + EE(1,1,i)= b(10)+b(11) + EE(2,2,i)=-b(10)+b(11) + EE(2,1,i)= b(12)-b(13) + EE(1,2,i)= b(12)+b(13) +c ee(1,1,i)=1.0d0 +c ee(2,2,i)=1.0d0 +c ee(2,1,i)=0.0d0 +c ee(1,2,i)=0.0d0 +c ee(2,1,i)=ee(1,2,i) + enddo + if (lprint) then + do i=1,nloctyp + write (iout,*) 'Type',i + write (iout,*) 'B1' + write(iout,*) B1(1,i),B1(2,i) + write (iout,*) 'B2' + write(iout,*) B2(1,i),B2(2,i) + write (iout,*) 'CC' + do j=1,2 + write (iout,'(2f10.5)') CC(j,1,i),CC(j,2,i) + enddo + write(iout,*) 'DD' + do j=1,2 + write (iout,'(2f10.5)') DD(j,1,i),DD(j,2,i) + enddo + write(iout,*) 'EE' + do j=1,2 + write (iout,'(2f10.5)') EE(j,1,i),EE(j,2,i) + enddo + enddo + endif +C +C Read electrostatic-interaction parameters +C + if (lprint) then + write (iout,*) + write (iout,'(/a)') 'Electrostatic interaction constants:' + write (iout,'(1x,a,1x,a,10x,a,11x,a,11x,a,11x,a)') + & 'IT','JT','APP','BPP','AEL6','AEL3' + endif + read (ielep,*,end=116,err=116) ((epp(i,j),j=1,2),i=1,2) + read (ielep,*,end=116,err=116) ((rpp(i,j),j=1,2),i=1,2) + read (ielep,*,end=116,err=116) ((elpp6(i,j),j=1,2),i=1,2) + read (ielep,*,end=116,err=116) ((elpp3(i,j),j=1,2),i=1,2) + close (ielep) + do i=1,2 + do j=1,2 + rri=rpp(i,j)**6 + app (i,j)=epp(i,j)*rri*rri + bpp (i,j)=-2.0D0*epp(i,j)*rri + ael6(i,j)=elpp6(i,j)*4.2D0**6 + ael3(i,j)=elpp3(i,j)*4.2D0**3 + if (lprint) write(iout,'(2i3,4(1pe15.4))')i,j,app(i,j),bpp(i,j), + & ael6(i,j),ael3(i,j) + enddo + enddo +C +C Read side-chain interaction parameters. +C + read (isidep,*,end=117,err=117) ipot,expon + if (ipot.lt.1 .or. ipot.gt.5) then + write (iout,'(2a)') 'Error while reading SC interaction', + & 'potential file - unknown potential type.' +#ifdef MPI + call MPI_Finalize(Ierror) +#endif + stop + endif + expon2=expon/2 + if(me.eq.king) + & write(iout,'(/3a,2i3)') 'Potential is ',potname(ipot), + & ', exponents are ',expon,2*expon + goto (10,20,30,30,40) ipot +C----------------------- LJ potential --------------------------------- + 10 read (isidep,*,end=116,err=116)((eps(i,j),j=i,ntyp),i=1,ntyp), + & (sigma0(i),i=1,ntyp) + if (lprint) then + write (iout,'(/a/)') 'Parameters of the LJ potential:' + write (iout,'(a/)') 'The epsilon array:' + call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) + write (iout,'(/a)') 'One-body parameters:' + write (iout,'(a,4x,a)') 'residue','sigma' + write (iout,'(a3,6x,f10.5)') (restyp(i),sigma0(i),i=1,ntyp) + endif + goto 50 +C----------------------- LJK potential -------------------------------- + 20 read (isidep,*,end=116,err=116)((eps(i,j),j=i,ntyp),i=1,ntyp), + & (sigma0(i),i=1,ntyp),(rr0(i),i=1,ntyp) + if (lprint) then + write (iout,'(/a/)') 'Parameters of the LJK potential:' + write (iout,'(a/)') 'The epsilon array:' + call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) + write (iout,'(/a)') 'One-body parameters:' + write (iout,'(a,4x,2a)') 'residue',' sigma ',' r0 ' + write (iout,'(a3,6x,2f10.5)') (restyp(i),sigma0(i),rr0(i), + & i=1,ntyp) + endif + goto 50 +C---------------------- GB or BP potential ----------------------------- + 30 read (isidep,*,end=116,err=116)((eps(i,j),j=i,ntyp),i=1,ntyp), + & (sigma0(i),i=1,ntyp),(sigii(i),i=1,ntyp),(chip(i),i=1,ntyp), + & (alp(i),i=1,ntyp) +C For the GB potential convert sigma'**2 into chi' + if (ipot.eq.4) then + do i=1,ntyp + chip(i)=(chip(i)-1.0D0)/(chip(i)+1.0D0) + enddo + endif + if (lprint) then + write (iout,'(/a/)') 'Parameters of the BP potential:' + write (iout,'(a/)') 'The epsilon array:' + call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) + write (iout,'(/a)') 'One-body parameters:' + write (iout,'(a,4x,4a)') 'residue',' sigma ','s||/s_|_^2', + & ' chip ',' alph ' + write (iout,'(a3,6x,4f10.5)') (restyp(i),sigma0(i),sigii(i), + & chip(i),alp(i),i=1,ntyp) + endif + goto 50 +C--------------------- GBV potential ----------------------------------- + 40 read (isidep,*,end=116,err=116)((eps(i,j),j=i,ntyp),i=1,ntyp), + & (sigma0(i),i=1,ntyp),(rr0(i),i=1,ntyp),(sigii(i),i=1,ntyp), + & (chip(i),i=1,ntyp),(alp(i),i=1,ntyp) + if (lprint) then + write (iout,'(/a/)') 'Parameters of the GBV potential:' + write (iout,'(a/)') 'The epsilon array:' + call printmat(ntyp,ntyp,ntyp,iout,restyp,eps) + write (iout,'(/a)') 'One-body parameters:' + write (iout,'(a,4x,5a)') 'residue',' sigma ',' r0 ', + & 's||/s_|_^2',' chip ',' alph ' + write (iout,'(a3,6x,5f10.5)') (restyp(i),sigma0(i),rr0(i), + & sigii(i),chip(i),alp(i),i=1,ntyp) + endif + 50 continue + close (isidep) +C----------------------------------------------------------------------- +C Calculate the "working" parameters of SC interactions. + do i=2,ntyp + do j=1,i-1 + eps(i,j)=eps(j,i) + enddo + enddo + do i=1,ntyp + do j=i,ntyp + sigma(i,j)=dsqrt(sigma0(i)**2+sigma0(j)**2) + sigma(j,i)=sigma(i,j) + rs0(i,j)=dwa16*sigma(i,j) + rs0(j,i)=rs0(i,j) + enddo + enddo + if (lprint) write (iout,'(/a/10x,7a/72(1h-))') + & 'Working parameters of the SC interactions:', + & ' a ',' b ',' augm ',' sigma ',' r0 ', + & ' chi1 ',' chi2 ' + do i=1,ntyp + do j=i,ntyp + epsij=eps(i,j) + if (ipot.eq.1 .or. ipot.eq.3 .or. ipot.eq.4) then + rrij=sigma(i,j) + else + rrij=rr0(i)+rr0(j) + endif + r0(i,j)=rrij + r0(j,i)=rrij + rrij=rrij**expon + epsij=eps(i,j) + sigeps=dsign(1.0D0,epsij) + epsij=dabs(epsij) + aa(i,j)=epsij*rrij*rrij + bb(i,j)=-sigeps*epsij*rrij + aa(j,i)=aa(i,j) + bb(j,i)=bb(i,j) + if (ipot.gt.2) then + sigt1sq=sigma0(i)**2 + sigt2sq=sigma0(j)**2 + sigii1=sigii(i) + sigii2=sigii(j) + ratsig1=sigt2sq/sigt1sq + ratsig2=1.0D0/ratsig1 + chi(i,j)=(sigii1-1.0D0)/(sigii1+ratsig1) + if (j.gt.i) chi(j,i)=(sigii2-1.0D0)/(sigii2+ratsig2) + rsum_max=dsqrt(sigii1*sigt1sq+sigii2*sigt2sq) + else + rsum_max=sigma(i,j) + endif +c if (ipot.eq.1 .or. ipot.eq.3 .or. ipot.eq.4) then + sigmaii(i,j)=rsum_max + sigmaii(j,i)=rsum_max +c else +c sigmaii(i,j)=r0(i,j) +c sigmaii(j,i)=r0(i,j) +c endif +cd write (iout,*) i,j,r0(i,j),sigma(i,j),rsum_max + if ((ipot.eq.2 .or. ipot.eq.5) .and. r0(i,j).gt.rsum_max) then + r_augm=sigma(i,j)*(rrij-sigma(i,j))/rrij + augm(i,j)=epsij*r_augm**(2*expon) +c augm(i,j)=0.5D0**(2*expon)*aa(i,j) + augm(j,i)=augm(i,j) + else + augm(i,j)=0.0D0 + augm(j,i)=0.0D0 + endif + if (lprint) then + write (iout,'(2(a3,2x),3(1pe10.3),5(0pf8.3))') + & restyp(i),restyp(j),aa(i,j),bb(i,j),augm(i,j), + & sigma(i,j),r0(i,j),chi(i,j),chi(j,i) + endif + enddo + enddo +#ifdef OLDSCP +C +C Define the SC-p interaction constants (hard-coded; old style) +C + do i=1,20 +C "Soft" SC-p repulsion (causes helices to be too flat, but facilitates +C helix formation) +c aad(i,1)=0.3D0*4.0D0**12 +C Following line for constants currently implemented +C "Hard" SC-p repulsion (gives correct turn spacing in helices) + aad(i,1)=1.5D0*4.0D0**12 +c aad(i,1)=0.17D0*5.6D0**12 + aad(i,2)=aad(i,1) +C "Soft" SC-p repulsion + bad(i,1)=0.0D0 +C Following line for constants currently implemented +c aad(i,1)=0.3D0*4.0D0**6 +C "Hard" SC-p repulsion + bad(i,1)=3.0D0*4.0D0**6 +c bad(i,1)=-2.0D0*0.17D0*5.6D0**6 + bad(i,2)=bad(i,1) +c aad(i,1)=0.0D0 +c aad(i,2)=0.0D0 +c bad(i,1)=1228.8D0 +c bad(i,2)=1228.8D0 + enddo +#else +C +C 8/9/01 Read the SC-p interaction constants from file +C + do i=1,ntyp + read (iscpp,*,end=118,err=118) (eps_scp(i,j),rscp(i,j),j=1,2) + enddo + do i=1,ntyp + aad(i,1)=dabs(eps_scp(i,1))*rscp(i,1)**12 + aad(i,2)=dabs(eps_scp(i,2))*rscp(i,2)**12 + bad(i,1)=-2*eps_scp(i,1)*rscp(i,1)**6 + bad(i,2)=-2*eps_scp(i,2)*rscp(i,2)**6 + enddo + + if (lprint) then + write (iout,*) "Parameters of SC-p interactions:" + do i=1,20 + write (iout,'(4f8.3,4e12.4)') eps_scp(i,1),rscp(i,1), + & eps_scp(i,2),rscp(i,2),aad(i,1),bad(i,1),aad(i,2),bad(i,2) + enddo + endif +#endif +C +C Define the constants of the disulfide bridge +C + ebr=-5.50D0 +c +c Old arbitrary potential - commented out. +c +c dbr= 4.20D0 +c fbr= 3.30D0 +c +c Constants of the disulfide-bond potential determined based on the RHF/6-31G** +c energy surface of diethyl disulfide. +c A. Liwo and U. Kozlowska, 11/24/03 +c + D0CM = 3.78d0 + AKCM = 15.1d0 + AKTH = 11.0d0 + AKCT = 12.0d0 + V1SS =-1.08d0 + V2SS = 7.61d0 + V3SS = 13.7d0 +c akcm=0.0d0 +c akth=0.0d0 +c akct=0.0d0 +c v1ss=0.0d0 +c v2ss=0.0d0 +c v3ss=0.0d0 + + if(me.eq.king) then + write (iout,'(/a)') "Disulfide bridge parameters:" + write (iout,'(a,f10.2)') 'S-S bridge energy: ',ebr + write (iout,'(2(a,f10.2))') 'd0cm:',d0cm,' akcm:',akcm + write (iout,'(2(a,f10.2))') 'akth:',akth,' akct:',akct + write (iout,'(3(a,f10.2))') 'v1ss:',v1ss,' v2ss:',v2ss, + & ' v3ss:',v3ss + endif + return + 111 write (iout,*) "Error reading bending energy parameters." + goto 999 + 112 write (iout,*) "Error reading rotamer energy parameters." + goto 999 + 113 write (iout,*) "Error reading torsional energy parameters." + goto 999 + 1113 write (iout,*) + & "Error reading side-chain 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_MD-DFA-restraints/pinorm.f b/source/unres/src_MD-DFA-restraints/pinorm.f new file mode 100644 index 0000000..91392bf --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/printmat.f b/source/unres/src_MD-DFA-restraints/printmat.f new file mode 100644 index 0000000..be2b38f --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/prng.f b/source/unres/src_MD-DFA-restraints/prng.f new file mode 100644 index 0000000..73f6766 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/prng.f @@ -0,0 +1,525 @@ + real*8 function prng_next(me) + implicit none + integer me +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) + +c RS6K porting note: ishift now takes 64-bit integers , with a warning + if ( 0.le.me .and. me.le.nmax ) then + next = iparam(1,me)*m + iparam(2,me) + iparam(1,me) = next + prng_next = recip53 * ishft( next, -11 ) + else + prng_next=-1.0D0 + endif + + end +c +c vprng(me, rn, num) Get a vector of random numbers +c + subroutine vprng(me,rn,num) + real*8 recip53, rn(1) + parameter ( recip53 = 2.0D0**(-53) ) + integer*8 m,iparam +c parameter ( m = 34522712143931 ) ! 11**13 + integer nmax, num, me + parameter(nmax=1021) + common/ksrprng/iparam(2,0:nmax) + + integer*8 next + +crc g77 doesn't support integer*8 constants + m = dint(34522712143931.0d0) + + if ( 0.le.me .and. me.le.nmax ) then + do 1 i=1,num + next = iparam(1,me)*m + iparam(2,me) + iparam(1,me) = next + rn(i) = recip53 * ishft( next, -11 ) + 1 continue + else + rn(1)=-1.0D0 + endif + return + end + +c +c prng_chkpnt Get the current state of a generator +c +c Calling sequence: +c logical prng_chkpnt, status +c status = prng_chkpnt (me, iseed) where +c +c me is the particular generator whose state is being gotten +c seed is an 4-element integer array where the "l"-values will be saved +c + logical function prng_chkpnt (me, iseed) + implicit none + integer me + integer*8 iseed + + integer nmax + integer*8 iparam + parameter(nmax=1021) + common/ksrprng/iparam(2,0:nmax) + + if (me .lt. 0 .or. me .gt. nmax) then + prng_chkpnt=.false. + else + prng_chkpnt=.true. + iseed=iparam(1,me) + endif + end +c +c prng_restart Restart generator from a saved state +c +c Calling sequence: +c logical prng_restart, status +c status = prng_restart (me, iseed) where +c +c me is the particular generator being restarted +c iseed is a 8-byte integer containing the "l"-values +c + logical function prng_restart (me, iseed) + implicit none + integer me + integer*8 iseed + + integer nmax + integer*8 iparam + parameter(nmax=1021) + common/ksrprng/iparam(2,0:nmax) + + if (me .lt. 0 .or. me .gt. nmax) then + prng_restart=.false. + return + else + prng_restart=.true. + iparam(1,me)=iseed + endif + end + + block data prngblk + parameter(nmax=1021) + integer*8 iparam + common/ksrprng/iparam(2,0:nmax) + data (iparam(1,i),iparam(2,i),i= 0, 29) / + + 11848219, 11848219, 11848237, 11848237, 11848241, 11848241, + + 11848247, 11848247, 11848253, 11848253, 11848271, 11848271, + + 11848297, 11848297, 11848313, 11848313, 11848339, 11848339, + + 11848351, 11848351, 11848357, 11848357, 11848363, 11848363, + + 11848367, 11848367, 11848373, 11848373, 11848379, 11848379, + + 11848393, 11848393, 11848433, 11848433, 11848451, 11848451, + + 11848469, 11848469, 11848477, 11848477, 11848489, 11848489, + + 11848493, 11848493, 11848513, 11848513, 11848523, 11848523, + + 11848531, 11848531, 11848537, 11848537, 11848553, 11848553, + + 11848589, 11848589, 11848591, 11848591, 11848601, 11848601 / + data (iparam(1,i),iparam(2,i),i= 30, 59) / + + 11848619, 11848619, 11848637, 11848637, 11848663, 11848663, + + 11848673, 11848673, 11848679, 11848679, 11848691, 11848691, + + 11848699, 11848699, 11848709, 11848709, 11848717, 11848717, + + 11848721, 11848721, 11848729, 11848729, 11848741, 11848741, + + 11848751, 11848751, 11848757, 11848757, 11848787, 11848787, + + 11848801, 11848801, 11848829, 11848829, 11848853, 11848853, + + 11848861, 11848861, 11848867, 11848867, 11848873, 11848873, + + 11848891, 11848891, 11848909, 11848909, 11848919, 11848919, + + 11848931, 11848931, 11848937, 11848937, 11848961, 11848961, + + 11848981, 11848981, 11849021, 11849021, 11849039, 11849039 / + data (iparam(1,i),iparam(2,i),i= 60, 89) / + + 11849053, 11849053, 11849059, 11849059, 11849069, 11849069, + + 11849077, 11849077, 11849087, 11849087, 11849093, 11849093, + + 11849107, 11849107, 11849111, 11849111, 11849129, 11849129, + + 11849137, 11849137, 11849177, 11849177, 11849183, 11849183, + + 11849203, 11849203, 11849231, 11849231, 11849237, 11849237, + + 11849239, 11849239, 11849249, 11849249, 11849251, 11849251, + + 11849269, 11849269, 11849273, 11849273, 11849291, 11849291, + + 11849297, 11849297, 11849309, 11849309, 11849339, 11849339, + + 11849359, 11849359, 11849363, 11849363, 11849399, 11849399, + + 11849401, 11849401, 11849413, 11849413, 11849417, 11849417 / + data (iparam(1,i),iparam(2,i),i= 90, 119) / + + 11849437, 11849437, 11849443, 11849443, 11849473, 11849473, + + 11849491, 11849491, 11849503, 11849503, 11849507, 11849507, + + 11849557, 11849557, 11849567, 11849567, 11849569, 11849569, + + 11849573, 11849573, 11849587, 11849587, 11849599, 11849599, + + 11849633, 11849633, 11849641, 11849641, 11849653, 11849653, + + 11849659, 11849659, 11849671, 11849671, 11849683, 11849683, + + 11849689, 11849689, 11849693, 11849693, 11849699, 11849699, + + 11849701, 11849701, 11849707, 11849707, 11849713, 11849713, + + 11849723, 11849723, 11849741, 11849741, 11849743, 11849743, + + 11849759, 11849759, 11849767, 11849767, 11849771, 11849771 / + data (iparam(1,i),iparam(2,i),i= 120, 149) / + + 11849791, 11849791, 11849801, 11849801, 11849809, 11849809, + + 11849813, 11849813, 11849869, 11849869, 11849881, 11849881, + + 11849891, 11849891, 11849909, 11849909, 11849923, 11849923, + + 11849933, 11849933, 11849947, 11849947, 11849987, 11849987, + + 11850001, 11850001, 11850011, 11850011, 11850019, 11850019, + + 11850023, 11850023, 11850031, 11850031, 11850049, 11850049, + + 11850061, 11850061, 11850073, 11850073, 11850077, 11850077, + + 11850103, 11850103, 11850109, 11850109, 11850121, 11850121, + + 11850127, 11850127, 11850133, 11850133, 11850149, 11850149, + + 11850161, 11850161, 11850169, 11850169, 11850191, 11850191 / + data (iparam(1,i),iparam(2,i),i= 150, 179) / + + 11850233, 11850233, 11850247, 11850247, 11850259, 11850259, + + 11850269, 11850269, 11850283, 11850283, 11850301, 11850301, + + 11850341, 11850341, 11850347, 11850347, 11850367, 11850367, + + 11850373, 11850373, 11850379, 11850379, 11850389, 11850389, + + 11850407, 11850407, 11850427, 11850427, 11850437, 11850437, + + 11850469, 11850469, 11850481, 11850481, 11850511, 11850511, + + 11850529, 11850529, 11850541, 11850541, 11850557, 11850557, + + 11850607, 11850607, 11850611, 11850611, 11850667, 11850667, + + 11850677, 11850677, 11850679, 11850679, 11850701, 11850701, + + 11850731, 11850731, 11850739, 11850739, 11850749, 11850749 / + data (iparam(1,i),iparam(2,i),i= 180, 209) / + + 11850791, 11850791, 11850803, 11850803, 11850829, 11850829, + + 11850833, 11850833, 11850859, 11850859, 11850877, 11850877, + + 11850899, 11850899, 11850907, 11850907, 11850913, 11850913, + + 11850919, 11850919, 11850931, 11850931, 11850941, 11850941, + + 11850947, 11850947, 11850953, 11850953, 11850961, 11850961, + + 11850983, 11850983, 11850991, 11850991, 11850997, 11850997, + + 11851031, 11851031, 11851033, 11851033, 11851051, 11851051, + + 11851061, 11851061, 11851067, 11851067, 11851093, 11851093, + + 11851109, 11851109, 11851123, 11851123, 11851127, 11851127, + + 11851139, 11851139, 11851157, 11851157, 11851163, 11851163 / + data (iparam(1,i),iparam(2,i),i= 210, 239) / + + 11851181, 11851181, 11851201, 11851201, 11851219, 11851219, + + 11851291, 11851291, 11851303, 11851303, 11851309, 11851309, + + 11851313, 11851313, 11851319, 11851319, 11851349, 11851349, + + 11851351, 11851351, 11851361, 11851361, 11851373, 11851373, + + 11851403, 11851403, 11851409, 11851409, 11851423, 11851423, + + 11851447, 11851447, 11851451, 11851451, 11851481, 11851481, + + 11851493, 11851493, 11851519, 11851519, 11851523, 11851523, + + 11851529, 11851529, 11851547, 11851547, 11851549, 11851549, + + 11851559, 11851559, 11851577, 11851577, 11851589, 11851589, + + 11851591, 11851591, 11851597, 11851597, 11851603, 11851603 / + data (iparam(1,i),iparam(2,i),i= 240, 269) / + + 11851607, 11851607, 11851613, 11851613, 11851621, 11851621, + + 11851627, 11851627, 11851639, 11851639, 11851673, 11851673, + + 11851681, 11851681, 11851727, 11851727, 11851753, 11851753, + + 11851759, 11851759, 11851787, 11851787, 11851793, 11851793, + + 11851799, 11851799, 11851813, 11851813, 11851841, 11851841, + + 11851859, 11851859, 11851867, 11851867, 11851891, 11851891, + + 11851909, 11851909, 11851919, 11851919, 11851927, 11851927, + + 11851933, 11851933, 11851949, 11851949, 11851967, 11851967, + + 11851997, 11851997, 11852017, 11852017, 11852051, 11852051, + + 11852053, 11852053, 11852059, 11852059, 11852083, 11852083 / + data (iparam(1,i),iparam(2,i),i= 270, 299) / + + 11852089, 11852089, 11852129, 11852129, 11852147, 11852147, + + 11852149, 11852149, 11852161, 11852161, 11852171, 11852171, + + 11852177, 11852177, 11852209, 11852209, 11852221, 11852221, + + 11852237, 11852237, 11852251, 11852251, 11852263, 11852263, + + 11852273, 11852273, 11852279, 11852279, 11852287, 11852287, + + 11852293, 11852293, 11852297, 11852297, 11852303, 11852303, + + 11852311, 11852311, 11852327, 11852327, 11852339, 11852339, + + 11852341, 11852341, 11852359, 11852359, 11852369, 11852369, + + 11852437, 11852437, 11852453, 11852453, 11852459, 11852459, + + 11852473, 11852473, 11852513, 11852513, 11852531, 11852531 / + data (iparam(1,i),iparam(2,i),i= 300, 329) / + + 11852537, 11852537, 11852539, 11852539, 11852557, 11852557, + + 11852573, 11852573, 11852579, 11852579, 11852591, 11852591, + + 11852609, 11852609, 11852611, 11852611, 11852623, 11852623, + + 11852641, 11852641, 11852647, 11852647, 11852657, 11852657, + + 11852663, 11852663, 11852717, 11852717, 11852719, 11852719, + + 11852741, 11852741, 11852759, 11852759, 11852767, 11852767, + + 11852773, 11852773, 11852803, 11852803, 11852807, 11852807, + + 11852809, 11852809, 11852831, 11852831, 11852833, 11852833, + + 11852837, 11852837, 11852857, 11852857, 11852873, 11852873, + + 11852879, 11852879, 11852891, 11852891, 11852917, 11852917 / + data (iparam(1,i),iparam(2,i),i= 330, 359) / + + 11852921, 11852921, 11852957, 11852957, 11852959, 11852959, + + 11852969, 11852969, 11852983, 11852983, 11852989, 11852989, + + 11853001, 11853001, 11853013, 11853013, 11853019, 11853019, + + 11853031, 11853031, 11853089, 11853089, 11853133, 11853133, + + 11853157, 11853157, 11853161, 11853161, 11853181, 11853181, + + 11853203, 11853203, 11853217, 11853217, 11853221, 11853221, + + 11853227, 11853227, 11853241, 11853241, 11853307, 11853307, + + 11853319, 11853319, 11853323, 11853323, 11853329, 11853329, + + 11853367, 11853367, 11853383, 11853383, 11853419, 11853419, + + 11853421, 11853421, 11853427, 11853427, 11853449, 11853449 / + data (iparam(1,i),iparam(2,i),i= 360, 389) / + + 11853451, 11853451, 11853463, 11853463, 11853529, 11853529, + + 11853557, 11853557, 11853571, 11853571, 11853601, 11853601, + + 11853613, 11853613, 11853617, 11853617, 11853629, 11853629, + + 11853649, 11853649, 11853659, 11853659, 11853679, 11853679, + + 11853689, 11853689, 11853719, 11853719, 11853731, 11853731, + + 11853757, 11853757, 11853761, 11853761, 11853773, 11853773, + + 11853791, 11853791, 11853817, 11853817, 11853839, 11853839, + + 11853847, 11853847, 11853857, 11853857, 11853869, 11853869, + + 11853883, 11853883, 11853887, 11853887, 11853889, 11853889, + + 11853893, 11853893, 11853899, 11853899, 11853911, 11853911 / + data (iparam(1,i),iparam(2,i),i= 390, 419) / + + 11853931, 11853931, 11853943, 11853943, 11853979, 11853979, + + 11853991, 11853991, 11854001, 11854001, 11854009, 11854009, + + 11854019, 11854019, 11854057, 11854057, 11854061, 11854061, + + 11854147, 11854147, 11854159, 11854159, 11854163, 11854163, + + 11854169, 11854169, 11854211, 11854211, 11854247, 11854247, + + 11854261, 11854261, 11854267, 11854267, 11854279, 11854279, + + 11854303, 11854303, 11854327, 11854327, 11854331, 11854331, + + 11854333, 11854333, 11854363, 11854363, 11854379, 11854379, + + 11854399, 11854399, 11854411, 11854411, 11854429, 11854429, + + 11854433, 11854433, 11854439, 11854439, 11854441, 11854441 / + data (iparam(1,i),iparam(2,i),i= 420, 449) / + + 11854463, 11854463, 11854477, 11854477, 11854489, 11854489, + + 11854517, 11854517, 11854519, 11854519, 11854523, 11854523, + + 11854529, 11854529, 11854567, 11854567, 11854571, 11854571, + + 11854573, 11854573, 11854603, 11854603, 11854607, 11854607, + + 11854681, 11854681, 11854691, 11854691, 11854709, 11854709, + + 11854723, 11854723, 11854757, 11854757, 11854783, 11854783, + + 11854793, 11854793, 11854813, 11854813, 11854847, 11854847, + + 11854853, 11854853, 11854873, 11854873, 11854877, 11854877, + + 11854883, 11854883, 11854891, 11854891, 11854897, 11854897, + + 11854901, 11854901, 11854919, 11854919, 11854937, 11854937 / + data (iparam(1,i),iparam(2,i),i= 450, 479) / + + 11854961, 11854961, 11854963, 11854963, 11854979, 11854979, + + 11855003, 11855003, 11855017, 11855017, 11855023, 11855023, + + 11855029, 11855029, 11855033, 11855033, 11855111, 11855111, + + 11855141, 11855141, 11855147, 11855147, 11855149, 11855149, + + 11855159, 11855159, 11855177, 11855177, 11855203, 11855203, + + 11855213, 11855213, 11855219, 11855219, 11855231, 11855231, + + 11855267, 11855267, 11855269, 11855269, 11855303, 11855303, + + 11855309, 11855309, 11855321, 11855321, 11855329, 11855329, + + 11855339, 11855339, 11855351, 11855351, 11855353, 11855353, + + 11855357, 11855357, 11855359, 11855359, 11855381, 11855381 / + data (iparam(1,i),iparam(2,i),i= 480, 509) / + + 11855383, 11855383, 11855387, 11855387, 11855399, 11855399, + + 11855407, 11855407, 11855413, 11855413, 11855489, 11855489, + + 11855491, 11855491, 11855507, 11855507, 11855521, 11855521, + + 11855531, 11855531, 11855549, 11855549, 11855551, 11855551, + + 11855567, 11855567, 11855581, 11855581, 11855587, 11855587, + + 11855593, 11855593, 11855633, 11855633, 11855653, 11855653, + + 11855663, 11855663, 11855687, 11855687, 11855689, 11855689, + + 11855699, 11855699, 11855713, 11855713, 11855731, 11855731, + + 11855737, 11855737, 11855743, 11855743, 11855747, 11855747, + + 11855759, 11855759, 11855773, 11855773, 11855801, 11855801 / + data (iparam(1,i),iparam(2,i),i= 510, 539) / + + 11855807, 11855807, 11855813, 11855813, 11855827, 11855827, + + 11855839, 11855839, 11855869, 11855869, 11855881, 11855881, + + 11855903, 11855903, 11855911, 11855911, 11855933, 11855933, + + 11855959, 11855959, 11855989, 11855989, 11855993, 11855993, + + 11855999, 11855999, 11856001, 11856001, 11856023, 11856023, + + 11856049, 11856049, 11856071, 11856071, 11856101, 11856101, + + 11856107, 11856107, 11856113, 11856113, 11856139, 11856139, + + 11856151, 11856151, 11856161, 11856161, 11856179, 11856179, + + 11856193, 11856193, 11856199, 11856199, 11856223, 11856223, + + 11856239, 11856239, 11856263, 11856263, 11856269, 11856269 / + data (iparam(1,i),iparam(2,i),i= 540, 569) / + + 11856281, 11856281, 11856287, 11856287, 11856307, 11856307, + + 11856311, 11856311, 11856329, 11856329, 11856343, 11856343, + + 11856359, 11856359, 11856371, 11856371, 11856373, 11856373, + + 11856409, 11856409, 11856419, 11856419, 11856461, 11856461, + + 11856469, 11856469, 11856473, 11856473, 11856479, 11856479, + + 11856511, 11856511, 11856517, 11856517, 11856541, 11856541, + + 11856547, 11856547, 11856553, 11856553, 11856583, 11856583, + + 11856629, 11856629, 11856641, 11856641, 11856653, 11856653, + + 11856659, 11856659, 11856673, 11856673, 11856697, 11856697, + + 11856709, 11856709, 11856727, 11856727, 11856731, 11856731 / + data (iparam(1,i),iparam(2,i),i= 570, 599) / + + 11856763, 11856763, 11856809, 11856809, 11856811, 11856811, + + 11856821, 11856821, 11856841, 11856841, 11856857, 11856857, + + 11856877, 11856877, 11856883, 11856883, 11856899, 11856899, + + 11856919, 11856919, 11856947, 11856947, 11856953, 11856953, + + 11856979, 11856979, 11857003, 11857003, 11857033, 11857033, + + 11857037, 11857037, 11857039, 11857039, 11857049, 11857049, + + 11857061, 11857061, 11857067, 11857067, 11857073, 11857073, + + 11857081, 11857081, 11857091, 11857091, 11857093, 11857093, + + 11857099, 11857099, 11857123, 11857123, 11857127, 11857127, + + 11857147, 11857147, 11857151, 11857151, 11857193, 11857193 / + data (iparam(1,i),iparam(2,i),i= 600, 629) / + + 11857217, 11857217, 11857229, 11857229, 11857243, 11857243, + + 11857249, 11857249, 11857267, 11857267, 11857277, 11857277, + + 11857291, 11857291, 11857303, 11857303, 11857309, 11857309, + + 11857327, 11857327, 11857331, 11857331, 11857333, 11857333, + + 11857361, 11857361, 11857367, 11857367, 11857369, 11857369, + + 11857393, 11857393, 11857399, 11857399, 11857409, 11857409, + + 11857421, 11857421, 11857423, 11857423, 11857451, 11857451, + + 11857453, 11857453, 11857457, 11857457, 11857477, 11857477, + + 11857481, 11857481, 11857493, 11857493, 11857499, 11857499, + + 11857519, 11857519, 11857523, 11857523, 11857529, 11857529 / + data (iparam(1,i),iparam(2,i),i= 630, 659) / + + 11857543, 11857543, 11857561, 11857561, 11857589, 11857589, + + 11857591, 11857591, 11857613, 11857613, 11857621, 11857621, + + 11857661, 11857661, 11857667, 11857667, 11857693, 11857693, + + 11857697, 11857697, 11857709, 11857709, 11857711, 11857711, + + 11857751, 11857751, 11857753, 11857753, 11857759, 11857759, + + 11857763, 11857763, 11857777, 11857777, 11857787, 11857787, + + 11857793, 11857793, 11857801, 11857801, 11857817, 11857817, + + 11857819, 11857819, 11857831, 11857831, 11857837, 11857837, + + 11857873, 11857873, 11857877, 11857877, 11857883, 11857883, + + 11857889, 11857889, 11857907, 11857907, 11857913, 11857913 / + data (iparam(1,i),iparam(2,i),i= 660, 689) / + + 11857931, 11857931, 11857969, 11857969, 11857991, 11857991, + + 11857999, 11857999, 11858009, 11858009, 11858017, 11858017, + + 11858023, 11858023, 11858029, 11858029, 11858039, 11858039, + + 11858051, 11858051, 11858057, 11858057, 11858059, 11858059, + + 11858101, 11858101, 11858111, 11858111, 11858131, 11858131, + + 11858149, 11858149, 11858159, 11858159, 11858177, 11858177, + + 11858191, 11858191, 11858201, 11858201, 11858227, 11858227, + + 11858243, 11858243, 11858267, 11858267, 11858269, 11858269, + + 11858279, 11858279, 11858281, 11858281, 11858291, 11858291, + + 11858311, 11858311, 11858323, 11858323, 11858359, 11858359 / + data (iparam(1,i),iparam(2,i),i= 690, 719) / + + 11858377, 11858377, 11858381, 11858381, 11858387, 11858387, + + 11858423, 11858423, 11858443, 11858443, 11858447, 11858447, + + 11858479, 11858479, 11858533, 11858533, 11858543, 11858543, + + 11858551, 11858551, 11858557, 11858557, 11858569, 11858569, + + 11858573, 11858573, 11858579, 11858579, 11858597, 11858597, + + 11858599, 11858599, 11858629, 11858629, 11858657, 11858657, + + 11858659, 11858659, 11858683, 11858683, 11858701, 11858701, + + 11858719, 11858719, 11858723, 11858723, 11858729, 11858729, + + 11858747, 11858747, 11858779, 11858779, 11858783, 11858783, + + 11858801, 11858801, 11858807, 11858807, 11858813, 11858813 / + data (iparam(1,i),iparam(2,i),i= 720, 749) / + + 11858839, 11858839, 11858851, 11858851, 11858893, 11858893, + + 11858897, 11858897, 11858921, 11858921, 11858947, 11858947, + + 11858953, 11858953, 11858969, 11858969, 11858971, 11858971, + + 11858989, 11858989, 11859017, 11859017, 11859031, 11859031, + + 11859049, 11859049, 11859061, 11859061, 11859073, 11859073, + + 11859077, 11859077, 11859079, 11859079, 11859083, 11859083, + + 11859101, 11859101, 11859109, 11859109, 11859137, 11859137, + + 11859139, 11859139, 11859151, 11859151, 11859157, 11859157, + + 11859163, 11859163, 11859167, 11859167, 11859179, 11859179, + + 11859187, 11859187, 11859229, 11859229, 11859233, 11859233 / + data (iparam(1,i),iparam(2,i),i= 750, 779) / + + 11859241, 11859241, 11859247, 11859247, 11859269, 11859269, + + 11859293, 11859293, 11859307, 11859307, 11859311, 11859311, + + 11859349, 11859349, 11859359, 11859359, 11859371, 11859371, + + 11859377, 11859377, 11859383, 11859383, 11859427, 11859427, + + 11859433, 11859433, 11859451, 11859451, 11859457, 11859457, + + 11859461, 11859461, 11859473, 11859473, 11859481, 11859481, + + 11859487, 11859487, 11859493, 11859493, 11859503, 11859503, + + 11859509, 11859509, 11859539, 11859539, 11859541, 11859541, + + 11859563, 11859563, 11859569, 11859569, 11859571, 11859571, + + 11859583, 11859583, 11859599, 11859599, 11859611, 11859611 / + data (iparam(1,i),iparam(2,i),i= 780, 809) / + + 11859643, 11859643, 11859707, 11859707, 11859713, 11859713, + + 11859719, 11859719, 11859739, 11859739, 11859751, 11859751, + + 11859791, 11859791, 11859817, 11859817, 11859821, 11859821, + + 11859833, 11859833, 11859847, 11859847, 11859853, 11859853, + + 11859877, 11859877, 11859889, 11859889, 11859893, 11859893, + + 11859901, 11859901, 11859907, 11859907, 11859917, 11859917, + + 11859923, 11859923, 11859929, 11859929, 11859961, 11859961, + + 11859979, 11859979, 11859989, 11859989, 11859997, 11859997, + + 11860021, 11860021, 11860031, 11860031, 11860039, 11860039, + + 11860049, 11860049, 11860081, 11860081, 11860087, 11860087 / + data (iparam(1,i),iparam(2,i),i= 810, 839) / + + 11860097, 11860097, 11860103, 11860103, 11860109, 11860109, + + 11860117, 11860117, 11860133, 11860133, 11860151, 11860151, + + 11860171, 11860171, 11860207, 11860207, 11860223, 11860223, + + 11860231, 11860231, 11860243, 11860243, 11860267, 11860267, + + 11860301, 11860301, 11860307, 11860307, 11860327, 11860327, + + 11860379, 11860379, 11860397, 11860397, 11860411, 11860411, + + 11860469, 11860469, 11860477, 11860477, 11860483, 11860483, + + 11860487, 11860487, 11860489, 11860489, 11860493, 11860493, + + 11860517, 11860517, 11860547, 11860547, 11860567, 11860567, + + 11860573, 11860573, 11860613, 11860613, 11860619, 11860619 / + data (iparam(1,i),iparam(2,i),i= 840, 869) / + + 11860627, 11860627, 11860637, 11860637, 11860643, 11860643, + + 11860649, 11860649, 11860661, 11860661, 11860669, 11860669, + + 11860687, 11860687, 11860691, 11860691, 11860697, 11860697, + + 11860699, 11860699, 11860703, 11860703, 11860727, 11860727, + + 11860741, 11860741, 11860753, 11860753, 11860777, 11860777, + + 11860787, 11860787, 11860789, 11860789, 11860811, 11860811, + + 11860837, 11860837, 11860859, 11860859, 11860867, 11860867, + + 11860889, 11860889, 11860897, 11860897, 11860963, 11860963, + + 11860969, 11860969, 11860973, 11860973, 11860993, 11860993, + + 11861011, 11861011, 11861033, 11861033, 11861071, 11861071 / + data (iparam(1,i),iparam(2,i),i= 870, 899) / + + 11861081, 11861081, 11861089, 11861089, 11861093, 11861093, + + 11861099, 11861099, 11861107, 11861107, 11861131, 11861131, + + 11861141, 11861141, 11861159, 11861159, 11861167, 11861167, + + 11861191, 11861191, 11861197, 11861197, 11861207, 11861207, + + 11861219, 11861219, 11861221, 11861221, 11861231, 11861231, + + 11861237, 11861237, 11861273, 11861273, 11861293, 11861293, + + 11861299, 11861299, 11861303, 11861303, 11861327, 11861327, + + 11861351, 11861351, 11861357, 11861357, 11861363, 11861363, + + 11861371, 11861371, 11861401, 11861401, 11861407, 11861407, + + 11861411, 11861411, 11861413, 11861413, 11861429, 11861429 / + data (iparam(1,i),iparam(2,i),i= 900, 929) / + + 11861441, 11861441, 11861467, 11861467, 11861527, 11861527, + + 11861539, 11861539, 11861543, 11861543, 11861557, 11861557, + + 11861569, 11861569, 11861573, 11861573, 11861579, 11861579, + + 11861581, 11861581, 11861599, 11861599, 11861611, 11861611, + + 11861617, 11861617, 11861627, 11861627, 11861639, 11861639, + + 11861651, 11861651, 11861659, 11861659, 11861671, 11861671, + + 11861683, 11861683, 11861687, 11861687, 11861693, 11861693, + + 11861701, 11861701, 11861711, 11861711, 11861713, 11861713, + + 11861749, 11861749, 11861791, 11861791, 11861803, 11861803, + + 11861819, 11861819, 11861827, 11861827, 11861849, 11861849 / + data (iparam(1,i),iparam(2,i),i= 930, 959) / + + 11861873, 11861873, 11861879, 11861879, 11861887, 11861887, + + 11861911, 11861911, 11861917, 11861917, 11861921, 11861921, + + 11861923, 11861923, 11861953, 11861953, 11861959, 11861959, + + 11861987, 11861987, 11862007, 11862007, 11862013, 11862013, + + 11862029, 11862029, 11862031, 11862031, 11862049, 11862049, + + 11862077, 11862077, 11862083, 11862083, 11862157, 11862157, + + 11862167, 11862167, 11862199, 11862199, 11862203, 11862203, + + 11862217, 11862217, 11862223, 11862223, 11862229, 11862229, + + 11862233, 11862233, 11862239, 11862239, 11862241, 11862241, + + 11862259, 11862259, 11862269, 11862269, 11862271, 11862271 / + data (iparam(1,i),iparam(2,i),i= 960, 989) / + + 11862293, 11862293, 11862307, 11862307, 11862313, 11862313, + + 11862317, 11862317, 11862343, 11862343, 11862353, 11862353, + + 11862373, 11862373, 11862391, 11862391, 11862439, 11862439, + + 11862469, 11862469, 11862493, 11862493, 11862527, 11862527, + + 11862547, 11862547, 11862563, 11862563, 11862569, 11862569, + + 11862577, 11862577, 11862581, 11862581, 11862611, 11862611, + + 11862623, 11862623, 11862661, 11862661, 11862673, 11862673, + + 11862679, 11862679, 11862701, 11862701, 11862703, 11862703, + + 11862713, 11862713, 11862761, 11862761, 11862791, 11862791, + + 11862803, 11862803, 11862839, 11862839, 11862841, 11862841 / + data (iparam(1,i),iparam(2,i),i= 990,1019) / + + 11862857, 11862857, 11862869, 11862869, 11862881, 11862881, + + 11862911, 11862911, 11862919, 11862919, 11862959, 11862959, + + 11862979, 11862979, 11862989, 11862989, 11862997, 11862997, + + 11863021, 11863021, 11863031, 11863031, 11863037, 11863037, + + 11863039, 11863039, 11863057, 11863057, 11863067, 11863067, + + 11863073, 11863073, 11863099, 11863099, 11863109, 11863109, + + 11863121, 11863121, 11863123, 11863123, 11863133, 11863133, + + 11863151, 11863151, 11863153, 11863153, 11863171, 11863171, + + 11863183, 11863183, 11863207, 11863207, 11863213, 11863213, + + 11863237, 11863237, 11863249, 11863249, 11863253, 11863253 / + data (iparam(1,i),iparam(2,i),i=1020,1021) / + + 11863259, 11863259, 11863279, 11863279 / + end diff --git a/source/unres/src_MD-DFA-restraints/prng_32.F b/source/unres/src_MD-DFA-restraints/prng_32.F new file mode 100644 index 0000000..9448f31 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/proc_proc.c b/source/unres/src_MD-DFA-restraints/proc_proc.c new file mode 100644 index 0000000..d77c5a4 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/proc_proc.c @@ -0,0 +1,139 @@ +#include +#include + +#ifdef CRAY +void PROC_PROC(long int *f, int *i) +#else +#ifdef LINUX +#ifdef PGI +void proc_proc_(long int *f, int *i) +#else +void proc_proc__(long int *f, int *i) +#endif +#endif +#ifdef SGI +void proc_proc_(long int *f, int *i) +#endif +#if defined(WIN) && !defined(WINIFL) +void _stdcall PROC_PROC(long int *f, int *i) +#endif +#ifdef WINIFL +void proc_proc(long int *f, int *i) +#endif +#if defined(AIX) || defined(WINPGI) +void proc_proc(long int *f, int *i) +#endif +#endif + +{ +static long int NaNQ; +static long int NaNQm; + +if(*i==-1) + { + NaNQ=*f; + NaNQm=0xffffffff; + return; + } +*i=0; +if(*f==NaNQ) + *i=1; +if(*f==NaNQm) + *i=1; +} + +#ifdef CRAY +void PROC_CONV(char *buf, int *i, int n) +#endif +#ifdef LINUX +void proc_conv__(char *buf, int *i, int n) +#endif +#ifdef SGI +void proc_conv_(char *buf, int *i, int n) +#endif +#if defined(AIX) || defined(WINPGI) +void proc_conv(char *buf, int *i, int n) +#endif +#ifdef WIN +void _stdcall PROC_CONV(char *buf, int *i, int n) +#endif +{ +int j; + +sscanf(buf,"%d",&j); +*i=j; +return; +} + +#ifdef CRAY +void PROC_CONV_R(char *buf, int *i, int n) +#endif +#ifdef LINUX +void proc_conv_r__(char *buf, int *i, int n) +#endif +#ifdef SGI +void proc_conv_r_(char *buf, int *i, int n) +#endif +#if defined(AIX) || defined(WINPGI) +void proc_conv_r(char *buf, int *i, int n) +#endif +#ifdef WIN +void _stdcall PROC_CONV_R(char *buf, int *i, int n) +#endif + +{ + +/* sprintf(buf,"%d",*i); */ + +return; +} + + +#ifndef IMSL +#ifdef CRAY +void DSVRGP(int *n, double *tab1, double *tab2, int *itab) +#endif +#ifdef LINUX +void dsvrgp__(int *n, double *tab1, double *tab2, int *itab) +#endif +#ifdef SGI +void dsvrgp_(int *n, double *tab1, double *tab2, int *itab) +#endif +#if defined(AIX) || defined(WINPGI) +void dsvrgp(int *n, double *tab1, double *tab2, int *itab) +#endif +#ifdef WIN +void _stdcall DSVRGP(int *n, double *tab1, double *tab2, int *itab) +#endif +{ +double t; +int i,j,k; + +if(tab1 != tab2) + { + for(i=0; i<*n; i++) + tab2[i]=tab1[i]; + } +k=0; +while(k<*n-1) + { + j=k; + t=tab2[k]; + for(i=k+1; i<*n; i++) + if(t>tab2[i]) + { + j=i; + t=tab2[i]; + } + if(j!=k) + { + tab2[j]=tab2[k]; + tab2[k]=t; + i=itab[j]; + itab[j]=itab[k]; + itab[k]=i; + } + k++; + } +} +#endif diff --git a/source/unres/src_MD-DFA-restraints/q_measure.F b/source/unres/src_MD-DFA-restraints/q_measure.F new file mode 100644 index 0000000..417cf35 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/q_measure.F @@ -0,0 +1,487 @@ + double precision function qwolynes(seg1,seg2,flag,seg3,seg4) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + integer i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4, + & secseg + integer nsep /3/ + double precision dist,qm + double precision qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM + logical lprn /.false./ + logical flag + double precision sigm,x + sigm(x)=0.25d0*x + qq = 0.0d0 + nl=0 + if(flag) then + do il=seg1+nsep,seg2 + do jl=seg1,il-nsep + nl=nl+1 + d0ij=dsqrt((cref(1,jl)-cref(1,il))**2+ + & (cref(2,jl)-cref(2,il))**2+ + & (cref(3,jl)-cref(3,il))**2) + dij=dist(il,jl) + qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2) + if (itype(il).ne.10 .or. itype(jl).ne.10) then + nl=nl+1 + d0ijCM=dsqrt( + & (cref(1,jl+nres)-cref(1,il+nres))**2+ + & (cref(2,jl+nres)-cref(2,il+nres))**2+ + & (cref(3,jl+nres)-cref(3,il+nres))**2) + dijCM=dist(il+nres,jl+nres) + qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2) + endif + qq = qq+qqij+qqijCM + enddo + enddo + qq = qq/nl + else + do il=seg1,seg2 + if((seg3-il).lt.3) then + secseg=il+3 + else + secseg=seg3 + endif + do jl=secseg,seg4 + nl=nl+1 + d0ij=dsqrt((cref(1,jl)-cref(1,il))**2+ + & (cref(2,jl)-cref(2,il))**2+ + & (cref(3,jl)-cref(3,il))**2) + dij=dist(il,jl) + qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2) + if (itype(il).ne.10 .or. itype(jl).ne.10) then + nl=nl+1 + d0ijCM=dsqrt( + & (cref(1,jl+nres)-cref(1,il+nres))**2+ + & (cref(2,jl+nres)-cref(2,il+nres))**2+ + & (cref(3,jl+nres)-cref(3,il+nres))**2) + dijCM=dist(il+nres,jl+nres) + qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2) + endif + qq = qq+qqij+qqijCM + enddo + enddo + qq = qq/nl + endif + qwolynes=1.0d0-qq + return + end +c------------------------------------------------------------------- + subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.MD' + integer i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4, + & secseg + integer nsep /3/ + double precision dist + double precision dij,d0ij,dijCM,d0ijCM + logical lprn /.false./ + logical flag + double precision sigm,x,sim,dd0,fac,ddqij + sigm(x)=0.25d0*x + + do i=0,nres + do j=1,3 + dqwol(j,i)=0.0d0 + dxqwol(j,i)=0.0d0 + enddo + enddo + nl=0 + if(flag) then + do il=seg1+nsep,seg2 + do jl=seg1,il-nsep + nl=nl+1 + d0ij=dsqrt((cref(1,jl)-cref(1,il))**2+ + & (cref(2,jl)-cref(2,il))**2+ + & (cref(3,jl)-cref(3,il))**2) + dij=dist(il,jl) + sim = 1.0d0/sigm(d0ij) + sim = sim*sim + dd0 = dij-d0ij + fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim) + do k=1,3 + ddqij = (c(k,il)-c(k,jl))*fac + dqwol(k,il)=dqwol(k,il)+ddqij + dqwol(k,jl)=dqwol(k,jl)-ddqij + enddo + + if (itype(il).ne.10 .or. itype(jl).ne.10) then + nl=nl+1 + d0ijCM=dsqrt( + & (cref(1,jl+nres)-cref(1,il+nres))**2+ + & (cref(2,jl+nres)-cref(2,il+nres))**2+ + & (cref(3,jl+nres)-cref(3,il+nres))**2) + dijCM=dist(il+nres,jl+nres) + sim = 1.0d0/sigm(d0ijCM) + sim = sim*sim + dd0=dijCM-d0ijCM + fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim) + do k=1,3 + ddqij = (c(k,il+nres)-c(k,jl+nres))*fac + dxqwol(k,il)=dxqwol(k,il)+ddqij + dxqwol(k,jl)=dxqwol(k,jl)-ddqij + enddo + endif + enddo + enddo + else + do il=seg1,seg2 + if((seg3-il).lt.3) then + secseg=il+3 + else + secseg=seg3 + endif + do jl=secseg,seg4 + nl=nl+1 + d0ij=dsqrt((cref(1,jl)-cref(1,il))**2+ + & (cref(2,jl)-cref(2,il))**2+ + & (cref(3,jl)-cref(3,il))**2) + dij=dist(il,jl) + sim = 1.0d0/sigm(d0ij) + sim = sim*sim + dd0 = dij-d0ij + fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim) + do k=1,3 + ddqij = (c(k,il)-c(k,jl))*fac + dqwol(k,il)=dqwol(k,il)+ddqij + dqwol(k,jl)=dqwol(k,jl)-ddqij + enddo + if (itype(il).ne.10 .or. itype(jl).ne.10) then + nl=nl+1 + d0ijCM=dsqrt( + & (cref(1,jl+nres)-cref(1,il+nres))**2+ + & (cref(2,jl+nres)-cref(2,il+nres))**2+ + & (cref(3,jl+nres)-cref(3,il+nres))**2) + dijCM=dist(il+nres,jl+nres) + sim = 1.0d0/sigm(d0ijCM) + sim=sim*sim + dd0 = dijCM-d0ijCM + fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim) + do k=1,3 + ddqij = (c(k,il+nres)-c(k,jl+nres))*fac + dxqwol(k,il)=dxqwol(k,il)+ddqij + dxqwol(k,jl)=dxqwol(k,jl)-ddqij + enddo + endif + enddo + enddo + endif + do i=0,nres + do j=1,3 + dqwol(j,i)=dqwol(j,i)/nl + dxqwol(j,i)=dxqwol(j,i)/nl + enddo + enddo + return + end +c------------------------------------------------------------------- + subroutine qwol_num(seg1,seg2,flag,seg3,seg4) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + integer seg1,seg2,seg3,seg4 + logical flag + double precision qwolan(3,0:maxres),cdummy(3,0:maxres2), + & qwolxan(3,0:maxres),q1,q2 + double precision delta /1.0d-10/ + do i=0,nres + do j=1,3 + q1=qwolynes(seg1,seg2,flag,seg3,seg4) + cdummy(j,i)=c(j,i) + c(j,i)=c(j,i)+delta + q2=qwolynes(seg1,seg2,flag,seg3,seg4) + qwolan(j,i)=(q2-q1)/delta + c(j,i)=cdummy(j,i) + enddo + enddo + do i=0,nres + do j=1,3 + q1=qwolynes(seg1,seg2,flag,seg3,seg4) + cdummy(j,i+nres)=c(j,i+nres) + c(j,i+nres)=c(j,i+nres)+delta + q2=qwolynes(seg1,seg2,flag,seg3,seg4) + qwolxan(j,i)=(q2-q1)/delta + c(j,i+nres)=cdummy(j,i+nres) + enddo + enddo +c write(iout,*) "Numerical Q carteisan gradients backbone: " +c do i=0,nct +c write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3) +c enddo +c write(iout,*) "Numerical Q carteisan gradients side-chain: " +c do i=0,nct +c write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3) +c enddo + return + end +c------------------------------------------------------------------------ + subroutine EconstrQ +c MD with umbrella_sampling using Wolyne's distance measure as a constraint + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' +#ifndef LANG0 + include 'COMMON.LANGEVIN' +#else + include 'COMMON.LANGEVIN.lang0' +#endif + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.TIME1' + double precision uzap1,uzap2,hm1,hm2,hmnum + double precision ucdelan,dUcartan(3,0:MAXRES) + & ,dUxcartan(3,0:MAXRES),cdummy(3,0:MAXRES), + & duconst(3,0:MAXRES),duxconst(3,0:MAXRES) + integer kstart,kend,lstart,lend,idummy + double precision delta /1.0d-7/ + do i=0,nres + do j=1,3 + duconst(j,i)=0.0d0 + dudconst(j,i)=0.0d0 + duxconst(j,i)=0.0d0 + dudxconst(j,i)=0.0d0 + enddo + enddo + Uconst=0.0d0 + do i=1,nfrag + qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true. + & ,idummy,idummy) + Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset)) +c Calculating the derivatives of Constraint energy with respect to Q + Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i), + & qinfrag(i,iset)) +c hm1=harmonic(qfrag(i,iset),qinfrag(i,iset)) +c hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset)) +c hmnum=(hm2-hm1)/delta +c write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset), +c & qinfrag(i,iset)) +c write(iout,*) "harmonicnum frag", hmnum +c Calculating the derivatives of Q with respect to cartesian coordinates + call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true. + & ,idummy,idummy) +c write(iout,*) "dqwol " +c do ii=1,nres +c write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3) +c enddo +c write(iout,*) "dxqwol " +c do ii=1,nres +c write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3) +c enddo +c Calculating numerical gradients of dU/dQi and dQi/dxi +c call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true. +c & ,idummy,idummy) +c The gradients of Uconst in Cs + do ii=0,nres + do j=1,3 + duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii) + dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii) + enddo + enddo + enddo + do i=1,npair + kstart=ifrag(1,ipair(1,i,iset),iset) + kend=ifrag(2,ipair(1,i,iset),iset) + lstart=ifrag(1,ipair(2,i,iset),iset) + lend=ifrag(2,ipair(2,i,iset),iset) + qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend) + Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset)) +c Calculating dU/dQ + Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset)) +c hm1=harmonic(qpair(i),qinpair(i,iset)) +c hm2=harmonic(qpair(i)+delta,qinpair(i,iset)) +c hmnum=(hm2-hm1)/delta +c write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i), +c & qinpair(i,iset)) +c write(iout,*) "harmonicnum pair ", hmnum +c Calculating dQ/dXi + call qwolynes_prim(kstart,kend,.false. + & ,lstart,lend) +c write(iout,*) "dqwol " +c do ii=1,nres +c write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3) +c enddo +c write(iout,*) "dxqwol " +c do ii=1,nres +c write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3) +c enddo +c Calculating numerical gradients +c call qwol_num(kstart,kend,.false. +c & ,lstart,lend) +c The gradients of Uconst in Cs + do ii=0,nres + do j=1,3 + duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii) + dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii) + enddo + enddo + enddo +c write(iout,*) "Uconst inside subroutine ", Uconst +c Transforming the gradients from Cs to dCs for the backbone + do i=0,nres + do j=i+1,nres + do k=1,3 + dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j) + enddo + enddo + enddo +c Transforming the gradients from Cs to dCs for the side chains + do i=1,nres + do j=1,3 + dudxconst(j,i)=duxconst(j,i) + enddo + enddo +c write(iout,*) "dU/ddc backbone " +c do ii=0,nres +c write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3) +c enddo +c write(iout,*) "dU/ddX side chain " +c do ii=1,nres +c write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3) +c enddo +c Calculating numerical gradients of dUconst/ddc and dUconst/ddx +c call dEconstrQ_num + return + end +c----------------------------------------------------------------------- + subroutine dEconstrQ_num +c Calculating numerical dUconst/ddc and dUconst/ddx + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' +#ifndef LANG0 + include 'COMMON.LANGEVIN' +#else + include 'COMMON.LANGEVIN.lang0' +#endif + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.TIME1' + double precision uzap1,uzap2 + double precision dUcartan(3,0:MAXRES) + & ,dUxcartan(3,0:MAXRES),cdummy(3,0:MAXRES) + integer kstart,kend,lstart,lend,idummy + double precision delta /1.0d-7/ +c For the backbone + do i=0,nres-1 + do j=1,3 + dUcartan(j,i)=0.0d0 + cdummy(j,i)=dc(j,i) + dc(j,i)=dc(j,i)+delta + call chainbuild_cart + uzap2=0.0d0 + do ii=1,nfrag + qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true. + & ,idummy,idummy) + uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii), + & qinfrag(ii,iset)) + enddo + do ii=1,npair + kstart=ifrag(1,ipair(1,ii,iset),iset) + kend=ifrag(2,ipair(1,ii,iset),iset) + lstart=ifrag(1,ipair(2,ii,iset),iset) + lend=ifrag(2,ipair(2,ii,iset),iset) + qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) + uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii), + & qinpair(ii,iset)) + enddo + dc(j,i)=cdummy(j,i) + call chainbuild_cart + uzap1=0.0d0 + do ii=1,nfrag + qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true. + & ,idummy,idummy) + uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii), + & qinfrag(ii,iset)) + enddo + do ii=1,npair + kstart=ifrag(1,ipair(1,ii,iset),iset) + kend=ifrag(2,ipair(1,ii,iset),iset) + lstart=ifrag(1,ipair(2,ii,iset),iset) + lend=ifrag(2,ipair(2,ii,iset),iset) + qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) + uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii), + & qinpair(ii,iset)) + enddo + ducartan(j,i)=(uzap2-uzap1)/(delta) + enddo + enddo +c Calculating numerical gradients for dU/ddx + do i=0,nres-1 + duxcartan(j,i)=0.0d0 + do j=1,3 + cdummy(j,i)=dc(j,i+nres) + dc(j,i+nres)=dc(j,i+nres)+delta + call chainbuild_cart + uzap2=0.0d0 + do ii=1,nfrag + qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true. + & ,idummy,idummy) + uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii), + & qinfrag(ii,iset)) + enddo + do ii=1,npair + kstart=ifrag(1,ipair(1,ii,iset),iset) + kend=ifrag(2,ipair(1,ii,iset),iset) + lstart=ifrag(1,ipair(2,ii,iset),iset) + lend=ifrag(2,ipair(2,ii,iset),iset) + qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) + uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii), + & qinpair(ii,iset)) + enddo + dc(j,i+nres)=cdummy(j,i) + call chainbuild_cart + uzap1=0.0d0 + do ii=1,nfrag + qfrag(ii)=qwolynes(ifrag(1,ii,iset), + & ifrag(2,ii,iset),.true.,idummy,idummy) + uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii), + & qinfrag(ii,iset)) + enddo + do ii=1,npair + kstart=ifrag(1,ipair(1,ii,iset),iset) + kend=ifrag(2,ipair(1,ii,iset),iset) + lstart=ifrag(1,ipair(2,ii,iset),iset) + lend=ifrag(2,ipair(2,ii,iset),iset) + qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) + uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii), + & qinpair(ii,iset)) + enddo + duxcartan(j,i)=(uzap2-uzap1)/(delta) + enddo + enddo + write(iout,*) "Numerical dUconst/ddc backbone " + do ii=0,nres + write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3) + enddo +c write(iout,*) "Numerical dUconst/ddx side-chain " +c do ii=1,nres +c write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3) +c enddo + return + end +c--------------------------------------------------------------------------- diff --git a/source/unres/src_MD-DFA-restraints/q_measure1.F b/source/unres/src_MD-DFA-restraints/q_measure1.F new file mode 100644 index 0000000..9c1546d --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/q_measure1.F @@ -0,0 +1,470 @@ + double precision function qwolynes(seg1,seg2,flag,seg3,seg4) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.MD' + integer i,j,jl,k,l,il,kl,nl,np,seg1,seg2,seg3,seg4,secseg + integer nsep /3/ + double precision dist,qm + double precision qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM + logical lprn /.false./ + logical flag + qq = 0.0d0 + nl=0 + do i=0,nres + do j=1,3 + dqwol(j,i)=0.0d0 + dxqwol(j,i)=0.0d0 + enddo + enddo + if (lprn) then + write (iout,*) "seg1",seg1," seg2",seg2," seg3",seg3," seg4",seg4, + & " flag",flag + call flush(iout) + endif + if (flag) then + do il=seg1+nsep,seg2 + do jl=seg1,il-nsep + nl=nl+1 + if (itype(il).ne.10) then + ilnres=il+nres + else + ilnres=il + endif + if (itype(jl).ne.10) then + jlnres=jl+nres + else + jlnres=jl + endif + qqijCM = qcontrib(il,jl,ilnres,jlnres) + qq = qq+qqijCM + if (lprn) then + write (iout,*) "qqijCM",qqijCM + call flush(iout) + endif + enddo + enddo + if (lprn) then + write (iout,*) "nl",nl," qq",qq + call flush(iout) + endif + else + do il=seg1,seg2 + if((seg3-il).lt.3) then + secseg=il+3 + else + secseg=seg3 + endif + do jl=secseg,seg4 + nl=nl+1 + if (itype(il).ne.10) then + ilnres=il+nres + else + ilnres=il + endif + if (itype(jl).ne.10) then + jlnres=jl+nres + else + jlnres=jl + endif + qqijCM = qcontrib(il,jl,ilnres,jlnres) + qq = qq+qqijCM + if (lprn) then + write (iout,*) "qqijCM",qqijCM + call flush(iout) + endif + enddo + enddo + endif + qq = qq/nl + qwolynes=1.0d0-qq + do i=0,nres + do j=1,3 + dqwol(j,i)=dqwol(j,i)/nl + dxqwol(j,i)=dxqwol(j,i)/nl + enddo + enddo + return + end +c------------------------------------------------------------------- + subroutine qwol_num(seg1,seg2,flag,seg3,seg4) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.MD' + integer seg1,seg2,seg3,seg4 + logical flag + double precision qwolan(3,0:maxres),cdummy(3,0:maxres2), + & qwolxan(3,0:maxres),q1,q2 + double precision delta /1.0d-7/ + write (iout,*) "seg1",seg1," seg2",seg2," seg3",seg3," seg4",seg4 + write(iout,*) "dQ/dc backbone " + do i=0,nres + write(iout,'(i5,3e15.5)') i, (dqwol(j,i),j=1,3) + enddo + write(iout,*) "dQ/dX side chain " + do i=1,nres + write(iout,'(i5,3e15.5)') i,(dxqwol(j,i),j=1,3) + enddo + do i=1,nres + do j=1,3 + cdummy(j,i)=c(j,i) + c(j,i)=c(j,i)-delta + q1=qwolynes(seg1,seg2,flag,seg3,seg4) + c(j,i)=cdummy(j,i)+delta + q2=qwolynes(seg1,seg2,flag,seg3,seg4) + qwolan(j,i)=0.5d0*(q2-q1)/delta + c(j,i)=cdummy(j,i) +c write (iout,*) "i",i," j",j," q1",q1," a2",q2 + enddo + enddo + do i=1,nres + do j=1,3 + cdummy(j,i+nres)=c(j,i+nres) + c(j,i+nres)=c(j,i+nres)-delta + q1=qwolynes(seg1,seg2,flag,seg3,seg4) + c(j,i+nres)=cdummy(j,i+nres)+delta + q2=qwolynes(seg1,seg2,flag,seg3,seg4) + qwolxan(j,i)=0.5d0*(q2-q1)/delta + c(j,i+nres)=cdummy(j,i+nres) + enddo + enddo + write(iout,*) "Numerical Q cartesian gradients backbone: " + do i=0,nres + write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3) + enddo + write(iout,*) "Numerical Q cartesian gradients side-chain: " + do i=0,nres + write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3) + enddo + return + end +c------------------------------------------------------------------------ + subroutine EconstrQ +c MD with umbrella_sampling using Wolyne's distance measure as a constraint + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' +#ifndef LANG0 + include 'COMMON.LANGEVIN' +#else + include 'COMMON.LANGEVIN.lang0' +#endif + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.TIME1' + double precision uzap1,uzap2,hm1,hm2,hmnum + double precision ucdelan,dUcartan(3,0:MAXRES) + & ,dUxcartan(3,0:MAXRES),cdummy(3,0:MAXRES), + & duconst(3,0:MAXRES),duxconst(3,0:MAXRES) + integer kstart,kend,lstart,lend,idummy + double precision delta /1.0d-7/ + do i=0,nres + do j=1,3 + duconst(j,i)=0.0d0 + dudconst(j,i)=0.0d0 + duxconst(j,i)=0.0d0 + dudxconst(j,i)=0.0d0 + enddo + enddo + Uconst=0.0d0 + do i=1,nfrag + qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true. + & ,idummy,idummy) + Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset)) +c Calculating the derivatives of Constraint energy with respect to Q + Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),qinfrag(i,iset)) +c Calculating the derivatives of Q with respect to cartesian coordinates + do ii=0,nres + do j=1,3 + duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii) + dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii) + enddo + enddo +c write (iout,*) "Calling qwol_num" +c call qwol_num(ifrag(1,i),ifrag(2,i),.true.,idummy,idummy) + enddo + do i=1,npair + kstart=ifrag(1,ipair(1,i,iset),iset) + kend=ifrag(2,ipair(1,i,iset),iset) + lstart=ifrag(1,ipair(2,i,iset),iset) + lend=ifrag(2,ipair(2,i,iset),iset) + qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend) + Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset)) +c Calculating dU/dQ + Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset)) +c Calculating dQ/dXi + do ii=0,nres + do j=1,3 + duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii) + dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii) + enddo + enddo + enddo +c write(iout,*) "Uconst inside subroutine ", Uconst +c Transforming the gradients from Cs to dCs for the backbone + do i=0,nres + do j=i+1,nres + do k=1,3 + dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j) + enddo + enddo + enddo +c Transforming the gradients from Cs to dCs for the side chains + do i=1,nres + do j=1,3 + dudxconst(j,i)=duxconst(j,i) + enddo + enddo +c write(iout,*) "dU/dc backbone " +c do ii=0,nres +c write(iout,'(i5,3e15.5)') ii, (duconst(j,ii),j=1,3) +c enddo +c write(iout,*) "dU/dX side chain " +c do ii=1,nres +c write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3) +c enddo +c write(iout,*) "dU/ddc backbone " +c do ii=0,nres +c write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3) +c enddo +c write(iout,*) "dU/ddX side chain " +c do ii=1,nres +c write(iout,'(i5,3e15.5)') ii,(dudxconst(j,ii),j=1,3) +c enddo +c Calculating numerical gradients of dUconst/ddc and dUconst/ddx +c call dEconstrQ_num + return + end +c----------------------------------------------------------------------- + subroutine dEconstrQ_num +c Calculating numerical dUconst/ddc and dUconst/ddx + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' +#ifndef LANG0 + include 'COMMON.LANGEVIN' +#else + include 'COMMON.LANGEVIN.lang0' +#endif + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.TIME1' + double precision uzap1,uzap2 + double precision dUcartan(3,0:MAXRES) + & ,dUxcartan(3,0:MAXRES),cdummy(3,0:MAXRES) + integer kstart,kend,lstart,lend,idummy + double precision delta /1.0d-7/ +c For the backbone + do i=0,nres-1 + do j=1,3 + dUcartan(j,i)=0.0d0 + cdummy(j,i)=dc(j,i) + dc(j,i)=dc(j,i)+delta + call chainbuild_cart + uzap2=0.0d0 + do ii=1,nfrag + qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset), + & .true.,idummy,idummy) + uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii), + & qinfrag(ii,iset)) + enddo + do ii=1,npair + kstart=ifrag(1,ipair(1,ii,iset),iset) + kend=ifrag(2,ipair(1,ii,iset),iset) + lstart=ifrag(1,ipair(2,ii,iset),iset) + lend=ifrag(2,ipair(2,ii,iset),iset) + qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) + uzap2=uzap2+wpair(ii,iset)* + & harmonic(qpair(ii),qinpair(ii,iset)) + enddo + dc(j,i)=cdummy(j,i) + call chainbuild_cart + uzap1=0.0d0 + do ii=1,nfrag + qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset), + & .true.,idummy,idummy) + uzap1=uzap1+wfrag(ii,iset)* + & harmonic(qfrag(ii),qinfrag(ii,iset)) + enddo + do ii=1,npair + kstart=ifrag(1,ipair(1,ii,iset),iset) + kend=ifrag(2,ipair(1,ii,iset),iset) + lstart=ifrag(1,ipair(2,ii,iset),iset) + lend=ifrag(2,ipair(2,ii,iset),iset) + qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) + uzap1=uzap1+wpair(ii,iset)* + & harmonic(qpair(ii),qinpair(ii,iset)) + enddo + ducartan(j,i)=(uzap2-uzap1)/(delta) + enddo + enddo +c Calculating numerical gradients for dU/ddx + do i=0,nres-1 + do j=1,3 + duxcartan(j,i)=0.0d0 + enddo + do j=1,3 + cdummy(j,i)=dc(j,i+nres) + dc(j,i+nres)=dc(j,i+nres)+delta + call chainbuild_cart + uzap2=0.0d0 + do ii=1,nfrag + qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset), + & .true.,idummy,idummy) + uzap2=uzap2+wfrag(ii,iset)* + & harmonic(qfrag(ii),qinfrag(ii,iset)) + enddo + do ii=1,npair + kstart=ifrag(1,ipair(1,ii,iset),iset) + kend=ifrag(2,ipair(1,ii,iset),iset) + lstart=ifrag(1,ipair(2,ii,iset),iset) + lend=ifrag(2,ipair(2,ii,iset),iset) + qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) + uzap2=uzap2+wpair(ii,iset)* + & harmonic(qpair(ii),qinpair(ii,iset)) + enddo + dc(j,i+nres)=cdummy(j,i) + call chainbuild_cart + uzap1=0.0d0 + do ii=1,nfrag + qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset), + & .true.,idummy,idummy) + uzap1=uzap1+wfrag(ii,iset)* + & harmonic(qfrag(ii),qinfrag(ii,iset)) + enddo + do ii=1,npair + kstart=ifrag(1,ipair(1,ii,iset),iset) + kend=ifrag(2,ipair(1,ii,iset),iset) + lstart=ifrag(1,ipair(2,ii,iset),iset) + lend=ifrag(2,ipair(2,ii,iset),iset) + qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) + uzap1=uzap1+wpair(ii,iset)* + & harmonic(qpair(ii),qinpair(ii,iset)) + enddo + duxcartan(j,i)=(uzap2-uzap1)/(delta) + enddo + enddo + write(iout,*) "Numerical dUconst/ddc backbone " + do ii=0,nres + write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3) + enddo + write(iout,*) "Numerical dUconst/ddx side-chain " + do ii=1,nres + write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3) + enddo + return + end +c--------------------------------------------------------------------------- + double precision function qcontrib(il,jl,il1,jl1) + implicit none + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.MD' + integer i,j,k,il,jl,il1,jl1,nd + double precision dist + external dist + double precision dij1,dij2,dij3,dij4,d0ij1,d0ij2,d0ij3,d0ij4,fac, + & fac1,ddave,ssij,ddqij + logical lprn /.false./ + d0ij1=dsqrt((cref(1,jl)-cref(1,il))**2+ + & (cref(2,jl)-cref(2,il))**2+ + & (cref(3,jl)-cref(3,il))**2) + dij1=dist(il,jl) + ddave=(dij1-d0ij1)**2 + nd=1 + if (jl1.ne.jl) then + d0ij2=dsqrt((cref(1,jl1)-cref(1,il))**2+ + & (cref(2,jl1)-cref(2,il))**2+ + & (cref(3,jl1)-cref(3,il))**2) + dij2=dist(il,jl1) + ddave=ddave+(dij2-d0ij2)**2 + nd=nd+1 + endif + if (il1.ne.il) then + d0ij3=dsqrt((cref(1,jl)-cref(1,il1))**2+ + & (cref(2,jl)-cref(2,il1))**2+ + & (cref(3,jl)-cref(3,il1))**2) + dij3=dist(il1,jl) + ddave=ddave+(dij3-d0ij3)**2 + nd=nd+1 + endif + if (il1.ne.il .and. jl1.ne.jl) then + d0ij4=dsqrt((cref(1,jl1)-cref(1,il1))**2+ + & (cref(2,jl1)-cref(2,il1))**2+ + & (cref(3,jl1)-cref(3,il1))**2) + dij4=dist(il1,jl1) + ddave=ddave+(dij4-d0ij4)**2 + nd=nd+1 + endif + ddave=ddave/nd + if (lprn) then + write (iout,*) "il",il," jl",jl, + & " itype",itype(il),itype(jl)," nd",nd + write (iout,*)"d0ij",d0ij1,d0ij2,d0ij3,d0ij4, + & " dij",dij1,dij2,dij3,dij4," ddave",ddave + call flush(iout) + endif +c ssij = (0.25d0*d0ij1)**2 + if (il.ne.il1 .and. jl.ne.jl1) then + ssij = 16.0d0/(d0ij1*d0ij4) + else + ssij = 16.0d0/(d0ij1*d0ij1) + endif + qcontrib = dexp(-0.5d0*ddave*ssij) +c Compute gradient + fac1 = qcontrib*ssij/nd + fac = fac1*(dij1-d0ij1)/dij1 + do k=1,3 + ddqij = (c(k,il)-c(k,jl))*fac + dqwol(k,il)=dqwol(k,il)+ddqij + dqwol(k,jl)=dqwol(k,jl)-ddqij + enddo + if (jl1.ne.jl) then + fac = fac1*(dij2-d0ij2)/dij2 + do k=1,3 + ddqij = (c(k,il)-c(k,jl1))*fac + dqwol(k,il)=dqwol(k,il)+ddqij + dxqwol(k,jl)=dxqwol(k,jl)-ddqij + enddo + endif + if (il1.ne.il) then + fac = fac1*(dij3-d0ij3)/dij3 + do k=1,3 + ddqij = (c(k,il1)-c(k,jl))*fac + dxqwol(k,il)=dxqwol(k,il)+ddqij + dqwol(k,jl)=dqwol(k,jl)-ddqij + enddo + endif + if (il1.ne.il .and. jl1.ne.jl) then + fac = fac1*(dij4-d0ij4)/dij4 + do k=1,3 + ddqij = (c(k,il1)-c(k,jl1))*fac + dxqwol(k,il)=dxqwol(k,il)+ddqij + dxqwol(k,jl)=dxqwol(k,jl)-ddqij + enddo + endif + return + end diff --git a/source/unres/src_MD-DFA-restraints/q_measure3.F b/source/unres/src_MD-DFA-restraints/q_measure3.F new file mode 100644 index 0000000..f0a030e --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/q_measure3.F @@ -0,0 +1,529 @@ + double precision function qwolynes(seg1,seg2,flag,seg3,seg4) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.MD' + integer i,j,jl,k,l,il,kl,nl,np,seg1,seg2,seg3,seg4,secseg + integer nsep /3/ + double precision dist,qm + double precision qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM + logical lprn /.false./ + logical flag + qq = 0.0d0 + nl=0 + do i=0,nres + do j=1,3 + dqwol(j,i)=0.0d0 + dxqwol(j,i)=0.0d0 + enddo + enddo + if (lprn) then + write (iout,*) "seg1",seg1," seg2",seg2," seg3",seg3," seg4",seg4, + & " flag",flag + call flush(iout) + endif + if (flag) then + do il=seg1+nsep,seg2 + do jl=seg1,il-nsep + nl=nl+1 + if (itype(il).ne.10) then + ilnres=il+nres + else + ilnres=il + endif + if (itype(jl).ne.10) then + jlnres=jl+nres + else + jlnres=jl + endif + qqijCM = qcontrib(il,jl,ilnres,jlnres) + qq = qq+qqijCM + if (lprn) then + write (iout,*) "qqijCM",qqijCM + call flush(iout) + endif + enddo + enddo + if (lprn) then + write (iout,*) "nl",nl," qq",qq + call flush(iout) + endif + else + do il=seg1,seg2 + if((seg3-il).lt.3) then + secseg=il+3 + else + secseg=seg3 + endif + do jl=secseg,seg4 + nl=nl+1 + if (itype(il).ne.10) then + ilnres=il+nres + else + ilnres=il + endif + if (itype(jl).ne.10) then + jlnres=jl+nres + else + jlnres=jl + endif + qqijCM = qcontrib(il,jl,ilnres,jlnres) + qq = qq+qqijCM + if (lprn) then + write (iout,*) "qqijCM",qqijCM + call flush(iout) + endif + enddo + enddo + endif + qq = qq/nl + qwolynes=1.0d0-qq + do i=0,nres + do j=1,3 + dqwol(j,i)=dqwol(j,i)/nl + dxqwol(j,i)=dxqwol(j,i)/nl + enddo + enddo + return + end +c------------------------------------------------------------------- + subroutine qwol_num(seg1,seg2,flag,seg3,seg4) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.MD' + integer seg1,seg2,seg3,seg4 + logical flag + double precision qwolan(3,0:maxres),cdummy(3,0:maxres2), + & qwolxan(3,0:maxres),q1,q2 + double precision delta /1.0d-7/ + write (iout,*) "seg1",seg1," seg2",seg2," seg3",seg3," seg4",seg4 + write(iout,*) "dQ/dc backbone " + do i=0,nres + write(iout,'(i5,3e15.5)') i, (dqwol(j,i),j=1,3) + enddo + write(iout,*) "dQ/dX side chain " + do i=1,nres + write(iout,'(i5,3e15.5)') i,(dxqwol(j,i),j=1,3) + enddo + do i=1,nres + do j=1,3 + cdummy(j,i)=c(j,i) + c(j,i)=c(j,i)-delta + q1=qwolynes(seg1,seg2,flag,seg3,seg4) + c(j,i)=cdummy(j,i)+delta + q2=qwolynes(seg1,seg2,flag,seg3,seg4) + qwolan(j,i)=0.5d0*(q2-q1)/delta + c(j,i)=cdummy(j,i) +c write (iout,*) "i",i," j",j," q1",q1," a2",q2 + enddo + enddo + do i=1,nres + do j=1,3 + cdummy(j,i+nres)=c(j,i+nres) + c(j,i+nres)=c(j,i+nres)-delta + q1=qwolynes(seg1,seg2,flag,seg3,seg4) + c(j,i+nres)=cdummy(j,i+nres)+delta + q2=qwolynes(seg1,seg2,flag,seg3,seg4) + qwolxan(j,i)=0.5d0*(q2-q1)/delta + c(j,i+nres)=cdummy(j,i+nres) + enddo + enddo + write(iout,*) "Numerical Q cartesian gradients backbone: " + do i=0,nres + write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3) + enddo + write(iout,*) "Numerical Q cartesian gradients side-chain: " + do i=0,nres + write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3) + enddo + return + end +c------------------------------------------------------------------------ + subroutine EconstrQ +c MD with umbrella_sampling using Wolyne's distance measure as a constraint + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' +#ifndef LANG0 + include 'COMMON.LANGEVIN' +#else + include 'COMMON.LANGEVIN.lang0' +#endif + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.TIME1' + double precision uzap1,uzap2,hm1,hm2,hmnum + double precision ucdelan,dUcartan(3,0:MAXRES) + & ,dUxcartan(3,0:MAXRES),cdummy(3,0:MAXRES), + & duconst(3,0:MAXRES),duxconst(3,0:MAXRES) + integer kstart,kend,lstart,lend,idummy + double precision delta /1.0d-7/ + do i=0,nres + do j=1,3 + duconst(j,i)=0.0d0 + dudconst(j,i)=0.0d0 + duxconst(j,i)=0.0d0 + dudxconst(j,i)=0.0d0 + enddo + enddo + Uconst=0.0d0 + do i=1,nfrag + qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true. + & ,idummy,idummy) + Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset)) +c Calculating the derivatives of Constraint energy with respect to Q + Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),qinfrag(i,iset)) +c Calculating the derivatives of Q with respect to cartesian coordinates + do ii=0,nres + do j=1,3 + duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii) + dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii) + enddo + enddo +c write (iout,*) "Calling qwol_num" +c call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.,idummy,idummy) + enddo +c stop + do i=1,npair + kstart=ifrag(1,ipair(1,i,iset),iset) + kend=ifrag(2,ipair(1,i,iset),iset) + lstart=ifrag(1,ipair(2,i,iset),iset) + lend=ifrag(2,ipair(2,i,iset),iset) + qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend) + Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset)) +c Calculating dU/dQ + Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset)) +c Calculating dQ/dXi + do ii=0,nres + do j=1,3 + duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii) + dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii) + enddo + enddo + enddo +c write(iout,*) "Uconst inside subroutine ", Uconst +c Transforming the gradients from Cs to dCs for the backbone + do i=0,nres + do j=i+1,nres + do k=1,3 + dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j) + enddo + enddo + enddo +c Transforming the gradients from Cs to dCs for the side chains + do i=1,nres + do j=1,3 + dudxconst(j,i)=duxconst(j,i) + enddo + enddo +c write(iout,*) "dU/dc backbone " +c do ii=0,nres +c write(iout,'(i5,3e15.5)') ii, (duconst(j,ii),j=1,3) +c enddo +c write(iout,*) "dU/dX side chain " +c do ii=1,nres +c write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3) +c enddo +c write(iout,*) "dU/ddc backbone " +c do ii=0,nres +c write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3) +c enddo +c write(iout,*) "dU/ddX side chain " +c do ii=1,nres +c write(iout,'(i5,3e15.5)') ii,(dudxconst(j,ii),j=1,3) +c enddo +c Calculating numerical gradients of dUconst/ddc and dUconst/ddx +c call dEconstrQ_num + return + end +c----------------------------------------------------------------------- + subroutine dEconstrQ_num +c Calculating numerical dUconst/ddc and dUconst/ddx + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' +#ifndef LANG0 + include 'COMMON.LANGEVIN' +#else + include 'COMMON.LANGEVIN.lang0' +#endif + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.TIME1' + double precision uzap1,uzap2 + double precision dUcartan(3,0:MAXRES) + & ,dUxcartan(3,0:MAXRES),cdummy(3,0:MAXRES) + integer kstart,kend,lstart,lend,idummy + double precision delta /1.0d-7/ +c For the backbone + do i=0,nres-1 + do j=1,3 + dUcartan(j,i)=0.0d0 + cdummy(j,i)=dc(j,i) + dc(j,i)=dc(j,i)+delta + call chainbuild_cart + uzap2=0.0d0 + do ii=1,nfrag + qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset), + & .true.,idummy,idummy) + uzap2=uzap2+wfrag(ii,iset)* + & harmonic(qfrag(ii),qinfrag(ii,iset)) + enddo + do ii=1,npair + kstart=ifrag(1,ipair(1,ii,iset),iset) + kend=ifrag(2,ipair(1,ii,iset),iset) + lstart=ifrag(1,ipair(2,ii,iset),iset) + lend=ifrag(2,ipair(2,ii,iset),iset) + qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) + uzap2=uzap2+wpair(ii,iset)* + & harmonic(qpair(ii),qinpair(ii,iset)) + enddo + dc(j,i)=cdummy(j,i) + call chainbuild_cart + uzap1=0.0d0 + do ii=1,nfrag + qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset), + & .true.,idummy,idummy) + uzap1=uzap1+wfrag(ii,iset)* + & harmonic(qfrag(ii),qinfrag(ii,iset)) + enddo + do ii=1,npair + kstart=ifrag(1,ipair(1,ii,iset),iset) + kend=ifrag(2,ipair(1,ii,iset),iset) + lstart=ifrag(1,ipair(2,ii,iset),iset) + lend=ifrag(2,ipair(2,ii,iset),iset) + qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) + uzap1=uzap1+wpair(ii,iset)* + & harmonic(qpair(ii),qinpair(ii,iset)) + enddo + ducartan(j,i)=(uzap2-uzap1)/(delta) + enddo + enddo +c Calculating numerical gradients for dU/ddx + do i=0,nres-1 + do j=1,3 + duxcartan(j,i)=0.0d0 + enddo + do j=1,3 + cdummy(j,i)=dc(j,i+nres) + dc(j,i+nres)=dc(j,i+nres)+delta + call chainbuild_cart + uzap2=0.0d0 + do ii=1,nfrag + qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset), + & .true.,idummy,idummy) + uzap2=uzap2+wfrag(ii,iset)* + & harmonic(qfrag(ii),qinfrag(ii,iset)) + enddo + do ii=1,npair + kstart=ifrag(1,ipair(1,ii,iset),iset) + kend=ifrag(2,ipair(1,ii,iset),iset) + lstart=ifrag(1,ipair(2,ii,iset),iset) + lend=ifrag(2,ipair(2,ii,iset),iset) + qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) + uzap2=uzap2+wpair(ii,iset)* + & harmonic(qpair(ii),qinpair(ii,iset)) + enddo + dc(j,i+nres)=cdummy(j,i) + call chainbuild_cart + uzap1=0.0d0 + do ii=1,nfrag + qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset), + & .true.,idummy,idummy) + uzap1=uzap1+wfrag(ii,iset)* + & harmonic(qfrag(ii),qinfrag(ii,iset)) + enddo + do ii=1,npair + kstart=ifrag(1,ipair(1,ii,iset),iset) + kend=ifrag(2,ipair(1,ii,iset),iset) + lstart=ifrag(1,ipair(2,ii,iset),iset) + lend=ifrag(2,ipair(2,ii,iset),iset) + qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) + uzap1=uzap1+wpair(ii,iset)* + & harmonic(qpair(ii),qinpair(ii,iset)) + enddo + duxcartan(j,i)=(uzap2-uzap1)/(delta) + enddo + enddo + write(iout,*) "Numerical dUconst/ddc backbone " + do ii=0,nres + write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3) + enddo + write(iout,*) "Numerical dUconst/ddx side-chain " + do ii=1,nres + write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3) + enddo + return + end +c--------------------------------------------------------------------------- + double precision function qcontrib(il,jl,il1,jl1) + implicit none + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.MD' + include 'COMMON.LOCAL' + integer i,j,k,il,jl,il1,jl1,nd,itl,jtl + double precision dist + external dist + double precision dij,dij1,d0ij,d0ij1,om1,om2,om12,om10,om20,om120 + & ,fac,fac1,ddave,ssij,ddqij,d0ii1,d0jj1,rij,eom1,eom2,eom12 + double precision u(3),v(3),er(3),er0(3),dcosom1(3),dcosom2(3), + & aux1,aux2 + double precision scalar + external scalar + logical lprn /.false./ + if (lprn) write (iout,*) "il",il," jl",jl," il1",il1," jl1",jl1 + d0ij=dsqrt((cref(1,jl)-cref(1,il))**2+ + & (cref(2,jl)-cref(2,il))**2+ + & (cref(3,jl)-cref(3,il))**2) + dij=dist(il,jl) + dij1=dist(il1,jl1) + do i=1,3 + er(i)=(c(i,jl1)-c(i,il1))/dij1 + enddo + do i=1,3 + er0(i)=cref(i,jl1)-cref(i,il1) + enddo + d0ij1=dsqrt(scalar(er0,er0)) + do i=1,3 + er0(i)=er0(i)/d0ij1 + enddo + if (il.ne.il1 .or. jl.ne.jl1) then + ddave=0.5d0*((dij-d0ij)**2+(dij1-d0ij1)**2) + nd=2 + else + ddave=(dij-d0ij)**2 + nd=1 + endif + if (il.ne.il1) then + do i=1,3 + u(i)=cref(i,il1)-cref(i,il) + enddo + d0ii1=dsqrt(scalar(u,u)) + do i=1,3 + u(i)=u(i)/d0ii1 + enddo + if (lprn) then + write (iout,*) "u",(u(i),i=1,3) + write (iout,*) "er0",(er0(i),i=1,3) + om10=scalar(er0,u) + om1=scalar(er,dc_norm(1,il1)) + write (iout,*) "om10",om10," om1",om1 + endif + else + om1=0.0d0 + om10=0.0d0 + endif + if (jl.ne.jl1) then + do i=1,3 + v(i)=cref(i,jl1)-cref(i,jl) + enddo + d0jj1=dsqrt(scalar(v,v)) + do i=1,3 + v(i)=v(i)/d0jj1 + enddo + if (lprn) then + write (iout,*) "v",(v(i),i=1,3) + write (iout,*) "er0",(er0(i),i=1,3) + om20=scalar(er,v) + om2=scalar(er,dc_norm(1,jl1)) + write (iout,*) "om20",om20," om2",om2 + endif + else + om2=0.0d0 + om20=0.0d0 + endif + if (il.ne.il1 .and. jl.ne.jl1) then + om120=scalar(u,v) + om12=scalar(dc_norm(1,il1),dc_norm(1,jl1)) + else + om12=0.0d0 + om120=0.0d0 + endif + if (lprn) then + write (iout,*) "il",il," jl",jl,itype(il),itype(jl) + write (iout,*)"d0ij",d0ij," om10",om10," om20",om20, + & " om120",om120, + & " dij",dij," om1",om1," om2",om2," om12",om12 + call flush(iout) + endif + ssij = 16.0d0/(d0ij*d0ij) + qcontrib = dexp(-0.5d0*(ddave*ssij+((om1-om10)**2 + & +(om2-om20)**2+(om12-om120)**2))) + if (lprn) write (iout,*) "ssij",ssij," qcontrib",qcontrib +c qcontrib = dexp(-0.5d0*(ddave*ssij)+(om1-om10)**2+(om2-om20)**2) +c qcontrib = dexp(-0.5d0*(ddave*ssij)) +c Compute gradient - radial component + fac1 = qcontrib*ssij/nd + fac = fac1*(dij-d0ij)/dij + do k=1,3 + ddqij = (c(k,il)-c(k,jl))*fac + dqwol(k,il)=dqwol(k,il)+ddqij + dqwol(k,jl)=dqwol(k,jl)-ddqij + enddo + if (il1.ne.il .or. jl1.ne.jl) then + fac = fac1*(dij1-d0ij1)/dij1 + do k=1,3 + ddqij = (c(k,il1)-c(k,jl1))*fac + if (il1.ne.il) then + dxqwol(k,il)=dxqwol(k,il)+ddqij + else + dqwol(k,il)=dqwol(k,il)+ddqij + endif + if (jl1.ne.jl) then + dxqwol(k,jl)=dxqwol(k,jl)-ddqij + else + dqwol(k,jl)=dqwol(k,jl)-ddqij + endif + enddo + endif +c return +c Orientational contributions + rij=1.0d0/dij1 + eom1=qcontrib*(om1-om10) + eom2=qcontrib*(om2-om20) + eom12=qcontrib*(om12-om120) + do k=1,3 + dcosom1(k)=rij*(dc_norm(k,il1)-om1*er(k)) + dcosom2(k)=rij*(dc_norm(k,jl1)-om2*er(k)) + enddo + do k=1,3 + ddqij=eom1*dcosom1(k)+eom2*dcosom2(k) + aux1=(eom12*(dc_norm(k,jl1)-om12*dc_norm(k,il1)) + & +eom1*(er(k)-om1*dc_norm(k,il1)))*vbld_inv(il1) + aux2=(eom12*(dc_norm(k,il1)-om12*dc_norm(k,jl1)) + & +eom2*(er(k)-om2*dc_norm(k,jl1)))*vbld_inv(jl1) + dqwol(k,il)=dqwol(k,il)-ddqij-aux1 + dqwol(k,jl)=dqwol(k,jl)+ddqij-aux2 + dxqwol(k,il)=dxqwol(k,il)-ddqij+aux1 +c & +(eom12*(dc_norm(k,jl1)-om12*dc_norm(k,il1)) +c & +eom1*(er(k)-om1*dc_norm(k,il1)))*vbld_inv(il1) + dxqwol(k,jl)=dxqwol(k,jl)+ddqij+aux2 +c & +(eom12*(dc_norm(k,il1)-om12*dc_norm(k,jl1)) +c & +eom2*(er(k)-om2*dc_norm(k,jl1)))*vbld_inv(jl1) + enddo + return + end diff --git a/source/unres/src_MD-DFA-restraints/randgens.f b/source/unres/src_MD-DFA-restraints/randgens.f new file mode 100644 index 0000000..0daeb35 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/rattle.F b/source/unres/src_MD-DFA-restraints/rattle.F new file mode 100644 index 0000000..a2e5034 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/rattle.F @@ -0,0 +1,706 @@ + subroutine rattle1 +c RATTLE algorithm for velocity Verlet - step 1, UNRES +c AL 9/24/04 + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' +#ifndef LANG0 + include 'COMMON.LANGEVIN' +#else + include 'COMMON.LANGEVIN.lang0' +#endif + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.TIME1' + double precision gginv(maxres2,maxres2), + & gdc(3,MAXRES2,MAXRES2),dC_uncor(3,MAXRES2), + & Cmat(MAXRES2,MAXRES2),x(MAXRES2),xcorr(3,MAXRES2) + common /przechowalnia/ GGinv,gdc,Cmat,nbond + integer max_rattle /5/ + logical lprn /.false./, lprn1 /.false./,not_done + double precision tol_rattle /1.0d-5/ + if (lprn) write (iout,*) "RATTLE1" + nbond=nct-nnt + do i=nnt,nct + if (itype(i).ne.10) nbond=nbond+1 + enddo +c Make a folded form of the Ginv-matrix + ind=0 + ii=0 + do i=nnt,nct-1 + ii=ii+1 + do j=1,3 + ind=ind+1 + ind1=0 + jj=0 + do k=nnt,nct-1 + jj=jj+1 + do l=1,3 + ind1=ind1+1 + if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=Ginv(ind,ind1) + enddo + enddo + do k=nnt,nct + if (itype(k).ne.10) then + jj=jj+1 + do l=1,3 + ind1=ind1+1 + if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=Ginv(ind,ind1) + enddo + endif + enddo + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ii=ii+1 + do j=1,3 + ind=ind+1 + ind1=0 + jj=0 + do k=nnt,nct-1 + jj=jj+1 + do l=1,3 + ind1=ind1+1 + if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=Ginv(ind,ind1) + enddo + enddo + do k=nnt,nct + if (itype(k).ne.10) then + jj=jj+1 + do l=1,3 + ind1=ind1+1 + if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=Ginv(ind,ind1) + enddo + endif + enddo + enddo + endif + enddo + if (lprn1) then + write (iout,*) "Matrix GGinv" + call MATOUT(nbond,nbond,MAXRES2,MAXRES2,GGinv) + endif + not_done=.true. + iter=0 + do while (not_done) + iter=iter+1 + if (iter.gt.max_rattle) then + write (iout,*) "Error - too many iterations in RATTLE." + stop + endif +c Calculate the matrix C = GG**(-1) dC_old o dC + ind1=0 + do i=nnt,nct-1 + ind1=ind1+1 + do j=1,3 + dC_uncor(j,ind1)=dC(j,i) + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind1=ind1+1 + do j=1,3 + dC_uncor(j,ind1)=dC(j,i+nres) + enddo + endif + enddo + do i=1,nbond + ind=0 + do k=nnt,nct-1 + ind=ind+1 + do j=1,3 + gdc(j,i,ind)=GGinv(i,ind)*dC_old(j,k) + enddo + enddo + do k=nnt,nct + if (itype(k).ne.10) then + ind=ind+1 + do j=1,3 + gdc(j,i,ind)=GGinv(i,ind)*dC_old(j,k+nres) + enddo + endif + enddo + enddo +c Calculate deviations from standard virtual-bond lengths + ind=0 + do i=nnt,nct-1 + ind=ind+1 + x(ind)=vbld(i+1)**2-vbl**2 + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind=ind+1 + x(ind)=vbld(i+nres)**2-vbldsc0(1,itype(i))**2 + endif + enddo + if (lprn) then + write (iout,*) "Coordinates and violations" + do i=1,nbond + write(iout,'(i5,3f10.5,5x,e15.5)') + & i,(dC_uncor(j,i),j=1,3),x(i) + enddo + write (iout,*) "Velocities and violations" + ind=0 + do i=nnt,nct-1 + ind=ind+1 + write (iout,'(2i5,3f10.5,5x,e15.5)') + & i,ind,(d_t_new(j,i),j=1,3),scalar(d_t_new(1,i),dC_old(1,i)) + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind=ind+1 + write (iout,'(2i5,3f10.5,5x,e15.5)') + & i+nres,ind,(d_t_new(j,i+nres),j=1,3), + & scalar(d_t_new(1,i+nres),dC_old(1,i+nres)) + endif + enddo +c write (iout,*) "gdc" +c do i=1,nbond +c write (iout,*) "i",i +c do j=1,nbond +c write (iout,'(i5,3f10.5)') j,(gdc(k,j,i),k=1,3) +c enddo +c enddo + endif + xmax=dabs(x(1)) + do i=2,nbond + if (dabs(x(i)).gt.xmax) then + xmax=dabs(x(i)) + endif + enddo + if (xmax.lt.tol_rattle) then + not_done=.false. + goto 100 + endif +c Calculate the matrix of the system of equations + do i=1,nbond + do j=1,nbond + Cmat(i,j)=0.0d0 + do k=1,3 + Cmat(i,j)=Cmat(i,j)+dC_uncor(k,i)*gdc(k,i,j) + enddo + enddo + enddo + if (lprn1) then + write (iout,*) "Matrix Cmat" + call MATOUT(nbond,nbond,MAXRES2,MAXRES2,Cmat) + endif + call gauss(Cmat,X,MAXRES2,nbond,1,*10) +c Add constraint term to positions + ind=0 + do i=nnt,nct-1 + ind=ind+1 + do j=1,3 + xx=0.0d0 + do ii=1,nbond + xx = xx+x(ii)*gdc(j,ind,ii) + enddo + xx=0.5d0*xx + dC(j,i)=dC(j,i)-xx + d_t_new(j,i)=d_t_new(j,i)-xx/d_time + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind=ind+1 + do j=1,3 + xx=0.0d0 + do ii=1,nbond + xx = xx+x(ii)*gdc(j,ind,ii) + enddo + xx=0.5d0*xx + dC(j,i+nres)=dC(j,i+nres)-xx + d_t_new(j,i+nres)=d_t_new(j,i+nres)-xx/d_time + enddo + endif + enddo +c Rebuild the chain using the new coordinates + call chainbuild_cart + if (lprn) then + write (iout,*) "New coordinates, Lagrange multipliers,", + & " and differences between actual and standard bond lengths" + ind=0 + do i=nnt,nct-1 + ind=ind+1 + xx=vbld(i+1)**2-vbl**2 + write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') + & i,(dC(j,i),j=1,3),x(ind),xx + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind=ind+1 + xx=vbld(i+nres)**2-vbldsc0(1,itype(i))**2 + write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') + & i,(dC(j,i+nres),j=1,3),x(ind),xx + endif + enddo + write (iout,*) "Velocities and violations" + ind=0 + do i=nnt,nct-1 + ind=ind+1 + write (iout,'(2i5,3f10.5,5x,e15.5)') + & i,ind,(d_t_new(j,i),j=1,3),scalar(d_t_new(1,i),dC_old(1,i)) + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind=ind+1 + write (iout,'(2i5,3f10.5,5x,e15.5)') + & i+nres,ind,(d_t_new(j,i+nres),j=1,3), + & scalar(d_t_new(1,i+nres),dC_old(1,i+nres)) + endif + enddo + endif + enddo + 100 continue + return + 10 write (iout,*) "Error - singularity in solving the system", + & " of equations for Lagrange multipliers." + stop + end +c------------------------------------------------------------------------------ + subroutine rattle2 +c RATTLE algorithm for velocity Verlet - step 2, UNRES +c AL 9/24/04 + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' +#ifndef LANG0 + include 'COMMON.LANGEVIN' +#else + include 'COMMON.LANGEVIN.lang0' +#endif + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.TIME1' + double precision gginv(maxres2,maxres2), + & gdc(3,MAXRES2,MAXRES2),dC_uncor(3,MAXRES2), + & Cmat(MAXRES2,MAXRES2),x(MAXRES2) + common /przechowalnia/ GGinv,gdc,Cmat,nbond + integer max_rattle /5/ + logical lprn /.false./, lprn1 /.false./,not_done + double precision tol_rattle /1.0d-5/ + if (lprn) write (iout,*) "RATTLE2" + if (lprn) write (iout,*) "Velocity correction" +c Calculate the matrix G dC + do i=1,nbond + ind=0 + do k=nnt,nct-1 + ind=ind+1 + do j=1,3 + gdc(j,i,ind)=GGinv(i,ind)*dC(j,k) + enddo + enddo + do k=nnt,nct + if (itype(k).ne.10) then + ind=ind+1 + do j=1,3 + gdc(j,i,ind)=GGinv(i,ind)*dC(j,k+nres) + enddo + endif + enddo + enddo +c if (lprn) then +c write (iout,*) "gdc" +c do i=1,nbond +c write (iout,*) "i",i +c do j=1,nbond +c write (iout,'(i5,3f10.5)') j,(gdc(k,j,i),k=1,3) +c enddo +c enddo +c endif +c Calculate the matrix of the system of equations + ind=0 + do i=nnt,nct-1 + ind=ind+1 + do j=1,nbond + Cmat(ind,j)=0.0d0 + do k=1,3 + Cmat(ind,j)=Cmat(ind,j)+dC(k,i)*gdc(k,ind,j) + enddo + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind=ind+1 + do j=1,nbond + Cmat(ind,j)=0.0d0 + do k=1,3 + Cmat(ind,j)=Cmat(ind,j)+dC(k,i+nres)*gdc(k,ind,j) + enddo + enddo + endif + enddo +c Calculate the scalar product dC o d_t_new + ind=0 + do i=nnt,nct-1 + ind=ind+1 + x(ind)=scalar(d_t(1,i),dC(1,i)) + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind=ind+1 + x(ind)=scalar(d_t(1,i+nres),dC(1,i+nres)) + endif + enddo + if (lprn) then + write (iout,*) "Velocities and violations" + ind=0 + do i=nnt,nct-1 + ind=ind+1 + write (iout,'(2i5,3f10.5,5x,e15.5)') + & i,ind,(d_t(j,i),j=1,3),x(ind) + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind=ind+1 + write (iout,'(2i5,3f10.5,5x,e15.5)') + & i+nres,ind,(d_t(j,i+nres),j=1,3),x(ind) + endif + enddo + endif + xmax=dabs(x(1)) + do i=2,nbond + if (dabs(x(i)).gt.xmax) then + xmax=dabs(x(i)) + endif + enddo + if (xmax.lt.tol_rattle) then + not_done=.false. + goto 100 + endif + if (lprn1) then + write (iout,*) "Matrix Cmat" + call MATOUT(nbond,nbond,MAXRES2,MAXRES2,Cmat) + endif + call gauss(Cmat,X,MAXRES2,nbond,1,*10) +c Add constraint term to velocities + ind=0 + do i=nnt,nct-1 + ind=ind+1 + do j=1,3 + xx=0.0d0 + do ii=1,nbond + xx = xx+x(ii)*gdc(j,ind,ii) + enddo + d_t(j,i)=d_t(j,i)-xx + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind=ind+1 + do j=1,3 + xx=0.0d0 + do ii=1,nbond + xx = xx+x(ii)*gdc(j,ind,ii) + enddo + d_t(j,i+nres)=d_t(j,i+nres)-xx + enddo + endif + enddo + if (lprn) then + write (iout,*) + & "New velocities, Lagrange multipliers violations" + ind=0 + do i=nnt,nct-1 + ind=ind+1 + if (lprn) write (iout,'(2i5,3f10.5,5x,2e15.5)') + & i,ind,(d_t(j,i),j=1,3),x(ind),scalar(d_t(1,i),dC(1,i)) + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind=ind+1 + write (iout,'(2i5,3f10.5,5x,2e15.5)') + & i+nres,ind,(d_t(j,i+nres),j=1,3),x(ind), + & scalar(d_t(1,i+nres),dC(1,i+nres)) + endif + enddo + endif + 100 continue + return + 10 write (iout,*) "Error - singularity in solving the system", + & " of equations for Lagrange multipliers." + stop + end +c------------------------------------------------------------------------------ + subroutine rattle_brown +c RATTLE/LINCS algorithm for Brownian dynamics, UNRES +c AL 9/24/04 + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' +#ifndef LANG0 + include 'COMMON.LANGEVIN' +#else + include 'COMMON.LANGEVIN.lang0' +#endif + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.TIME1' + double precision gginv(maxres2,maxres2), + & gdc(3,MAXRES2,MAXRES2),dC_uncor(3,MAXRES2), + & Cmat(MAXRES2,MAXRES2),x(MAXRES2) + common /przechowalnia/ GGinv,gdc,Cmat,nbond + integer max_rattle /5/ + logical lprn /.true./, lprn1 /.true./,not_done + double precision tol_rattle /1.0d-5/ + if (lprn) write (iout,*) "RATTLE_BROWN" + nbond=nct-nnt + do i=nnt,nct + if (itype(i).ne.10) nbond=nbond+1 + enddo +c Make a folded form of the Ginv-matrix + ind=0 + ii=0 + do i=nnt,nct-1 + ii=ii+1 + do j=1,3 + ind=ind+1 + ind1=0 + jj=0 + do k=nnt,nct-1 + jj=jj+1 + do l=1,3 + ind1=ind1+1 + if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=fricmat(ind,ind1) + enddo + enddo + do k=nnt,nct + if (itype(k).ne.10) then + jj=jj+1 + do l=1,3 + ind1=ind1+1 + if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=fricmat(ind,ind1) + enddo + endif + enddo + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ii=ii+1 + do j=1,3 + ind=ind+1 + ind1=0 + jj=0 + do k=nnt,nct-1 + jj=jj+1 + do l=1,3 + ind1=ind1+1 + if (j.eq.1 .and. l.eq.1) GGinv(ii,jj)=fricmat(ind,ind1) + enddo + enddo + do k=nnt,nct + if (itype(k).ne.10) then + jj=jj+1 + do l=1,3 + ind1=ind1+1 + if (j.eq.1 .and. l.eq.1)GGinv(ii,jj)=fricmat(ind,ind1) + enddo + endif + enddo + enddo + endif + enddo + if (lprn1) then + write (iout,*) "Matrix GGinv" + call MATOUT(nbond,nbond,MAXRES2,MAXRES2,GGinv) + endif + not_done=.true. + iter=0 + do while (not_done) + iter=iter+1 + if (iter.gt.max_rattle) then + write (iout,*) "Error - too many iterations in RATTLE." + stop + endif +c Calculate the matrix C = GG**(-1) dC_old o dC + ind1=0 + do i=nnt,nct-1 + ind1=ind1+1 + do j=1,3 + dC_uncor(j,ind1)=dC(j,i) + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind1=ind1+1 + do j=1,3 + dC_uncor(j,ind1)=dC(j,i+nres) + enddo + endif + enddo + do i=1,nbond + ind=0 + do k=nnt,nct-1 + ind=ind+1 + do j=1,3 + gdc(j,i,ind)=GGinv(i,ind)*dC_old(j,k) + enddo + enddo + do k=nnt,nct + if (itype(k).ne.10) then + ind=ind+1 + do j=1,3 + gdc(j,i,ind)=GGinv(i,ind)*dC_old(j,k+nres) + enddo + endif + enddo + enddo +c Calculate deviations from standard virtual-bond lengths + ind=0 + do i=nnt,nct-1 + ind=ind+1 + x(ind)=vbld(i+1)**2-vbl**2 + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind=ind+1 + x(ind)=vbld(i+nres)**2-vbldsc0(1,itype(i))**2 + endif + enddo + if (lprn) then + write (iout,*) "Coordinates and violations" + do i=1,nbond + write(iout,'(i5,3f10.5,5x,e15.5)') + & i,(dC_uncor(j,i),j=1,3),x(i) + enddo + write (iout,*) "Velocities and violations" + ind=0 + do i=nnt,nct-1 + ind=ind+1 + write (iout,'(2i5,3f10.5,5x,e15.5)') + & i,ind,(d_t(j,i),j=1,3),scalar(d_t(1,i),dC_old(1,i)) + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind=ind+1 + write (iout,'(2i5,3f10.5,5x,e15.5)') + & i+nres,ind,(d_t(j,i+nres),j=1,3), + & scalar(d_t(1,i+nres),dC_old(1,i+nres)) + endif + enddo + write (iout,*) "gdc" + do i=1,nbond + write (iout,*) "i",i + do j=1,nbond + write (iout,'(i5,3f10.5)') j,(gdc(k,j,i),k=1,3) + enddo + enddo + endif + xmax=dabs(x(1)) + do i=2,nbond + if (dabs(x(i)).gt.xmax) then + xmax=dabs(x(i)) + endif + enddo + if (xmax.lt.tol_rattle) then + not_done=.false. + goto 100 + endif +c Calculate the matrix of the system of equations + do i=1,nbond + do j=1,nbond + Cmat(i,j)=0.0d0 + do k=1,3 + Cmat(i,j)=Cmat(i,j)+dC_uncor(k,i)*gdc(k,i,j) + enddo + enddo + enddo + if (lprn1) then + write (iout,*) "Matrix Cmat" + call MATOUT(nbond,nbond,MAXRES2,MAXRES2,Cmat) + endif + call gauss(Cmat,X,MAXRES2,nbond,1,*10) +c Add constraint term to positions + ind=0 + do i=nnt,nct-1 + ind=ind+1 + do j=1,3 + xx=0.0d0 + do ii=1,nbond + xx = xx+x(ii)*gdc(j,ind,ii) + enddo + xx=-0.5d0*xx + d_t(j,i)=d_t(j,i)+xx/d_time + dC(j,i)=dC(j,i)+xx + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind=ind+1 + do j=1,3 + xx=0.0d0 + do ii=1,nbond + xx = xx+x(ii)*gdc(j,ind,ii) + enddo + xx=-0.5d0*xx + d_t(j,i+nres)=d_t(j,i+nres)+xx/d_time + dC(j,i+nres)=dC(j,i+nres)+xx + enddo + endif + enddo +c Rebuild the chain using the new coordinates + call chainbuild_cart + if (lprn) then + write (iout,*) "New coordinates, Lagrange multipliers,", + & " and differences between actual and standard bond lengths" + ind=0 + do i=nnt,nct-1 + ind=ind+1 + xx=vbld(i+1)**2-vbl**2 + write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') + & i,(dC(j,i),j=1,3),x(ind),xx + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind=ind+1 + xx=vbld(i+nres)**2-vbldsc0(1,itype(i))**2 + write (iout,'(i5,3f10.5,5x,f10.5,e15.5)') + & i,(dC(j,i+nres),j=1,3),x(ind),xx + endif + enddo + write (iout,*) "Velocities and violations" + ind=0 + do i=nnt,nct-1 + ind=ind+1 + write (iout,'(2i5,3f10.5,5x,e15.5)') + & i,ind,(d_t_new(j,i),j=1,3),scalar(d_t_new(1,i),dC_old(1,i)) + enddo + do i=nnt,nct + if (itype(i).ne.10) then + ind=ind+1 + write (iout,'(2i5,3f10.5,5x,e15.5)') + & i+nres,ind,(d_t_new(j,i+nres),j=1,3), + & scalar(d_t_new(1,i+nres),dC_old(1,i+nres)) + endif + enddo + endif + enddo + 100 continue + return + 10 write (iout,*) "Error - singularity in solving the system", + & " of equations for Lagrange multipliers." + stop + end diff --git a/source/unres/src_MD-DFA-restraints/readpdb.F b/source/unres/src_MD-DFA-restraints/readpdb.F new file mode 100644 index 0000000..48e0abd --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/readpdb.F @@ -0,0 +1,432 @@ + 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) + double precision e1(3),e2(3),e3(3) + logical fail + 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 2/15/2013 by Adam: corrected insertion of the last dummy residue + call refsys(nres-3,nres-2,nres-1,e1,e2,e3,fail) + if (fail) then + e2(1)=0.0d0 + e2(2)=1.0d0 + e2(3)=0.0d0 + endif + do j=1,3 + c(j,nres)=c(j,nres-1)-3.8d0*e2(j) + enddo + 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 2/15/2013 by Adam: corrected insertion of the first dummy residue + call refsys(2,3,4,e1,e2,e3,fail) + if (fail) then + e2(1)=0.0d0 + e2(2)=1.0d0 + e2(3)=0.0d0 + endif + do j=1,3 + c(j,1)=c(j,2)-3.8d0*e2(j) + enddo + else + do j=1,3 + dcj=c(j,4)-c(j,3) + c(j,1)=c(j,2)-dcj + c(j,nres+1)=c(j,1) + enddo + endif + endif +C Calculate internal coordinates. + if(me.eq.king.or..not.out1file)then + write (iout,'(a)') + & "Backbone and SC coordinates as read from the PDB" + do ires=1,nres + write (iout,'(2i3,2x,a,3f8.3,5x,3f8.3)') + & ires,itype(ires),restyp(itype(ires)),(c(j,ires),j=1,3), + & (c(j,nres+ires),j=1,3) + enddo + endif + call int_from_cart(.true.,.false.) + call sc_loc_geom(.false.) + do i=1,nres + thetaref(i)=theta(i) + phiref(i)=phi(i) + enddo + do i=1,nres-1 + do j=1,3 + dc(j,i)=c(j,i+1)-c(j,i) + dc_norm(j,i)=dc(j,i)*vbld_inv(i+1) + enddo + enddo + do i=2,nres-1 + do j=1,3 + dc(j,i+nres)=c(j,i+nres)-c(j,i) + dc_norm(j,i+nres)=dc(j,i+nres)*vbld_inv(i+nres) + enddo +c write (iout,*) i,(dc(j,i+nres),j=1,3),(dc_norm(j,i+nres),j=1,3), +c & vbld_inv(i+nres) + enddo +c call chainbuild +C Copy the coordinates to reference coordinates + do i=1,2*nres + do j=1,3 + cref(j,i)=c(j,i) + enddo + enddo + + + do j=1,nbfrag + do i=1,4 + bfrag(i,j)=bfrag(i,j)-ishift + enddo + enddo + + do j=1,nhfrag + do i=1,2 + hfrag(i,j)=hfrag(i,j)-ishift + enddo + enddo + + return + end +c--------------------------------------------------------------------------- + subroutine int_from_cart(lside,lprn) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include "mpif.h" +#endif + include 'COMMON.LOCAL' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.NAMES' + include 'COMMON.CONTROL' + include 'COMMON.SETUP' + character*3 seq,atom,res + character*80 card + dimension sccor(3,20) + integer rescode + logical lside,lprn + if(me.eq.king.or..not.out1file)then + if (lprn) then + write (iout,'(/a)') + & 'Internal coordinates calculated from crystal structure.' + if (lside) then + write (iout,'(8a)') ' Res ',' dvb',' Theta', + & ' Gamma',' Dsc_id',' Dsc',' Alpha', + & ' Beta ' + else + write (iout,'(4a)') ' Res ',' dvb',' Theta', + & ' Gamma' + endif + endif + endif + do i=1,nres-1 + iti=itype(i) + if (dist(i,i+1).lt.2.0D0 .or. dist(i,i+1).gt.5.0D0) then + write (iout,'(a,i4)') 'Bad Cartesians for residue',i +ctest stop + endif + vbld(i+1)=dist(i,i+1) + vbld_inv(i+1)=1.0d0/vbld(i+1) + if (i.gt.1) theta(i+1)=alpha(i-1,i,i+1) + if (i.gt.2) phi(i+1)=beta(i-2,i-1,i,i+1) + enddo +c if (unres_pdb) then +c if (itype(1).eq.21) then +c theta(3)=90.0d0*deg2rad +c phi(4)=180.0d0*deg2rad +c vbld(2)=3.8d0 +c vbld_inv(2)=1.0d0/vbld(2) +c endif +c if (itype(nres).eq.21) then +c theta(nres)=90.0d0*deg2rad +c phi(nres)=180.0d0*deg2rad +c vbld(nres)=3.8d0 +c vbld_inv(nres)=1.0d0/vbld(2) +c endif +c endif + if (lside) then + do i=2,nres-1 + do j=1,3 + c(j,maxres2)=0.5D0*(2*c(j,i)+(c(j,i-1)-c(j,i))*vbld_inv(i) + & +(c(j,i+1)-c(j,i))*vbld_inv(i+1)) + enddo + iti=itype(i) + di=dist(i,nres+i) +C 10/03/12 Adam: Correction for zero SC-SC bond length + if (itype(i).ne.10 .and. itype(i).ne.21. and. di.eq.0.0d0) + & di=dsc(itype(i)) + vbld(i+nres)=di + if (itype(i).ne.10) then + vbld_inv(i+nres)=1.0d0/di + else + vbld_inv(i+nres)=0.0d0 + endif + if (iti.ne.10) then + alph(i)=alpha(nres+i,i,maxres2) + omeg(i)=beta(nres+i,i,maxres2,i+1) + endif + if(me.eq.king.or..not.out1file)then + if (lprn) + & write (iout,'(a3,i4,7f10.3)') restyp(iti),i,vbld(i), + & rad2deg*theta(i),rad2deg*phi(i),dsc(iti),vbld(nres+i), + & rad2deg*alph(i),rad2deg*omeg(i) + endif + enddo + else if (lprn) then + do i=2,nres + iti=itype(i) + if(me.eq.king.or..not.out1file) + & write (iout,'(a3,i4,7f10.3)') restyp(iti),i,dist(i,i-1), + & rad2deg*theta(i),rad2deg*phi(i) + enddo + endif + return + end +c------------------------------------------------------------------------------- + subroutine sc_loc_geom(lprn) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include "mpif.h" +#endif + include 'COMMON.LOCAL' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.NAMES' + include 'COMMON.CONTROL' + include 'COMMON.SETUP' + double precision x_prime(3),y_prime(3),z_prime(3) + logical lprn + do i=1,nres-1 + do j=1,3 + dc_norm(j,i)=vbld_inv(i+1)*(c(j,i+1)-c(j,i)) + enddo + enddo + do i=2,nres-1 + if (itype(i).ne.10) then + do j=1,3 + dc_norm(j,i+nres)=vbld_inv(i+nres)*(c(j,i+nres)-c(j,i)) + enddo + else + do j=1,3 + dc_norm(j,i+nres)=0.0d0 + enddo + endif + enddo + do i=2,nres-1 + costtab(i+1) =dcos(theta(i+1)) + sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1)) + cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1))) + sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1))) + cosfac2=0.5d0/(1.0d0+costtab(i+1)) + cosfac=dsqrt(cosfac2) + sinfac2=0.5d0/(1.0d0-costtab(i+1)) + sinfac=dsqrt(sinfac2) + it=itype(i) + if (it.ne.10) then +c +C Compute the axes of tghe local cartesian coordinates system; store in +c x_prime, y_prime and z_prime +c + do j=1,3 + x_prime(j) = 0.00 + y_prime(j) = 0.00 + z_prime(j) = 0.00 + enddo + do j = 1,3 + x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac + y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac + enddo + call vecpr(x_prime,y_prime,z_prime) +c +C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i), +C to local coordinate system. Store in xx, yy, zz. +c + xx=0.0d0 + yy=0.0d0 + zz=0.0d0 + do j = 1,3 + xx = xx + x_prime(j)*dc_norm(j,i+nres) + yy = yy + y_prime(j)*dc_norm(j,i+nres) + zz = zz + z_prime(j)*dc_norm(j,i+nres) + enddo + + xxref(i)=xx + yyref(i)=yy + zzref(i)=zz + else + xxref(i)=0.0d0 + yyref(i)=0.0d0 + zzref(i)=0.0d0 + endif + enddo + if (lprn) then + do i=2,nres + iti=itype(i) + if(me.eq.king.or..not.out1file) + & write (iout,'(a3,i4,3f10.5)') restyp(iti),i,xxref(i), + & yyref(i),zzref(i) + enddo + endif + return + end +c--------------------------------------------------------------------------- + subroutine sccenter(ires,nscat,sccor) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + dimension sccor(3,20) + do j=1,3 + sccmj=0.0D0 + do i=1,nscat + sccmj=sccmj+sccor(j,i) + enddo + dc(j,ires)=sccmj/nscat + enddo + return + end +c--------------------------------------------------------------------------- + subroutine bond_regular + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CALC' + include 'COMMON.INTERACT' + include 'COMMON.CHAIN' + do i=1,nres-1 + vbld(i+1)=vbl + vbld_inv(i+1)=1.0d0/vbld(i+1) + vbld(i+1+nres)=dsc(itype(i+1)) + vbld_inv(i+1+nres)=dsc_inv(itype(i+1)) +c print *,vbld(i+1),vbld(i+1+nres) + enddo + return + end diff --git a/source/unres/src_MD-DFA-restraints/readrtns.F b/source/unres/src_MD-DFA-restraints/readrtns.F new file mode 100644 index 0000000..d21d3b9 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/readrtns.F @@ -0,0 +1,2868 @@ + subroutine readrtns + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.SETUP' + include 'COMMON.CONTROL' + include 'COMMON.SBRIDGE' + include 'COMMON.IOUNITS' + logical file_exist +C Read force-field parameters except weights + call parmread +C Read job setup parameters + call read_control +C Read control parameters for energy minimzation if required + if (minim) call read_minim +C Read MCM control parameters if required + if (modecalc.eq.3 .or. modecalc.eq.6) call mcmread +C Read MD control parameters if reqjuired + if (modecalc.eq.12) call read_MDpar +C Read MREMD control parameters if required + if (modecalc.eq.14) then + call read_MDpar + call read_REMDpar + endif +C Read MUCA control parameters if required + if (lmuca) call read_muca +C Read CSA control parameters if required (from fort.40 if exists +C otherwise from general input file) +csa if (modecalc.eq.8) then +csa inquire (file="fort.40",exist=file_exist) +csa if (.not.file_exist) call csaread +csa endif +cfmc if (modecalc.eq.10) call mcmfread +C Read molecule information, molecule geometry, energy-term weights, and +C restraints if requested + call molread +C Print restraint information +#ifdef MPI + if (.not. out1file .or. me.eq.king) then +#endif + if (nhpb.gt.nss) + &write (iout,'(a,i5,a)') "The following",nhpb-nss, + & " distance constraints have been imposed" + do i=nss+1,nhpb + write (iout,'(3i6,i2,3f10.5)') i-nss,ihpb(i),jhpb(i), + & ibecarb(i),dhpb(i),dhpb1(i),forcon(i) + enddo +#ifdef MPI + endif +#endif +c print *,"Processor",myrank," leaves READRTNS" + return + end +C------------------------------------------------------------------------------- + subroutine read_control +C +C Read contorl data +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MP + include 'mpif.h' + logical OKRandom, prng_restart + real*8 r1 +#endif + include 'COMMON.IOUNITS' + include 'COMMON.TIME1' + include 'COMMON.THREAD' + include 'COMMON.SBRIDGE' + include 'COMMON.CONTROL' + include 'COMMON.MCM' + include 'COMMON.MAP' + include 'COMMON.HEADER' +csa include 'COMMON.CSA' + include 'COMMON.CHAIN' + include 'COMMON.MUCA' + include 'COMMON.MD' + include 'COMMON.FFIELD' + include 'COMMON.SETUP' + COMMON /MACHSW/ KDIAG,ICORFL,IXDR + character*8 diagmeth(0:3) /'Library','EVVRSP','Givens','Jacobi'/ + character*80 ucase + character*320 controlcard + + nglob_csa=0 + eglob_csa=1d99 + nmin_csa=0 + read (INP,'(a)') titel + call card_concat(controlcard) +c out1file=index(controlcard,'OUT1FILE').gt.0 .or. fg_rank.gt.0 +c print *,"Processor",me," fg_rank",fg_rank," out1file",out1file + call reada(controlcard,'SEED',seed,0.0D0) + call random_init(seed) +C Set up the time limit (caution! The time must be input in minutes!) + read_cart=index(controlcard,'READ_CART').gt.0 + call readi(controlcard,'CONSTR_DIST',constr_dist,0) + call readi(controlcard,'CONSTR_HOMOL',constr_homology,0) + call reada(controlcard,'TIMLIM',timlim,960.0D0) ! default 16 hours + unres_pdb = index(controlcard,'UNRES_PDB') .gt. 0 + call reada(controlcard,'SAFETY',safety,30.0D0) ! default 30 minutes + call reada(controlcard,'RMSDBC',rmsdbc,3.0D0) + call reada(controlcard,'RMSDBC1',rmsdbc1,0.5D0) + call reada(controlcard,'RMSDBC1MAX',rmsdbc1max,1.5D0) + call reada(controlcard,'RMSDBCM',rmsdbcm,3.0D0) + call reada(controlcard,'DRMS',drms,0.1D0) + if(me.eq.king .or. .not. out1file .and. fg_rank.eq.0) then + write (iout,'(a,f10.1)')'RMSDBC = ',rmsdbc + write (iout,'(a,f10.1)')'RMSDBC1 = ',rmsdbc1 + write (iout,'(a,f10.1)')'RMSDBC1MAX = ',rmsdbc1max + write (iout,'(a,f10.1)')'DRMS = ',drms + write (iout,'(a,f10.1)')'RMSDBCM = ',rmsdbcm + write (iout,'(a,f10.1)') 'Time limit (min):',timlim + endif + call readi(controlcard,'NZ_START',nz_start,0) + call readi(controlcard,'NZ_END',nz_end,0) + call readi(controlcard,'IZ_SC',iz_sc,0) + timlim=60.0D0*timlim + safety = 60.0d0*safety + timem=timlim + modecalc=0 + call reada(controlcard,"T_BATH",t_bath,300.0d0) + minim=(index(controlcard,'MINIMIZE').gt.0) + dccart=(index(controlcard,'CART').gt.0) + overlapsc=(index(controlcard,'OVERLAP').gt.0) + overlapsc=.not.overlapsc + searchsc=(index(controlcard,'NOSEARCHSC').gt.0) + searchsc=.not.searchsc + sideadd=(index(controlcard,'SIDEADD').gt.0) + energy_dec=(index(controlcard,'ENERGY_DEC').gt.0) + outpdb=(index(controlcard,'PDBOUT').gt.0) + outmol2=(index(controlcard,'MOL2OUT').gt.0) + pdbref=(index(controlcard,'PDBREF').gt.0) + refstr=pdbref .or. (index(controlcard,'REFSTR').gt.0) + indpdb=index(controlcard,'PDBSTART') + extconf=(index(controlcard,'EXTCONF').gt.0) + call readi(controlcard,'IPRINT',iprint,0) + call readi(controlcard,'MAXGEN',maxgen,10000) + call readi(controlcard,'MAXOVERLAP',maxoverlap,1000) + call readi(controlcard,"KDIAG",kdiag,0) + call readi(controlcard,"RESCALE_MODE",rescale_mode,2) + if(me.eq.king .or. .not. out1file .and. fg_rank.eq.0) + & write (iout,*) "RESCALE_MODE",rescale_mode + split_ene=index(controlcard,'SPLIT_ENE').gt.0 + if (index(controlcard,'REGULAR').gt.0.0D0) then + call reada(controlcard,'WEIDIS',weidis,0.1D0) + modecalc=1 + refstr=.true. + endif + if (index(controlcard,'CHECKGRAD').gt.0) then + modecalc=5 + if (index(controlcard,'CART').gt.0) then + icheckgrad=1 + elseif (index(controlcard,'CARINT').gt.0) then + icheckgrad=2 + else + icheckgrad=3 + endif + elseif (index(controlcard,'THREAD').gt.0) then + modecalc=2 + call readi(controlcard,'THREAD',nthread,0) + if (nthread.gt.0) then + call reada(controlcard,'WEIDIS',weidis,0.1D0) + else + if (fg_rank.eq.0) + & write (iout,'(a)')'A number has to follow the THREAD keyword.' + stop 'Error termination in Read_Control.' + endif + else if (index(controlcard,'MCMA').gt.0) then + modecalc=3 + else if (index(controlcard,'MCEE').gt.0) then + modecalc=6 + else if (index(controlcard,'MULTCONF').gt.0) then + modecalc=4 + else if (index(controlcard,'MAP').gt.0) then + modecalc=7 + call readi(controlcard,'MAP',nmap,0) + else if (index(controlcard,'CSA').gt.0) then + write(*,*) "CSA not supported in this version" + stop +csa modecalc=8 +crc else if (index(controlcard,'ZSCORE').gt.0) then +crc +crc ZSCORE is rm from UNRES, modecalc=9 is available +crc +crc modecalc=9 +cfcm else if (index(controlcard,'MCMF').gt.0) then +cfmc modecalc=10 + else if (index(controlcard,'SOFTREG').gt.0) then + modecalc=11 + else if (index(controlcard,'CHECK_BOND').gt.0) then + modecalc=-1 + else if (index(controlcard,'TEST').gt.0) then + modecalc=-2 + else if (index(controlcard,'MD').gt.0) then + modecalc=12 + else if (index(controlcard,'RE ').gt.0) then + modecalc=14 + endif + + lmuca=index(controlcard,'MUCA').gt.0 + call readi(controlcard,'MUCADYN',mucadyn,0) + call readi(controlcard,'MUCASMOOTH',muca_smooth,0) + if (lmuca .and. (me.eq.king .or. .not.out1file )) + & then + write (iout,*) 'MUCADYN=',mucadyn + write (iout,*) 'MUCASMOOTH=',muca_smooth + endif + + iscode=index(controlcard,'ONE_LETTER') + indphi=index(controlcard,'PHI') + indback=index(controlcard,'BACK') + iranconf=index(controlcard,'RAND_CONF') + i2ndstr=index(controlcard,'USE_SEC_PRED') + gradout=index(controlcard,'GRADOUT').gt.0 + gnorm_check=index(controlcard,'GNORM_CHECK').gt.0 + + if(me.eq.king.or..not.out1file) + & write (iout,'(2a)') diagmeth(kdiag), + & ' routine used to diagonalize matrices.' + return + end +c-------------------------------------------------------------------------- + subroutine read_REMDpar +C +C Read REMD settings +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.TIME1' + include 'COMMON.MD' +#ifndef LANG0 + include 'COMMON.LANGEVIN' +#else + include 'COMMON.LANGEVIN.lang0' +#endif + include 'COMMON.INTERACT' + include 'COMMON.NAMES' + include 'COMMON.GEO' + include 'COMMON.REMD' + include 'COMMON.CONTROL' + include 'COMMON.SETUP' + character*80 ucase + character*320 controlcard + character*3200 controlcard1 + integer iremd_m_total + + if(me.eq.king.or..not.out1file) + & write (iout,*) "REMD setup" + + call card_concat(controlcard) + call readi(controlcard,"NREP",nrep,3) + call readi(controlcard,"NSTEX",nstex,1000) + call reada(controlcard,"RETMIN",retmin,10.0d0) + call reada(controlcard,"RETMAX",retmax,1000.0d0) + mremdsync=(index(controlcard,'SYNC').gt.0) + call readi(controlcard,"NSYN",i_sync_step,100) + restart1file=(index(controlcard,'REST1FILE').gt.0) + traj1file=(index(controlcard,'TRAJ1FILE').gt.0) + call readi(controlcard,"TRAJCACHE",max_cache_traj_use,1) + if(max_cache_traj_use.gt.max_cache_traj) + & max_cache_traj_use=max_cache_traj + if(me.eq.king.or..not.out1file) then +cd if (traj1file) then +crc caching is in testing - NTWX is not ignored +cd write (iout,*) "NTWX value is ignored" +cd write (iout,*) " trajectory is stored to one file by master" +cd write (iout,*) " before exchange at NSTEX intervals" +cd endif + write (iout,*) "NREP= ",nrep + write (iout,*) "NSTEX= ",nstex + write (iout,*) "SYNC= ",mremdsync + write (iout,*) "NSYN= ",i_sync_step + write (iout,*) "TRAJCACHE= ",max_cache_traj_use + endif + + t_exchange_only=(index(controlcard,'TONLY').gt.0) + call readi(controlcard,"HREMD",hremd,0) + if((me.eq.king.or..not.out1file).and.hremd.gt.0) then + write (iout,*) "Hamiltonian REMD with ",hremd," sets of weights" + endif + if(usampl.and.hremd.gt.0) then + write (iout,'(//a)') + & "========== ERROR: USAMPL and HREMD cannot be used together" +#ifdef MPI + call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) +#endif + stop + endif + + + remd_tlist=.false. + if (index(controlcard,'TLIST').gt.0) then + remd_tlist=.true. + call card_concat(controlcard1) + read(controlcard1,*) (remd_t(i),i=1,nrep) + if(me.eq.king.or..not.out1file) + & write (iout,*)'tlist',(remd_t(i),i=1,nrep) + endif + remd_mlist=.false. + if (index(controlcard,'MLIST').gt.0) then + remd_mlist=.true. + call card_concat(controlcard1) + read(controlcard1,*) (remd_m(i),i=1,nrep) + if(me.eq.king.or..not.out1file) then + write (iout,*)'mlist',(remd_m(i),i=1,nrep) + iremd_m_total=0 + do i=1,nrep + iremd_m_total=iremd_m_total+remd_m(i) + enddo + if(hremd.gt.1)then + write (iout,*) 'Total number of replicas ', + & iremd_m_total*hremd + else + write (iout,*) 'Total number of replicas ',iremd_m_total + endif + endif + endif + if(me.eq.king.or..not.out1file) + & write (iout,'(/30(1h=),a,29(1h=)/)') " End of REMD run setup " + return + end +c-------------------------------------------------------------------------- + subroutine read_MDpar +C +C Read MD settings +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.TIME1' + include 'COMMON.MD' +#ifndef LANG0 + include 'COMMON.LANGEVIN' +#else + include 'COMMON.LANGEVIN.lang0' +#endif + include 'COMMON.INTERACT' + include 'COMMON.NAMES' + include 'COMMON.GEO' + include 'COMMON.SETUP' + include 'COMMON.CONTROL' + include 'COMMON.SPLITELE' + character*80 ucase + character*320 controlcard + + call card_concat(controlcard) + call readi(controlcard,"NSTEP",n_timestep,1000000) + call readi(controlcard,"NTWE",ntwe,100) + call readi(controlcard,"NTWX",ntwx,1000) + call reada(controlcard,"DT",d_time,1.0d-1) + call reada(controlcard,"DVMAX",dvmax,2.0d1) + call reada(controlcard,"DAMAX",damax,1.0d1) + call reada(controlcard,"EDRIFTMAX",edriftmax,1.0d+1) + call readi(controlcard,"LANG",lang,0) + RESPA = index(controlcard,"RESPA") .gt. 0 + call readi(controlcard,"NTIME_SPLIT",ntime_split,1) + ntime_split0=ntime_split + call readi(controlcard,"MAXTIME_SPLIT",maxtime_split,64) + ntime_split0=ntime_split + call reada(controlcard,"R_CUT",r_cut,2.0d0) + call reada(controlcard,"LAMBDA",rlamb,0.3d0) + rest = index(controlcard,"REST").gt.0 + tbf = index(controlcard,"TBF").gt.0 + call readi(controlcard,"HMC",hmc,0) + tnp = index(controlcard,"NOSEPOINCARE99").gt.0 + tnp1 = index(controlcard,"NOSEPOINCARE01").gt.0 + tnh = index(controlcard,"NOSEHOOVER96").gt.0 + if (RESPA.and.tnh)then + xiresp = index(controlcard,"XIRESP").gt.0 + endif + call reada(controlcard,"Q_NP",Q_np,0.1d0) + usampl = index(controlcard,"USAMPL").gt.0 + + mdpdb = index(controlcard,"MDPDB").gt.0 + call reada(controlcard,"T_BATH",t_bath,300.0d0) + call reada(controlcard,"TAU_BATH",tau_bath,1.0d-1) + call reada(controlcard,"EQ_TIME",eq_time,1.0d+4) + call readi(controlcard,"RESET_MOMENT",count_reset_moment,1000) + if (count_reset_moment.eq.0) count_reset_moment=1000000000 + call readi(controlcard,"RESET_VEL",count_reset_vel,1000) + reset_moment=lang.eq.0 .and. tbf .and. count_reset_moment.gt.0 + reset_vel=lang.eq.0 .and. tbf .and. count_reset_vel.gt.0 + if (count_reset_vel.eq.0) count_reset_vel=1000000000 + large = index(controlcard,"LARGE").gt.0 + print_compon = index(controlcard,"PRINT_COMPON").gt.0 + rattle = index(controlcard,"RATTLE").gt.0 +c if performing umbrella sampling, fragments constrained are read from the fragment file + nset=0 + if(usampl) then + call read_fragments + endif + + if(me.eq.king.or..not.out1file) then + write (iout,*) + write (iout,'(27(1h=),a26,27(1h=))') " Parameters of the MD run " + write (iout,*) + write (iout,'(a)') "The units are:" + write (iout,'(a)') "positions: angstrom, time: 48.9 fs" + write (iout,'(2a)') "velocity: angstrom/(48.9 fs),", + & " acceleration: angstrom/(48.9 fs)**2" + write (iout,'(a)') "energy: kcal/mol, temperature: K" + write (iout,*) + write (iout,'(a60,i10)') "Number of time steps:",n_timestep + write (iout,'(a60,f10.5,a)') + & "Initial time step of numerical integration:",d_time, + & " natural units" + write (iout,'(60x,f10.5,a)') d_time*48.9," fs" + if (RESPA) then + write (iout,'(2a,i4,a)') + & "A-MTS algorithm used; initial time step for fast-varying", + & " short-range forces split into",ntime_split," steps." + write (iout,'(a,f5.2,a,f5.2)') "Short-range force cutoff", + & r_cut," lambda",rlamb + endif + write (iout,'(2a,f10.5)') + & "Maximum acceleration threshold to reduce the time step", + & "/increase split number:",damax + write (iout,'(2a,f10.5)') + & "Maximum predicted energy drift to reduce the timestep", + & "/increase split number:",edriftmax + write (iout,'(a60,f10.5)') + & "Maximum velocity threshold to reduce velocities:",dvmax + write (iout,'(a60,i10)') "Frequency of property output:",ntwe + write (iout,'(a60,i10)') "Frequency of coordinate output:",ntwx + if (rattle) write (iout,'(a60)') + & "Rattle algorithm used to constrain the virtual bonds" + endif + reset_fricmat=1000 + if (lang.gt.0) then + call reada(controlcard,"ETAWAT",etawat,0.8904d0) + call reada(controlcard,"RWAT",rwat,1.4d0) + call reada(controlcard,"SCAL_FRIC",scal_fric,2.0d-2) + surfarea=index(controlcard,"SURFAREA").gt.0 + call readi(controlcard,"RESET_FRICMAT",reset_fricmat,1000) + if(me.eq.king.or..not.out1file)then + write (iout,'(/a,$)') "Langevin dynamics calculation" + if (lang.eq.1) then + write (iout,'(a/)') + & " with direct integration of Langevin equations" + else if (lang.eq.2) then + write (iout,'(a/)') " with TINKER stochasic MD integrator" + else if (lang.eq.3) then + write (iout,'(a/)') " with Ciccotti's stochasic MD integrator" + else if (lang.eq.4) then + write (iout,'(a/)') " in overdamped mode" + else + write (iout,'(//a,i5)') + & "=========== ERROR: Unknown Langevin dynamics mode:",lang + stop + endif + write (iout,'(a60,f10.5)') "Temperature:",t_bath + write (iout,'(a60,f10.5)') "Viscosity of the solvent:",etawat + write (iout,'(a60,f10.5)') "Radius of solvent molecule:",rwat + write (iout,'(a60,f10.5)') + & "Scaling factor of the friction forces:",scal_fric + if (surfarea) write (iout,'(2a,i10,a)') + & "Friction coefficients will be scaled by solvent-accessible", + & " surface area every",reset_fricmat," steps." + endif +c Calculate friction coefficients and bounds of stochastic forces + eta=6*pi*cPoise*etawat + if(me.eq.king.or..not.out1file) + & write(iout,'(a60,f10.5)')"Eta of the solvent in natural units:" + & ,eta + gamp=scal_fric*(pstok+rwat)*eta + stdfp=dsqrt(2*Rb*t_bath/d_time) + do i=1,ntyp + gamsc(i)=scal_fric*(restok(i)+rwat)*eta + stdfsc(i)=dsqrt(2*Rb*t_bath/d_time) + enddo + if(me.eq.king.or..not.out1file)then + write (iout,'(/2a/)') + & "Radii of site types and friction coefficients and std's of", + & " stochastic forces of fully exposed sites" + write (iout,'(a5,f5.2,2f10.5)')'p',pstok,gamp,stdfp*dsqrt(gamp) + do i=1,ntyp + write (iout,'(a5,f5.2,2f10.5)') restyp(i),restok(i), + & gamsc(i),stdfsc(i)*dsqrt(gamsc(i)) + enddo + endif + else if (tbf) then + if(me.eq.king.or..not.out1file)then + write (iout,'(a)') "Berendsen bath calculation" + write (iout,'(a60,f10.5)') "Temperature:",t_bath + write (iout,'(a60,f10.5)') "Coupling constant (tau):",tau_bath + if (reset_moment) + & write (iout,'(a,i10,a)') "Momenta will be reset at zero every", + & count_reset_moment," steps" + if (reset_vel) + & write (iout,'(a,i10,a)') + & "Velocities will be reset at random every",count_reset_vel, + & " steps" + endif + else if (tnp .or. tnp1 .or. tnh) then + if (tnp .or. tnp1) then + write (iout,'(a)') "Nose-Poincare bath calculation" + if (tnp) write (iout,'(a)') + & "J.Comput.Phys. 151 114 (1999) S.D.Bond B.J.Leimkuhler B.B.Laird" + if (tnp1) write (iout,'(a)') "JPSJ 70 75 (2001) S. Nose" + else + write (iout,'(a)') "Nose-Hoover bath calculation" + write (iout,'(a)') "Mol.Phys. 87 1117 (1996) Martyna et al." + nresn=1 + nyosh=1 + nnos=1 + do i=1,nnos + qmass(i)=Q_np + xlogs(i)=1.0 + vlogs(i)=0.0 + enddo + do i=1,nyosh + WDTI(i) = 1.0*d_time/nresn + WDTI2(i)=WDTI(i)/2 + WDTI4(i)=WDTI(i)/4 + WDTI8(i)=WDTI(i)/8 + enddo + if (RESPA) then + if(xiresp) then + write (iout,'(a)') "NVT-XI-RESPA algorithm" + else + write (iout,'(a)') "NVT-XO-RESPA algorithm" + endif + do i=1,nyosh + WDTIi(i) = 1.0*d_time/nresn/ntime_split + WDTIi2(i)=WDTIi(i)/2 + WDTIi4(i)=WDTIi(i)/4 + WDTIi8(i)=WDTIi(i)/8 + enddo + endif + endif + + write (iout,'(a60,f10.5)') "Temperature:",t_bath + write (iout,'(a60,f10.5)') "Q =",Q_np + if (reset_moment) + & write (iout,'(a,i10,a)') "Momenta will be reset at zero every", + & count_reset_moment," steps" + if (reset_vel) + & write (iout,'(a,i10,a)') + & "Velocities will be reset at random every",count_reset_vel, + & " steps" + + else if (hmc.gt.0) then + write (iout,'(a)') "Hybrid Monte Carlo calculation" + write (iout,'(a60,f10.5)') "Temperature:",t_bath + write (iout,'(a60,i10)') + & "Number of MD steps between Metropolis tests:",hmc + + else + if(me.eq.king.or..not.out1file) + & write (iout,'(a31)') "Microcanonical mode calculation" + endif + if(me.eq.king.or..not.out1file)then + if (rest) write (iout,'(/a/)') "===== Calculation restarted ====" + if (usampl) then + write(iout,*) "MD running with constraints." + write(iout,*) "Equilibration time ", eq_time, " mtus." + write(iout,*) "Constraining ", nfrag," fragments." + write(iout,*) "Length of each fragment, weight and q0:" + do iset=1,nset + write (iout,*) "Set of restraints #",iset + do i=1,nfrag + write(iout,'(2i5,f8.1,f7.4)') ifrag(1,i,iset), + & ifrag(2,i,iset),wfrag(i,iset),qinfrag(i,iset) + enddo + write(iout,*) "constraints between ", npair, "fragments." + write(iout,*) "constraint pairs, weights and q0:" + do i=1,npair + write(iout,'(2i5,f8.1,f7.4)') ipair(1,i,iset), + & ipair(2,i,iset),wpair(i,iset),qinpair(i,iset) + enddo + write(iout,*) "angle constraints within ", nfrag_back, + & "backbone fragments." + write(iout,*) "fragment, weights:" + do i=1,nfrag_back + write(iout,'(2i5,3f8.1)') ifrag_back(1,i,iset), + & ifrag_back(2,i,iset),wfrag_back(1,i,iset), + & wfrag_back(2,i,iset),wfrag_back(3,i,iset) + enddo + enddo + iset=mod(kolor,nset)+1 + endif + endif + if(me.eq.king.or..not.out1file) + & write (iout,'(/30(1h=),a,29(1h=)/)') " End of MD run setup " + return + end +c------------------------------------------------------------------------------ + subroutine molread +C +C Read molecular data. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' + integer error_msg +#endif + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.LOCAL' + include 'COMMON.NAMES' + include 'COMMON.CHAIN' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + include 'COMMON.HEADER' + include 'COMMON.CONTROL' + include 'COMMON.DBASE' + include 'COMMON.THREAD' + include 'COMMON.CONTACTS' + include 'COMMON.TORCNSTR' + include 'COMMON.TIME1' + include 'COMMON.BOUNDS' + include 'COMMON.MD' + include 'COMMON.REMD' + include 'COMMON.SETUP' + character*4 sequence(maxres) + integer rescode + double precision x(maxvar) + character*256 pdbfile + character*320 weightcard + character*80 weightcard_t,ucase + dimension itype_pdb(maxres) + common /pizda/ itype_pdb + logical seq_comp,fail + double precision energia(0:n_ene) + integer ilen + external ilen +C +C Body +C +C Read weights of the subsequent energy terms. + if(hremd.gt.0) then + + k=0 + do il=1,hremd + do i=1,nrep + do j=1,remd_m(i) + i2set(k)=il + k=k+1 + enddo + enddo + enddo + + if(me.eq.king.or..not.out1file) then + write (iout,*) 'Reading ',hremd,' sets of weights for HREMD' + write (iout,*) 'Current weights for processor ', + & me,' set ',i2set(me) + endif + + do i=1,hremd + call card_concat(weightcard) + call reada(weightcard,'WLONG',wlong,1.0D0) + call reada(weightcard,'WSC',wsc,wlong) + call reada(weightcard,'WSCP',wscp,wlong) + call reada(weightcard,'WELEC',welec,1.0D0) + call reada(weightcard,'WVDWPP',wvdwpp,welec) + call reada(weightcard,'WEL_LOC',wel_loc,1.0D0) + call reada(weightcard,'WCORR4',wcorr4,0.0D0) + call reada(weightcard,'WCORR5',wcorr5,0.0D0) + call reada(weightcard,'WCORR6',wcorr6,0.0D0) + call reada(weightcard,'WTURN3',wturn3,1.0D0) + call reada(weightcard,'WTURN4',wturn4,1.0D0) + call reada(weightcard,'WTURN6',wturn6,1.0D0) + call reada(weightcard,'WSCCOR',wsccor,1.0D0) + call reada(weightcard,'WSTRAIN',wstrain,1.0D0) + call reada(weightcard,'WBOND',wbond,1.0D0) + call reada(weightcard,'WTOR',wtor,1.0D0) + call reada(weightcard,'WTORD',wtor_d,1.0D0) + call reada(weightcard,'WANG',wang,1.0D0) + call reada(weightcard,'WSCLOC',wscloc,1.0D0) + call reada(weightcard,'SCAL14',scal14,0.4D0) + call reada(weightcard,'SCALSCP',scalscp,1.0d0) + call reada(weightcard,'CUTOFF',cutoff_corr,7.0d0) + call reada(weightcard,'DELT_CORR',delt_corr,0.5d0) + call reada(weightcard,'TEMP0',temp0,300.0d0) + if (index(weightcard,'SOFT').gt.0) ipot=6 +C 12/1/95 Added weight for the multi-body term WCORR + call reada(weightcard,'WCORRH',wcorr,1.0D0) + if (wcorr4.gt.0.0d0) wcorr=wcorr4 + + hweights(i,1)=wsc + hweights(i,2)=wscp + hweights(i,3)=welec + hweights(i,4)=wcorr + hweights(i,5)=wcorr5 + hweights(i,6)=wcorr6 + hweights(i,7)=wel_loc + hweights(i,8)=wturn3 + hweights(i,9)=wturn4 + hweights(i,10)=wturn6 + hweights(i,11)=wang + hweights(i,12)=wscloc + hweights(i,13)=wtor + hweights(i,14)=wtor_d + hweights(i,15)=wstrain + hweights(i,16)=wvdwpp + hweights(i,17)=wbond + hweights(i,18)=scal14 + hweights(i,21)=wsccor + + enddo + + do i=1,n_ene + weights(i)=hweights(i2set(me),i) + enddo + wsc =weights(1) + wscp =weights(2) + welec =weights(3) + wcorr =weights(4) + wcorr5 =weights(5) + wcorr6 =weights(6) + wel_loc=weights(7) + wturn3 =weights(8) + wturn4 =weights(9) + wturn6 =weights(10) + wang =weights(11) + wscloc =weights(12) + wtor =weights(13) + wtor_d =weights(14) + wstrain=weights(15) + wvdwpp =weights(16) + wbond =weights(17) + scal14 =weights(18) + wsccor =weights(21) + + + else + call card_concat(weightcard) + call reada(weightcard,'WLONG',wlong,1.0D0) + call reada(weightcard,'WSC',wsc,wlong) + call reada(weightcard,'WSCP',wscp,wlong) + call reada(weightcard,'WELEC',welec,1.0D0) + call reada(weightcard,'WVDWPP',wvdwpp,welec) + call reada(weightcard,'WEL_LOC',wel_loc,1.0D0) + call reada(weightcard,'WCORR4',wcorr4,0.0D0) + call reada(weightcard,'WCORR5',wcorr5,0.0D0) + call reada(weightcard,'WCORR6',wcorr6,0.0D0) + call reada(weightcard,'WTURN3',wturn3,1.0D0) + call reada(weightcard,'WTURN4',wturn4,1.0D0) + call reada(weightcard,'WTURN6',wturn6,1.0D0) + call reada(weightcard,'WSCCOR',wsccor,1.0D0) + call reada(weightcard,'WSTRAIN',wstrain,1.0D0) + call reada(weightcard,'WBOND',wbond,1.0D0) + call reada(weightcard,'WTOR',wtor,1.0D0) + call reada(weightcard,'WTORD',wtor_d,1.0D0) + call reada(weightcard,'WANG',wang,1.0D0) + call reada(weightcard,'WSCLOC',wscloc,1.0D0) + call reada(weightcard,'WDFAD',wdfa_dist,0.0d0) + call reada(weightcard,'WDFAT',wdfa_tor,0.0d0) + call reada(weightcard,'WDFAN',wdfa_nei,0.0d0) + call reada(weightcard,'WDFAB',wdfa_beta,0.0d0) + call reada(weightcard,'SCAL14',scal14,0.4D0) + call reada(weightcard,'SCALSCP',scalscp,1.0d0) + call reada(weightcard,'CUTOFF',cutoff_corr,7.0d0) + call reada(weightcard,'DELT_CORR',delt_corr,0.5d0) + call reada(weightcard,'TEMP0',temp0,300.0d0) + if (index(weightcard,'SOFT').gt.0) ipot=6 +C 12/1/95 Added weight for the multi-body term WCORR + call reada(weightcard,'WCORRH',wcorr,1.0D0) + if (wcorr4.gt.0.0d0) wcorr=wcorr4 + weights(1)=wsc + weights(2)=wscp + weights(3)=welec + weights(4)=wcorr + weights(5)=wcorr5 + weights(6)=wcorr6 + weights(7)=wel_loc + weights(8)=wturn3 + weights(9)=wturn4 + weights(10)=wturn6 + weights(11)=wang + weights(12)=wscloc + weights(13)=wtor + weights(14)=wtor_d + weights(15)=wstrain + weights(16)=wvdwpp + weights(17)=wbond + weights(18)=scal14 + weights(21)=wsccor + endif + weights(25)=wdfa_dist + weights(26)=wdfa_tor + weights(27)=wdfa_nei + weights(28)=wdfa_beta + + 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 + 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) + dyn_ss=(index(weightcard,'DYN_SS').gt.0) + do i=1,maxres + dyn_ss_mask(i)=.false. + enddo + do i=1,maxres-1 + do j=i+1,maxres + dyn_ssbond_ij(i,j)=1.0d300 + enddo + enddo + call reada(weightcard,"HT",Ht,0.0D0) + if (dyn_ss) then + ss_depth=ebr/wsc-0.25*eps(1,1) + Ht=Ht/wsc-0.25*eps(1,1) + akcm=akcm*wstrain/wsc + akth=akth*wstrain/wsc + akct=akct*wstrain/wsc + v1ss=v1ss*wstrain/wsc + v2ss=v2ss*wstrain/wsc + v3ss=v3ss*wstrain/wsc + else + ss_depth=ebr/wstrain-0.25*eps(1,1)*wsc/wstrain + endif + + 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," SS_DEPTH",ss_depth + write (iout,*)" HT",Ht + 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 +C Following 2 lines for diagnostics; comment out if not needed + write (iout,*) "Before sideadd" + call intout + if(me.eq.king.or..not.out1file) + & write(iout,*)'Adding sidechains' + maxsi=1000 + do i=2,nres-1 + iti=itype(i) + if (iti.ne.10) then + nsi=0 + fail=.true. + do while (fail.and.nsi.le.maxsi) + call gen_side(iti,theta(i+1),alph(i),omeg(i),fail) + nsi=nsi+1 + enddo + if(fail) write(iout,*)'Adding sidechain failed for res ', + & i,' after ',nsi,' trials' + endif + enddo +C 10/03/12 Adam: Recalculate coordinates with new side chain positions + call chainbuild + endif +C Following 2 lines for diagnostics; comment out if not needed +c write (iout,*) "After sideadd" +c call intout + 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 Bartek: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 + if (pdbref) then + if(me.eq.king.or..not.out1file) + & write (iout,'(a,i3)') 'nsup=',nsup + nstart_seq=nnt + if (nsup.le.(nct-nnt+1)) then + do i=0,nct-nnt+1-nsup + if (seq_comp(itype(nnt+i),itype_pdb(nstart_sup),nsup)) then + nstart_seq=nnt+i + goto 111 + endif + enddo + write (iout,'(a)') + & 'Error - sequences to be superposed do not match.' + stop + else + do i=0,nsup-(nct-nnt+1) + if (seq_comp(itype(nnt),itype_pdb(nstart_sup+i),nct-nnt+1)) + & then + nstart_sup=nstart_sup+i + nsup=nct-nnt+1 + goto 111 + endif + enddo + write (iout,'(a)') + & 'Error - sequences to be superposed do not match.' + endif + 111 continue + if (nsup.eq.0) nsup=nct-nnt + if (nstart_sup.eq.0) nstart_sup=nnt + if (nstart_seq.eq.0) nstart_seq=nnt + if(me.eq.king.or..not.out1file) + & write (iout,*) 'nsup=',nsup,' nstart_sup=',nstart_sup, + & ' nstart_seq=',nstart_seq + endif +c--- Zscore rms ------- + if (nz_start.eq.0) nz_start=nnt + if (nz_end.eq.0 .and. nsup.gt.0) then + nz_end=nnt+nsup-1 + else if (nz_end.eq.0) then + nz_end=nct + endif + if(me.eq.king.or..not.out1file)then + write (iout,*) 'NZ_START=',nz_start,' NZ_END=',nz_end + write (iout,*) 'IZ_SC=',iz_sc + endif +c---------------------- + call init_int_table + if (refstr) then + if (.not.pdbref) then + call read_angles(inp,*38) + goto 39 + 38 write (iout,'(a)') 'Error reading reference structure.' +#ifdef MPI + call MPI_Finalize(MPI_COMM_WORLD,IERROR) + stop 'Error reading reference structure' +#endif + 39 call chainbuild + call setup_var +czscore call geom_to_var(nvar,coord_exp_zs(1,1)) + nstart_sup=nnt + nstart_seq=nnt + nsup=nct-nnt+1 + do i=1,2*nres + do j=1,3 + cref(j,i)=c(j,i) + enddo + enddo + call contact(.true.,ncont_ref,icont_ref,co) + endif + if(me.eq.king.or..not.out1file) + & write (iout,*) 'Contact order:',co + if (pdbref) then + if(me.eq.king.or..not.out1file) + & write (2,*) 'Shifting contacts:',nstart_seq,nstart_sup + do i=1,ncont_ref + do j=1,2 + icont_ref(j,i)=icont_ref(j,i)+nstart_seq-nstart_sup + enddo + if(me.eq.king.or..not.out1file) + & write (2,*) i,' ',restyp(itype(icont_ref(1,i))),' ', + & icont_ref(1,i),' ', + & restyp(itype(icont_ref(2,i))),' ',icont_ref(2,i) + enddo + endif + endif +c write (iout,*) "constr_dist",constr_dist,nstart_sup,nsup + if (constr_dist.gt.0) then + call read_dist_constr + endif + + + if (constr_homology.gt.0) then + call read_constr_homology + endif + + + if (nhpb.gt.0) call hpb_partition +c write (iout,*) "After read_dist_constr nhpb",nhpb +c call flush(iout) + if (indpdb.eq.0 .and. modecalc.ne.2 .and. modecalc.ne.4 + & .and. modecalc.ne.8 .and. modecalc.ne.9 .and. + & modecalc.ne.10) then +C If input structure hasn't been supplied from the PDB file read or generate +C initial geometry. + if (iranconf.eq.0 .and. .not. extconf) then + if(me.eq.king.or..not.out1file .and.fg_rank.eq.0) + & write (iout,'(a)') 'Initial geometry will be read in.' + if (read_cart) then + read(inp,'(8f10.5)',end=36,err=36) + & ((c(l,k),l=1,3),k=1,nres), + & ((c(l,k+nres),l=1,3),k=nnt,nct) + call int_from_cart1(.false.) + do i=1,nres-1 + do j=1,3 + dc(j,i)=c(j,i+1)-c(j,i) + dc_norm(j,i)=dc_norm(j,i)*vbld_inv(i+1) + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + do j=1,3 + dc(j,i+nres)=c(j,i+nres)-c(j,i) + dc_norm(j,i+nres)=dc_norm(j,i+nres)*vbld_inv(i+nres) + enddo + endif + enddo + return + else + call read_angles(inp,*36) + endif + goto 37 + 36 write (iout,'(a)') 'Error reading angle file.' +#ifdef MPI + call mpi_finalize( MPI_COMM_WORLD,IERR ) +#endif + stop 'Error reading angle file.' + 37 continue + else if (extconf) then + if(me.eq.king.or..not.out1file .and. fg_rank.eq.0) + & write (iout,'(a)') 'Extended chain initial geometry.' + do i=3,nres + theta(i)=90d0*deg2rad + enddo + do i=4,nres + phi(i)=180d0*deg2rad + enddo + do i=2,nres-1 + alph(i)=110d0*deg2rad + enddo + do i=2,nres-1 + omeg(i)=-120d0*deg2rad + enddo + else + if(me.eq.king.or..not.out1file) + & write (iout,'(a)') 'Random-generated initial geometry.' + + +#ifdef MPI + if (me.eq.king .or. fg_rank.eq.0 .and. ( + & modecalc.eq.12 .or. modecalc.eq.14) ) then +#endif + do itrial=1,100 + itmp=1 + call gen_rand_conf(itmp,*30) + goto 40 + 30 write (iout,*) 'Failed to generate random conformation', + & ', itrial=',itrial + write (*,*) 'Processor:',me, + & ' Failed to generate random conformation', + & ' itrial=',itrial + call intout + +#ifdef AIX + call flush_(iout) +#else + call flush(iout) +#endif + enddo + write (iout,'(a,i3,a)') 'Processor:',me, + & ' error in generating random conformation.' + write (*,'(a,i3,a)') 'Processor:',me, + & ' error in generating random conformation.' + call flush(iout) +#ifdef MPI + call MPI_Abort(mpi_comm_world,error_msg,ierrcode) + 40 continue + endif +#else + 40 continue +#endif + endif + elseif (modecalc.eq.4) then + read (inp,'(a)') intinname + open (intin,file=intinname,status='old',err=333) + if (me.eq.king .or. .not.out1file.and.fg_rank.eq.0) + & write (iout,'(a)') 'intinname',intinname + write (*,'(a)') 'Processor',myrank,' intinname',intinname + goto 334 + 333 write (iout,'(2a)') 'Error opening angle file ',intinname +#ifdef MPI + call MPI_Finalize(MPI_COMM_WORLD,IERR) +#endif + stop 'Error opening angle file.' + 334 continue + + endif +C Generate distance constraints, if the PDB structure is to be regularized. + if (nthread.gt.0) then + call read_threadbase + endif + call setup_var + if (me.eq.king .or. .not. out1file) + & call intout + if (ns.gt.0 .and. (me.eq.king .or. .not.out1file) ) then + write (iout,'(/a,i3,a)') + & 'The chain contains',ns,' disulfide-bridging cysteines.' + write (iout,'(20i4)') (iss(i),i=1,ns) + if (dyn_ss) then + write(iout,*)"Running with dynamic disulfide-bond formation" + else + write (iout,'(/a/)') 'Pre-formed links are:' + do i=1,nss + i1=ihpb(i)-nres + i2=jhpb(i)-nres + it1=itype(i1) + it2=itype(i2) + write (iout,'(2a,i3,3a,i3,a,3f10.3)') + & restyp(it1),'(',i1,') -- ',restyp(it2),'(',i2,')',dhpb(i), + & ebr,forcon(i) + enddo + write (iout,'(a)') + endif + endif + if (ns.gt.0.and.dyn_ss) then + do i=nss+1,nhpb + ihpb(i-nss)=ihpb(i) + jhpb(i-nss)=jhpb(i) + forcon(i-nss)=forcon(i) + dhpb(i-nss)=dhpb(i) + enddo + nhpb=nhpb-nss + nss=0 + call hpb_partition + do i=1,ns + dyn_ss_mask(iss(i))=.true. + enddo + endif + if (i2ndstr.gt.0) call secstrp2dihc +c call geom_to_var(nvar,x) +c call etotal(energia(0)) +c call enerprint(energia(0)) +c call briefout(0,etot) +c stop +cd write (iout,'(2(a,i3))') 'NNT',NNT,' NCT',NCT +cd write (iout,'(a)') 'Variable list:' +cd write (iout,'(i4,f10.5)') (i,rad2deg*x(i),i=1,nvar) +#ifdef MPI + if (me.eq.king .or. (fg_rank.eq.0 .and. .not.out1file)) + & write (iout,'(//80(1h*)/20x,a,i4,a/80(1h*)//)') + & 'Processor',myrank,': end reading molecular data.' +#endif + return + end +c-------------------------------------------------------------------------- + logical function seq_comp(itypea,itypeb,length) + implicit none + integer length,itypea(length),itypeb(length) + integer i + do i=1,length + if (itypea(i).ne.itypeb(i)) then + seq_comp=.false. + return + endif + enddo + seq_comp=.true. + return + end +c----------------------------------------------------------------------------- + subroutine read_bridge +C Read information about disulfide bridges. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.LOCAL' + include 'COMMON.NAMES' + include 'COMMON.CHAIN' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + include 'COMMON.HEADER' + include 'COMMON.CONTROL' + include 'COMMON.DBASE' + include 'COMMON.THREAD' + include 'COMMON.TIME1' + include 'COMMON.SETUP' +C Read bridging residues. + read (inp,*) ns,(iss(i),i=1,ns) + print *,'ns=',ns + if(me.eq.king.or..not.out1file) + & write (iout,*) 'ns=',ns,' iss:',(iss(i),i=1,ns) +C Check whether the specified bridging residues are cystines. + do i=1,ns + if (itype(iss(i)).ne.1) then + if (me.eq.king.or..not.out1file) write (iout,'(2a,i3,a)') + & 'Do you REALLY think that the residue ', + & restyp(itype(iss(i))),i, + & ' can form a disulfide bridge?!!!' + write (*,'(2a,i3,a)') + & 'Do you REALLY think that the residue ', + & restyp(itype(iss(i))),i, + & ' can form a disulfide bridge?!!!' +#ifdef 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) + if(fg_rank.eq.0) + & write(iout,*)'nss=',nss,' ihpb,jhpb: ',(ihpb(i),jhpb(i),i=1,nss) + if (nss.gt.0) then + nhpb=nss +C Check if the residues involved in bridges are in the specified list of +C bridging residues. + do i=1,nss + do j=1,i-1 + if (ihpb(i).eq.ihpb(j).or.ihpb(i).eq.jhpb(j) + & .or.jhpb(i).eq.ihpb(j).or.jhpb(i).eq.jhpb(j)) then + write (iout,'(a,i3,a)') 'Disulfide pair',i, + & ' contains residues present in other pairs.' + write (*,'(a,i3,a)') 'Disulfide pair',i, + & ' contains residues present in other pairs.' +#ifdef MPI + call MPI_Finalize(MPI_COMM_WORLD,ierror) + stop +#endif + endif + enddo + do j=1,ns + if (ihpb(i).eq.iss(j)) goto 10 + enddo + write (iout,'(a,i3,a)') 'Pair',i,' contains unknown cystine.' + 10 continue + do j=1,ns + if (jhpb(i).eq.iss(j)) goto 20 + enddo + write (iout,'(a,i3,a)') 'Pair',i,' contains unknown cystine.' + 20 continue + dhpb(i)=dbr + forcon(i)=fbr + enddo + do i=1,nss + ihpb(i)=ihpb(i)+nres + jhpb(i)=jhpb(i)+nres + enddo + endif + endif + return + end +c---------------------------------------------------------------------------- + subroutine read_x(kanal,*) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.CONTROL' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' +c Read coordinates from input +c + read(kanal,'(8f10.5)',end=10,err=10) + & ((c(l,k),l=1,3),k=1,nres), + & ((c(l,k+nres),l=1,3),k=nnt,nct) + do j=1,3 + c(j,nres+1)=c(j,1) + c(j,2*nres)=c(j,nres) + enddo + call int_from_cart1(.false.) + do i=1,nres-1 + do j=1,3 + dc(j,i)=c(j,i+1)-c(j,i) + dc_norm(j,i)=dc(j,i)*vbld_inv(i+1) + enddo + enddo + do i=nnt,nct + if (itype(i).ne.10) then + do j=1,3 + dc(j,i+nres)=c(j,i+nres)-c(j,i) + dc_norm(j,i+nres)=dc(j,i+nres)*vbld_inv(i+nres) + enddo + endif + enddo + + return + 10 return1 + end +c---------------------------------------------------------------------------- + subroutine read_threadbase + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.LOCAL' + include 'COMMON.NAMES' + include 'COMMON.CHAIN' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + include 'COMMON.HEADER' + include 'COMMON.CONTROL' + include 'COMMON.DBASE' + include 'COMMON.THREAD' + include 'COMMON.TIME1' +C Read pattern database for threading. + read (icbase,*) nseq + do i=1,nseq + read (icbase,'(i5,2x,a8,2i4)') nres_base(1,i),str_nam(i), + & nres_base(2,i),nres_base(3,i) + read (icbase,'(9f8.3)') ((cart_base(k,j,i),k=1,3),j=1, + & nres_base(1,i)) +c write (iout,'(i5,2x,a8,2i4)') nres_base(1,i),str_nam(i), +c & nres_base(2,i),nres_base(3,i) +c write (iout,'(9f8.3)') ((cart_base(k,j,i),k=1,3),j=1, +c & nres_base(1,i)) + enddo + close (icbase) + if (weidis.eq.0.0D0) weidis=0.1D0 + do i=nnt,nct + do j=i+2,nct + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=weidis + enddo + enddo + read (inp,*) nexcl,(iexam(1,i),iexam(2,i),i=1,nexcl) + write (iout,'(a,i5)') 'nexcl: ',nexcl + write (iout,'(2i5)') (iexam(1,i),iexam(2,i),i=1,nexcl) + return + end +c------------------------------------------------------------------------------ + subroutine setup_var + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.LOCAL' + include 'COMMON.NAMES' + include 'COMMON.CHAIN' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + include 'COMMON.HEADER' + include 'COMMON.CONTROL' + include 'COMMON.DBASE' + include 'COMMON.THREAD' + include 'COMMON.TIME1' +C Set up variable list. + ntheta=nres-2 + nphi=nres-3 + nvar=ntheta+nphi + nside=0 + do i=2,nres-1 + if (itype(i).ne.10) then + nside=nside+1 + ialph(i,1)=nvar+nside + ialph(nside,2)=i + endif + enddo + if (indphi.gt.0) then + nvar=nphi + else if (indback.gt.0) then + nvar=nphi+ntheta + else + nvar=nvar+2*nside + endif +cd write (iout,'(3i4)') (i,ialph(i,1),ialph(i,2),i=2,nres-1) + return + end +c---------------------------------------------------------------------------- + subroutine gen_dist_constr +C Generate CA distance constraints. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.LOCAL' + include 'COMMON.NAMES' + include 'COMMON.CHAIN' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + include 'COMMON.HEADER' + include 'COMMON.CONTROL' + include 'COMMON.DBASE' + include 'COMMON.THREAD' + include 'COMMON.TIME1' + dimension itype_pdb(maxres) + common /pizda/ itype_pdb + character*2 iden +cd print *,'gen_dist_constr: nnt=',nnt,' nct=',nct +cd write (2,*) 'gen_dist_constr: nnt=',nnt,' nct=',nct, +cd & ' nstart_sup',nstart_sup,' nstart_seq',nstart_seq, +cd & ' nsup',nsup + do i=nstart_sup,nstart_sup+nsup-1 +cd write (2,*) 'i',i,' seq ',restyp(itype(i+nstart_seq-nstart_sup)), +cd & ' seq_pdb', restyp(itype_pdb(i)) + do j=i+2,nstart_sup+nsup-1 + nhpb=nhpb+1 + ihpb(nhpb)=i+nstart_seq-nstart_sup + jhpb(nhpb)=j+nstart_seq-nstart_sup + forcon(nhpb)=weidis + dhpb(nhpb)=dist(i,j) + enddo + enddo +cd write (iout,'(a)') 'Distance constraints:' +cd do i=nss+1,nhpb +cd ii=ihpb(i) +cd jj=jhpb(i) +cd iden='CA' +cd if (ii.gt.nres) then +cd iden='SC' +cd ii=ii-nres +cd jj=jj-nres +cd endif +cd write (iout,'(a,1x,a,i4,3x,a,1x,a,i4,2f10.3)') +cd & restyp(itype(ii)),iden,ii,restyp(itype(jj)),iden,jj, +cd & dhpb(i),forcon(i) +cd enddo + return + end +c---------------------------------------------------------------------------- + subroutine map_read + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.MAP' + include 'COMMON.IOUNITS' + character*3 angid(4) /'THE','PHI','ALP','OME'/ + character*80 mapcard,ucase + do imap=1,nmap + read (inp,'(a)') mapcard + mapcard=ucase(mapcard) + if (index(mapcard,'PHI').gt.0) then + kang(imap)=1 + else if (index(mapcard,'THE').gt.0) then + kang(imap)=2 + else if (index(mapcard,'ALP').gt.0) then + kang(imap)=3 + else if (index(mapcard,'OME').gt.0) then + kang(imap)=4 + else + write(iout,'(a)')'Error - illegal variable spec in MAP card.' + stop 'Error - illegal variable spec in MAP card.' + endif + call readi (mapcard,'RES1',res1(imap),0) + call readi (mapcard,'RES2',res2(imap),0) + if (res1(imap).eq.0) then + res1(imap)=res2(imap) + else if (res2(imap).eq.0) then + res2(imap)=res1(imap) + endif + if(res1(imap)*res2(imap).eq.0 .or. res1(imap).gt.res2(imap))then + write (iout,'(a)') + & 'Error - illegal definition of variable group in MAP.' + stop 'Error - illegal definition of variable group in MAP.' + endif + call reada(mapcard,'FROM',ang_from(imap),0.0D0) + call reada(mapcard,'TO',ang_to(imap),0.0D0) + call readi(mapcard,'NSTEP',nstep(imap),0) + if (ang_from(imap).eq.ang_to(imap) .or. nstep(imap).eq.0) then + write (iout,'(a)') + & 'Illegal boundary and/or step size specification in MAP.' + stop 'Illegal boundary and/or step size specification in MAP.' + endif + enddo ! imap + return + end +c---------------------------------------------------------------------------- +csa subroutine csaread +csa implicit real*8 (a-h,o-z) +csa include 'DIMENSIONS' +csa include 'COMMON.IOUNITS' +csa include 'COMMON.GEO' +csa include 'COMMON.CSA' +csa include 'COMMON.BANK' +csa include 'COMMON.CONTROL' +csa character*80 ucase +csa character*620 mcmcard +csa call card_concat(mcmcard) +csa +csa call readi(mcmcard,'NCONF',nconf,50) +csa call readi(mcmcard,'NADD',nadd,0) +csa call readi(mcmcard,'JSTART',jstart,1) +csa call readi(mcmcard,'JEND',jend,1) +csa call readi(mcmcard,'NSTMAX',nstmax,500000) +csa call readi(mcmcard,'N0',n0,1) +csa call readi(mcmcard,'N1',n1,6) +csa call readi(mcmcard,'N2',n2,4) +csa call readi(mcmcard,'N3',n3,0) +csa call readi(mcmcard,'N4',n4,0) +csa call readi(mcmcard,'N5',n5,0) +csa call readi(mcmcard,'N6',n6,10) +csa call readi(mcmcard,'N7',n7,0) +csa call readi(mcmcard,'N8',n8,0) +csa call readi(mcmcard,'N9',n9,0) +csa call readi(mcmcard,'N14',n14,0) +csa call readi(mcmcard,'N15',n15,0) +csa call readi(mcmcard,'N16',n16,0) +csa call readi(mcmcard,'N17',n17,0) +csa call readi(mcmcard,'N18',n18,0) +csa +csa vdisulf=(index(mcmcard,'DYNSS').gt.0) +csa +csa call readi(mcmcard,'NDIFF',ndiff,2) +csa call reada(mcmcard,'DIFFCUT',diffcut,0.0d0) +csa call readi(mcmcard,'IS1',is1,1) +csa call readi(mcmcard,'IS2',is2,8) +csa call readi(mcmcard,'NRAN0',nran0,4) +csa call readi(mcmcard,'NRAN1',nran1,2) +csa call readi(mcmcard,'IRR',irr,1) +csa call readi(mcmcard,'NSEED',nseed,20) +csa call readi(mcmcard,'NTOTAL',ntotal,10000) +csa call reada(mcmcard,'CUT1',cut1,2.0d0) +csa call reada(mcmcard,'CUT2',cut2,5.0d0) +csa call reada(mcmcard,'ESTOP',estop,-3000.0d0) +csa call readi(mcmcard,'ICMAX',icmax,3) +csa call readi(mcmcard,'IRESTART',irestart,0) +csac!bankt call readi(mcmcard,'NBANKTM',ntbankm,0) +csa ntbankm=0 +csac!bankt +csa call reada(mcmcard,'DELE',dele,20.0d0) +csa call reada(mcmcard,'DIFCUT',difcut,720.0d0) +csa call readi(mcmcard,'IREF',iref,0) +csa call reada(mcmcard,'RMSCUT',rmscut,4.0d0) +csa call reada(mcmcard,'PNCCUT',pnccut,0.5d0) +csa call readi(mcmcard,'NCONF_IN',nconf_in,0) +csa call reada(mcmcard,'RDIH_BIAS',rdih_bias,0.5d0) +csa write (iout,*) "NCONF_IN",nconf_in +csa return +csa end +c---------------------------------------------------------------------------- +cfmc subroutine mcmfread +cfmc implicit real*8 (a-h,o-z) +cfmc include 'DIMENSIONS' +cfmc include 'COMMON.MCMF' +cfmc include 'COMMON.IOUNITS' +cfmc include 'COMMON.GEO' +cfmc character*80 ucase +cfmc character*620 mcmcard +cfmc call card_concat(mcmcard) +cfmc +cfmc call readi(mcmcard,'MAXRANT',maxrant,1000) +cfmc write(iout,*)'MAXRANT=',maxrant +cfmc call readi(mcmcard,'MAXFAM',maxfam,maxfam_p) +cfmc write(iout,*)'MAXFAM=',maxfam +cfmc call readi(mcmcard,'NNET1',nnet1,5) +cfmc write(iout,*)'NNET1=',nnet1 +cfmc call readi(mcmcard,'NNET2',nnet2,4) +cfmc write(iout,*)'NNET2=',nnet2 +cfmc call readi(mcmcard,'NNET3',nnet3,4) +cfmc write(iout,*)'NNET3=',nnet3 +cfmc call readi(mcmcard,'ILASTT',ilastt,0) +cfmc write(iout,*)'ILASTT=',ilastt +cfmc call readi(mcmcard,'MAXSTR',maxstr,maxstr_mcmf) +cfmc write(iout,*)'MAXSTR=',maxstr +cfmc maxstr_f=maxstr/maxfam +cfmc write(iout,*)'MAXSTR_F=',maxstr_f +cfmc call readi(mcmcard,'NMCMF',nmcmf,10) +cfmc write(iout,*)'NMCMF=',nmcmf +cfmc call readi(mcmcard,'IFOCUS',ifocus,nmcmf) +cfmc write(iout,*)'IFOCUS=',ifocus +cfmc call readi(mcmcard,'NLOCMCMF',nlocmcmf,1000) +cfmc write(iout,*)'NLOCMCMF=',nlocmcmf +cfmc call readi(mcmcard,'INTPRT',intprt,1000) +cfmc write(iout,*)'INTPRT=',intprt +cfmc call readi(mcmcard,'IPRT',iprt,100) +cfmc write(iout,*)'IPRT=',iprt +cfmc call readi(mcmcard,'IMAXTR',imaxtr,100) +cfmc write(iout,*)'IMAXTR=',imaxtr +cfmc call readi(mcmcard,'MAXEVEN',maxeven,1000) +cfmc write(iout,*)'MAXEVEN=',maxeven +cfmc call readi(mcmcard,'MAXEVEN1',maxeven1,3) +cfmc write(iout,*)'MAXEVEN1=',maxeven1 +cfmc call readi(mcmcard,'INIMIN',inimin,200) +cfmc write(iout,*)'INIMIN=',inimin +cfmc call readi(mcmcard,'NSTEPMCMF',nstepmcmf,10) +cfmc write(iout,*)'NSTEPMCMF=',nstepmcmf +cfmc call readi(mcmcard,'NTHREAD',nthread,5) +cfmc write(iout,*)'NTHREAD=',nthread +cfmc call readi(mcmcard,'MAXSTEPMCMF',maxstepmcmf,2500) +cfmc write(iout,*)'MAXSTEPMCMF=',maxstepmcmf +cfmc call readi(mcmcard,'MAXPERT',maxpert,9) +cfmc write(iout,*)'MAXPERT=',maxpert +cfmc call readi(mcmcard,'IRMSD',irmsd,1) +cfmc write(iout,*)'IRMSD=',irmsd +cfmc call reada(mcmcard,'DENEMIN',denemin,0.01D0) +cfmc write(iout,*)'DENEMIN=',denemin +cfmc call reada(mcmcard,'RCUT1S',rcut1s,3.5D0) +cfmc write(iout,*)'RCUT1S=',rcut1s +cfmc call reada(mcmcard,'RCUT1E',rcut1e,2.0D0) +cfmc write(iout,*)'RCUT1E=',rcut1e +cfmc call reada(mcmcard,'RCUT2S',rcut2s,0.5D0) +cfmc write(iout,*)'RCUT2S=',rcut2s +cfmc call reada(mcmcard,'RCUT2E',rcut2e,0.1D0) +cfmc write(iout,*)'RCUT2E=',rcut2e +cfmc call reada(mcmcard,'DPERT1',d_pert1,180.0D0) +cfmc write(iout,*)'DPERT1=',d_pert1 +cfmc call reada(mcmcard,'DPERT1A',d_pert1a,180.0D0) +cfmc write(iout,*)'DPERT1A=',d_pert1a +cfmc call reada(mcmcard,'DPERT2',d_pert2,90.0D0) +cfmc write(iout,*)'DPERT2=',d_pert2 +cfmc call reada(mcmcard,'DPERT2A',d_pert2a,45.0D0) +cfmc write(iout,*)'DPERT2A=',d_pert2a +cfmc call reada(mcmcard,'DPERT2B',d_pert2b,90.0D0) +cfmc write(iout,*)'DPERT2B=',d_pert2b +cfmc call reada(mcmcard,'DPERT2C',d_pert2c,60.0D0) +cfmc write(iout,*)'DPERT2C=',d_pert2c +cfmc d_pert1=deg2rad*d_pert1 +cfmc d_pert1a=deg2rad*d_pert1a +cfmc d_pert2=deg2rad*d_pert2 +cfmc d_pert2a=deg2rad*d_pert2a +cfmc d_pert2b=deg2rad*d_pert2b +cfmc d_pert2c=deg2rad*d_pert2c +cfmc call reada(mcmcard,'KT_MCMF1',kt_mcmf1,1.0D0) +cfmc write(iout,*)'KT_MCMF1=',kt_mcmf1 +cfmc call reada(mcmcard,'KT_MCMF2',kt_mcmf2,1.0D0) +cfmc write(iout,*)'KT_MCMF2=',kt_mcmf2 +cfmc call reada(mcmcard,'DKT_MCMF1',dkt_mcmf1,10.0D0) +cfmc write(iout,*)'DKT_MCMF1=',dkt_mcmf1 +cfmc call reada(mcmcard,'DKT_MCMF2',dkt_mcmf2,1.0D0) +cfmc write(iout,*)'DKT_MCMF2=',dkt_mcmf2 +cfmc call reada(mcmcard,'RCUTINI',rcutini,3.5D0) +cfmc write(iout,*)'RCUTINI=',rcutini +cfmc call reada(mcmcard,'GRAT',grat,0.5D0) +cfmc write(iout,*)'GRAT=',grat +cfmc call reada(mcmcard,'BIAS_MCMF',bias_mcmf,0.0D0) +cfmc write(iout,*)'BIAS_MCMF=',bias_mcmf +cfmc +cfmc return +cfmc end +c---------------------------------------------------------------------------- + subroutine mcmread + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.MCM' + include 'COMMON.MCE' + include 'COMMON.IOUNITS' + character*80 ucase + character*320 mcmcard + call card_concat(mcmcard) + call readi(mcmcard,'MAXACC',maxacc,100) + call readi(mcmcard,'MAX_MCM_IT',max_mcm_it,10000) + call readi(mcmcard,'MAXTRIAL',maxtrial,100) + call readi(mcmcard,'MAXTRIAL_ITER',maxtrial_iter,1000) + call readi(mcmcard,'MAXREPM',maxrepm,200) + call reada(mcmcard,'RANFRACT',RanFract,0.5D0) + call reada(mcmcard,'POOL_FRACT',pool_fraction,0.01D0) + call reada(mcmcard,'OVERLAP',overlap_cut,1.0D3) + call reada(mcmcard,'E_UP',e_up,5.0D0) + call reada(mcmcard,'DELTE',delte,0.1D0) + call readi(mcmcard,'NSWEEP',nsweep,5) + call readi(mcmcard,'NSTEPH',nsteph,0) + call readi(mcmcard,'NSTEPC',nstepc,0) + call reada(mcmcard,'TMIN',tmin,298.0D0) + call reada(mcmcard,'TMAX',tmax,298.0D0) + call readi(mcmcard,'NWINDOW',nwindow,0) + call readi(mcmcard,'PRINT_MC',print_mc,0) + print_stat=(index(mcmcard,'NO_PRINT_STAT').le.0) + print_int=(index(mcmcard,'NO_PRINT_INT').le.0) + ent_read=(index(mcmcard,'ENT_READ').gt.0) + call readi(mcmcard,'SAVE_FREQ',save_frequency,1000) + call readi(mcmcard,'MESSAGE_FREQ',message_frequency,1000) + call readi(mcmcard,'POOL_READ_FREQ',pool_read_freq,5000) + call readi(mcmcard,'POOL_SAVE_FREQ',pool_save_freq,1000) + call readi(mcmcard,'PRINT_FREQ',print_freq,1000) + if (nwindow.gt.0) then + read (inp,*) (winstart(i),winend(i),i=1,nwindow) + do i=1,nwindow + winlen(i)=winend(i)-winstart(i)+1 + enddo + endif + if (tmax.lt.tmin) tmax=tmin + if (tmax.eq.tmin) then + nstepc=0 + nsteph=0 + endif + if (nstepc.gt.0 .and. nsteph.gt.0) then + tsteph=(tmax/tmin)**(1.0D0/(nsteph+0.0D0)) + tstepc=(tmax/tmin)**(1.0D0/(nstepc+0.0D0)) + endif +C Probabilities of different move types + sumpro_type(0)=0.0D0 + call reada(mcmcard,'MULTI_BOND',sumpro_type(1),1.0d0) + call reada(mcmcard,'ONE_ANGLE' ,sumpro_type(2),2.0d0) + sumpro_type(2)=sumpro_type(1)+sumpro_type(2) + call reada(mcmcard,'THETA' ,sumpro_type(3),0.0d0) + sumpro_type(3)=sumpro_type(2)+sumpro_type(3) + call reada(mcmcard,'SIDE_CHAIN',sumpro_type(4),0.5d0) + sumpro_type(4)=sumpro_type(3)+sumpro_type(4) + do i=1,MaxMoveType + print *,'i',i,' sumprotype',sumpro_type(i) + sumpro_type(i)=sumpro_type(i)/sumpro_type(MaxMoveType) + print *,'i',i,' sumprotype',sumpro_type(i) + enddo + return + end +c---------------------------------------------------------------------------- + subroutine read_minim + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.MINIM' + include 'COMMON.IOUNITS' + character*80 ucase + character*320 minimcard + call card_concat(minimcard) + call readi(minimcard,'MAXMIN',maxmin,2000) + call readi(minimcard,'MAXFUN',maxfun,5000) + call readi(minimcard,'MINMIN',minmin,maxmin) + call readi(minimcard,'MINFUN',minfun,maxmin) + call reada(minimcard,'TOLF',tolf,1.0D-2) + call reada(minimcard,'RTOLF',rtolf,1.0D-4) + print_min_stat=min0(index(minimcard,'PRINT_MIN_STAT'),1) + print_min_res=min0(index(minimcard,'PRINT_MIN_RES'),1) + print_min_ini=min0(index(minimcard,'PRINT_MIN_INI'),1) + write (iout,'(/80(1h*)/20x,a/80(1h*))') + & 'Options in energy minimization:' + write (iout,'(4(a,i5),a,1pe14.5,a,1pe14.5)') + & 'MaxMin:',MaxMin,' MaxFun:',MaxFun, + & 'MinMin:',MinMin,' MinFun:',MinFun, + & ' TolF:',TolF,' RTolF:',RTolF + return + end +c---------------------------------------------------------------------------- + subroutine read_angles(kanal,*) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.CONTROL' +c Read angles from input +c + read (kanal,*,err=10,end=10) (theta(i),i=3,nres) + read (kanal,*,err=10,end=10) (phi(i),i=4,nres) + read (kanal,*,err=10,end=10) (alph(i),i=2,nres-1) + read (kanal,*,err=10,end=10) (omeg(i),i=2,nres-1) + + do i=1,nres +c 9/7/01 avoid 180 deg valence angle + if (theta(i).gt.179.99d0) theta(i)=179.99d0 +c + theta(i)=deg2rad*theta(i) + phi(i)=deg2rad*phi(i) + alph(i)=deg2rad*alph(i) + omeg(i)=deg2rad*omeg(i) + enddo + return + 10 return1 + end +c---------------------------------------------------------------------------- + subroutine reada(rekord,lancuch,wartosc,default) + implicit none + character*(*) rekord,lancuch + double precision wartosc,default + integer ilen,iread + external ilen + iread=index(rekord,lancuch) + if (iread.eq.0) then + wartosc=default + return + endif + iread=iread+ilen(lancuch)+1 + read (rekord(iread:),*,err=10,end=10) wartosc + return + 10 wartosc=default + return + end +c---------------------------------------------------------------------------- + subroutine readi(rekord,lancuch,wartosc,default) + implicit none + character*(*) rekord,lancuch + integer wartosc,default + integer ilen,iread + external ilen + iread=index(rekord,lancuch) + if (iread.eq.0) then + wartosc=default + return + endif + iread=iread+ilen(lancuch)+1 + read (rekord(iread:),*,err=10,end=10) wartosc + return + 10 wartosc=default + return + end +c---------------------------------------------------------------------------- + subroutine multreadi(rekord,lancuch,tablica,dim,default) + implicit none + integer dim,i + integer tablica(dim),default + character*(*) rekord,lancuch + character*80 aux + integer ilen,iread + external ilen + do i=1,dim + tablica(i)=default + enddo + iread=index(rekord,lancuch(:ilen(lancuch))//"=") + if (iread.eq.0) return + iread=iread+ilen(lancuch)+1 + read (rekord(iread:),*,end=10,err=10) (tablica(i),i=1,dim) + 10 return + end +c---------------------------------------------------------------------------- + subroutine multreada(rekord,lancuch,tablica,dim,default) + implicit none + integer dim,i + double precision tablica(dim),default + character*(*) rekord,lancuch + character*80 aux + integer ilen,iread + external ilen + do i=1,dim + tablica(i)=default + enddo + iread=index(rekord,lancuch(:ilen(lancuch))//"=") + if (iread.eq.0) return + iread=iread+ilen(lancuch)+1 + read (rekord(iread:),*,end=10,err=10) (tablica(i),i=1,dim) + 10 return + end +c---------------------------------------------------------------------------- + subroutine openunits + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' + character*16 form,nodename + integer nodelen +#endif + include 'COMMON.SETUP' + include 'COMMON.IOUNITS' + include 'COMMON.MD' + include 'COMMON.CONTROL' + integer lenpre,lenpot,ilen,lentmp + external ilen + character*3 out1file_text,ucase + character*3 ll + external ucase +c print *,"Processor",myrank,"fg_rank",fg_rank," entered openunits" + call getenv_loc("PREFIX",prefix) + pref_orig = prefix + call getenv_loc("POT",pot) + call getenv_loc("DIRTMP",tmpdir) + call getenv_loc("CURDIR",curdir) + call getenv_loc("OUT1FILE",out1file_text) +c print *,"Processor",myrank,"fg_rank",fg_rank," did GETENV" + out1file_text=ucase(out1file_text) + if (out1file_text(1:1).eq."Y") then + out1file=.true. + else + out1file=fg_rank.gt.0 + endif + lenpre=ilen(prefix) + lenpot=ilen(pot) + lentmp=ilen(tmpdir) + if (lentmp.gt.0) then + write (*,'(80(1h!))') + write (*,'(a,19x,a,19x,a)') "!"," A T T E N T I O N ","!" + write (*,'(80(1h!))') + write (*,*)"All output files will be on node /tmp directory." +#ifdef MPI + call MPI_GET_PROCESSOR_NAME( nodename, nodelen, IERROR ) + if (me.eq.king) then + write (*,*) "The master node is ",nodename + else if (fg_rank.eq.0) then + write (*,*) "I am the CG slave node ",nodename + else + write (*,*) "I am the FG slave node ",nodename + endif +#endif + PREFIX = tmpdir(:lentmp)//'/'//prefix(:lenpre) + lenpre = lentmp+lenpre+1 + endif + entname=prefix(:lenpre)//'_'//pot(:lenpot)//'.entr' +C Get the names and open the input files +#if defined(WINIFL) || defined(WINPGI) + open(1,file=pref_orig(:ilen(pref_orig))// + & '.inp',status='old',readonly,shared) + open (9,file=prefix(:ilen(prefix))//'.intin',status='unknown') +C open (18,file=prefix(:ilen(prefix))//'.entin',status='unknown') +C Get parameter filenames and open the parameter files. + call getenv_loc('BONDPAR',bondname) + open (ibond,file=bondname,status='old',readonly,shared) + call getenv_loc('THETPAR',thetname) + open (ithep,file=thetname,status='old',readonly,shared) +#ifndef CRYST_THETA + call getenv_loc('THETPARPDB',thetname_pdb) + open (ithep_pdb,file=thetname_pdb,status='old',readonly,shared) +#endif + call getenv_loc('ROTPAR',rotname) + open (irotam,file=rotname,status='old',readonly,shared) +#ifndef CRYST_SC + call getenv_loc('ROTPARPDB',rotname_pdb) + open (irotam_pdb,file=rotname_pdb,status='old',readonly,shared) +#endif + call getenv_loc('TORPAR',torname) + open (itorp,file=torname,status='old',readonly,shared) + call getenv_loc('TORDPAR',tordname) + open (itordp,file=tordname,status='old',readonly,shared) + call getenv_loc('FOURIER',fouriername) + open (ifourier,file=fouriername,status='old',readonly,shared) + call getenv_loc('ELEPAR',elename) + open (ielep,file=elename,status='old',readonly,shared) + call getenv_loc('SIDEPAR',sidename) + open (isidep,file=sidename,status='old',readonly,shared) +#elif (defined CRAY) || (defined AIX) + open(1,file=pref_orig(:ilen(pref_orig))//'.inp',status='old', + & action='read') +c print *,"Processor",myrank," opened file 1" + open (9,file=prefix(:ilen(prefix))//'.intin',status='unknown') +c print *,"Processor",myrank," opened file 9" +C open (18,file=prefix(:ilen(prefix))//'.entin',status='unknown') +C Get parameter filenames and open the parameter files. + call getenv_loc('BONDPAR',bondname) + open (ibond,file=bondname,status='old',action='read') +c print *,"Processor",myrank," opened file IBOND" + call getenv_loc('THETPAR',thetname) + open (ithep,file=thetname,status='old',action='read') +c print *,"Processor",myrank," opened file ITHEP" +#ifndef CRYST_THETA + call getenv_loc('THETPARPDB',thetname_pdb) + open (ithep_pdb,file=thetname_pdb,status='old',action='read') +#endif + call getenv_loc('ROTPAR',rotname) + open (irotam,file=rotname,status='old',action='read') +c print *,"Processor",myrank," opened file IROTAM" +#ifndef CRYST_SC + call getenv_loc('ROTPARPDB',rotname_pdb) + open (irotam_pdb,file=rotname_pdb,status='old',action='read') +#endif + call getenv_loc('TORPAR',torname) + open (itorp,file=torname,status='old',action='read') +c print *,"Processor",myrank," opened file ITORP" + call getenv_loc('TORDPAR',tordname) + open (itordp,file=tordname,status='old',action='read') +c print *,"Processor",myrank," opened file ITORDP" + call getenv_loc('SCCORPAR',sccorname) + open (isccor,file=sccorname,status='old',action='read') +c print *,"Processor",myrank," opened file ISCCOR" + call getenv_loc('FOURIER',fouriername) + open (ifourier,file=fouriername,status='old',action='read') +c print *,"Processor",myrank," opened file IFOURIER" + call getenv_loc('ELEPAR',elename) + open (ielep,file=elename,status='old',action='read') +c print *,"Processor",myrank," opened file IELEP" + call getenv_loc('SIDEPAR',sidename) + open (isidep,file=sidename,status='old',action='read') +c print *,"Processor",myrank," opened file ISIDEP" +c print *,"Processor",myrank," opened parameter files" +#elif (defined G77) + open(1,file=pref_orig(:ilen(pref_orig))//'.inp',status='old') + open (9,file=prefix(:ilen(prefix))//'.intin',status='unknown') +C open (18,file=prefix(:ilen(prefix))//'.entin',status='unknown') +C Get parameter filenames and open the parameter files. + call getenv_loc('BONDPAR',bondname) + open (ibond,file=bondname,status='old') + call getenv_loc('THETPAR',thetname) + open (ithep,file=thetname,status='old') +#ifndef CRYST_THETA + call getenv_loc('THETPARPDB',thetname_pdb) + open (ithep_pdb,file=thetname_pdb,status='old') +#endif + call getenv_loc('ROTPAR',rotname) + open (irotam,file=rotname,status='old') +#ifndef CRYST_SC + call getenv_loc('ROTPARPDB',rotname_pdb) + open (irotam_pdb,file=rotname_pdb,status='old') +#endif + call getenv_loc('TORPAR',torname) + open (itorp,file=torname,status='old') + call getenv_loc('TORDPAR',tordname) + open (itordp,file=tordname,status='old') + call getenv_loc('SCCORPAR',sccorname) + open (isccor,file=sccorname,status='old') + call getenv_loc('FOURIER',fouriername) + open (ifourier,file=fouriername,status='old') + call getenv_loc('ELEPAR',elename) + open (ielep,file=elename,status='old') + call getenv_loc('SIDEPAR',sidename) + open (isidep,file=sidename,status='old') +#else + open(1,file=pref_orig(:ilen(pref_orig))//'.inp',status='old', + &action='read') + open (9,file=prefix(:ilen(prefix))//'.intin',status='unknown') +C open (18,file=prefix(:ilen(prefix))//'.entin',status='unknown') +C Get parameter filenames and open the parameter files. + call getenv_loc('BONDPAR',bondname) + open (ibond,file=bondname,status='old',action='read') + call getenv_loc('THETPAR',thetname) + open (ithep,file=thetname,status='old',action='read') +#ifndef CRYST_THETA + call getenv_loc('THETPARPDB',thetname_pdb) + print *,"thetname_pdb ",thetname_pdb + open (ithep_pdb,file=thetname_pdb,status='old',action='read') + print *,ithep_pdb," opened" +#endif + call getenv_loc('ROTPAR',rotname) + open (irotam,file=rotname,status='old',action='read') +#ifndef CRYST_SC + call getenv_loc('ROTPARPDB',rotname_pdb) + open (irotam_pdb,file=rotname_pdb,status='old',action='read') +#endif + call getenv_loc('TORPAR',torname) + open (itorp,file=torname,status='old',action='read') + call getenv_loc('TORDPAR',tordname) + open (itordp,file=tordname,status='old',action='read') + call getenv_loc('SCCORPAR',sccorname) + open (isccor,file=sccorname,status='old',action='read') + call getenv_loc('FOURIER',fouriername) + open (ifourier,file=fouriername,status='old',action='read') + call getenv_loc('ELEPAR',elename) + open (ielep,file=elename,status='old',action='read') + call getenv_loc('SIDEPAR',sidename) + open (isidep,file=sidename,status='old',action='read') +#endif +#ifndef OLDSCP +C +C 8/9/01 In the newest version SCp interaction constants are read from a file +C Use -DOLDSCP to use hard-coded constants instead. +C + call getenv_loc('SCPPAR',scpname) +#if defined(WINIFL) || defined(WINPGI) + open (iscpp,file=scpname,status='old',readonly,shared) +#elif (defined CRAY) || (defined AIX) + open (iscpp,file=scpname,status='old',action='read') +#elif (defined G77) + open (iscpp,file=scpname,status='old') +#else + open (iscpp,file=scpname,status='old',action='read') +#endif +#endif + call getenv_loc('PATTERN',patname) +#if defined(WINIFL) || defined(WINPGI) + open (icbase,file=patname,status='old',readonly,shared) +#elif (defined CRAY) || (defined AIX) + open (icbase,file=patname,status='old',action='read') +#elif (defined G77) + open (icbase,file=patname,status='old') +#else + open (icbase,file=patname,status='old',action='read') +#endif +#ifdef MPI +C Open output file only for CG processes +c print *,"Processor",myrank," fg_rank",fg_rank + if (fg_rank.eq.0) then + + if (nodes.eq.1) then + npos=3 + else + npos = dlog10(dfloat(nodes-1))+1 + endif + if (npos.lt.3) npos=3 + write (liczba,'(i1)') npos + form = '(bz,i'//liczba(:ilen(liczba))//'.'//liczba(:ilen(liczba)) + & //')' + write (liczba,form) me + outname=prefix(:lenpre)//'.out_'//pot(:lenpot)// + & liczba(:ilen(liczba)) + intname=prefix(:lenpre)//'_'//pot(:lenpot)//liczba(:ilen(liczba)) + & //'.int' + pdbname=prefix(:lenpre)//'_'//pot(:lenpot)//liczba(:ilen(liczba)) + & //'.pdb' + mol2name=prefix(:lenpre)//'_'//pot(:lenpot)// + & liczba(:ilen(liczba))//'.mol2' + statname=prefix(:lenpre)//'_'//pot(:lenpot)// + & liczba(:ilen(liczba))//'.stat' + if (lentmp.gt.0) + & call copy_to_tmp(pref_orig(:ilen(pref_orig))//'_'//pot(:lenpot) + & //liczba(:ilen(liczba))//'.stat') + rest2name=prefix(:ilen(prefix))//"_"//liczba(:ilen(liczba)) + & //'.rst' + if(usampl) then + qname=prefix(:lenpre)//'_'//pot(:lenpot)// + & liczba(:ilen(liczba))//'.const' + endif + + endif +#else + outname=prefix(:lenpre)//'.out_'//pot(:lenpot) + intname=prefix(:lenpre)//'_'//pot(:lenpot)//'.int' + pdbname=prefix(:lenpre)//'_'//pot(:lenpot)//'.pdb' + mol2name=prefix(:lenpre)//'_'//pot(:lenpot)//'.mol2' + statname=prefix(:lenpre)//'_'//pot(:lenpot)//'.stat' + if (lentmp.gt.0) + & call copy_to_tmp(pref_orig(:ilen(pref_orig))//'_'//pot(:lenpot) + & //'.stat') + rest2name=prefix(:ilen(prefix))//'.rst' + if(usampl) then + qname=prefix(:lenpre)//'_'//pot(:lenpot)//'.const' + endif +#endif +#if defined(AIX) || defined(PGI) + if (me.eq.king .or. .not. out1file) + & open(iout,file=outname,status='unknown') +c#define DEBUG +#ifdef DEBUG + if (fg_rank.gt.0) then + write (liczba,'(i3.3)') myrank/nfgtasks + write (ll,'(bz,i3.3)') fg_rank + open(iout,file="debug"//liczba(:ilen(liczba))//"."//ll, + & status='unknown') + endif +#endif +c#undef DEBUG + if(me.eq.king) then + open(igeom,file=intname,status='unknown',position='append') + open(ipdb,file=pdbname,status='unknown') + open(imol2,file=mol2name,status='unknown') + open(istat,file=statname,status='unknown',position='append') + else +c1out open(iout,file=outname,status='unknown') + endif +#else + if (me.eq.king .or. .not.out1file) + & open(iout,file=outname,status='unknown') +c#define DEBUG +#ifdef DEBUG + if (fg_rank.gt.0) then + print "Processor",fg_rank," opening output file" + write (liczba,'(i3.3)') myrank/nfgtasks + write (ll,'(bz,i3.3)') fg_rank + open(iout,file="debug"//liczba(:ilen(liczba))//"."//ll, + & status='unknown') + endif +#endif +c#undef DEBUG + if(me.eq.king) then + open(igeom,file=intname,status='unknown',access='append') + open(ipdb,file=pdbname,status='unknown') + open(imol2,file=mol2name,status='unknown') + open(istat,file=statname,status='unknown',access='append') + else +c1out open(iout,file=outname,status='unknown') + endif +#endif +csa csa_rbank=prefix(:lenpre)//'.CSA.rbank' +csa csa_seed=prefix(:lenpre)//'.CSA.seed' +csa csa_history=prefix(:lenpre)//'.CSA.history' +csa csa_bank=prefix(:lenpre)//'.CSA.bank' +csa csa_bank1=prefix(:lenpre)//'.CSA.bank1' +csa csa_alpha=prefix(:lenpre)//'.CSA.alpha' +csa csa_alpha1=prefix(:lenpre)//'.CSA.alpha1' +csac!bankt csa_bankt=prefix(:lenpre)//'.CSA.bankt' +csa csa_int=prefix(:lenpre)//'.int' +csa csa_bank_reminimized=prefix(:lenpre)//'.CSA.bank_reminimized' +csa csa_native_int=prefix(:lenpre)//'.CSA.native.int' +csa csa_in=prefix(:lenpre)//'.CSA.in' +c print *,"Processor",myrank,"fg_rank",fg_rank," opened files" +C Write file names + if (me.eq.king)then + write (iout,'(80(1h-))') + write (iout,'(30x,a)') "FILE ASSIGNMENT" + write (iout,'(80(1h-))') + write (iout,*) "Input file : ", + & pref_orig(:ilen(pref_orig))//'.inp' + write (iout,*) "Output file : ", + & outname(:ilen(outname)) + write (iout,*) + write (iout,*) "Sidechain potential file : ", + & sidename(:ilen(sidename)) +#ifndef OLDSCP + write (iout,*) "SCp potential file : ", + & scpname(:ilen(scpname)) +#endif + write (iout,*) "Electrostatic potential file : ", + & elename(:ilen(elename)) + write (iout,*) "Cumulant coefficient file : ", + & fouriername(:ilen(fouriername)) + write (iout,*) "Torsional parameter file : ", + & torname(:ilen(torname)) + write (iout,*) "Double torsional parameter file : ", + & tordname(:ilen(tordname)) + write (iout,*) "SCCOR parameter file : ", + & sccorname(:ilen(sccorname)) + write (iout,*) "Bond & inertia constant file : ", + & bondname(:ilen(bondname)) + write (iout,*) "Bending parameter file : ", + & thetname(:ilen(thetname)) + write (iout,*) "Rotamer parameter file : ", + & rotname(:ilen(rotname)) + write (iout,*) "Threading database : ", + & patname(:ilen(patname)) + if (lentmp.ne.0) + &write (iout,*)" DIRTMP : ", + & tmpdir(:lentmp) + write (iout,'(80(1h-))') + endif + return + end +c---------------------------------------------------------------------------- + subroutine card_concat(card) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + character*(*) card + character*80 karta,ucase + external ilen + read (inp,'(a)') karta + karta=ucase(karta) + card=' ' + do while (karta(80:80).eq.'&') + card=card(:ilen(card)+1)//karta(:79) + read (inp,'(a)') karta + karta=ucase(karta) + enddo + card=card(:ilen(card)+1)//karta + return + end +c---------------------------------------------------------------------------------- + subroutine readrst + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.MD' + open(irest2,file=rest2name,status='unknown') + read(irest2,*) totT,EK,potE,totE,t_bath + do i=1,2*nres + read(irest2,'(3e15.5)') (d_t(j,i),j=1,3) + enddo + do i=1,2*nres + read(irest2,'(3e15.5)') (dc(j,i),j=1,3) + enddo + if(usampl) then + read (irest2,*) iset + endif + close(irest2) + return + end +c--------------------------------------------------------------------------------- + subroutine read_fragments + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.SETUP' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.MD' + include 'COMMON.CONTROL' + read(inp,*) nset,nfrag,npair,nfrag_back + if(me.eq.king.or..not.out1file) + & write(iout,*) "nset",nset," nfrag",nfrag," npair",npair, + & " nfrag_back",nfrag_back + do iset=1,nset + read(inp,*) mset(iset) + do i=1,nfrag + read(inp,*) wfrag(i,iset),ifrag(1,i,iset),ifrag(2,i,iset), + & qinfrag(i,iset) + if(me.eq.king.or..not.out1file) + & write(iout,*) "R ",i,wfrag(i,iset),ifrag(1,i,iset), + & ifrag(2,i,iset), qinfrag(i,iset) + enddo + do i=1,npair + read(inp,*) wpair(i,iset),ipair(1,i,iset),ipair(2,i,iset), + & qinpair(i,iset) + if(me.eq.king.or..not.out1file) + & write(iout,*) "R ",i,wpair(i,iset),ipair(1,i,iset), + & ipair(2,i,iset), qinpair(i,iset) + enddo + do i=1,nfrag_back + read(inp,*) wfrag_back(1,i,iset),wfrag_back(2,i,iset), + & wfrag_back(3,i,iset), + & ifrag_back(1,i,iset),ifrag_back(2,i,iset) + if(me.eq.king.or..not.out1file) + & write(iout,*) "A",i,wfrag_back(1,i,iset),wfrag_back(2,i,iset), + & wfrag_back(3,i,iset),ifrag_back(1,i,iset),ifrag_back(2,i,iset) + enddo + enddo + return + end +c------------------------------------------------------------------------------- + subroutine read_dist_constr + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.SETUP' + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.SBRIDGE' + integer ifrag_(2,100),ipair_(2,100) + double precision wfrag_(100),wpair_(100) + character*500 controlcard +c write (iout,*) "Calling read_dist_constr" +c write (iout,*) "nres",nres," nstart_sup",nstart_sup," nsup",nsup +c call flush(iout) + call card_concat(controlcard) + call readi(controlcard,"NFRAG",nfrag_,0) + call readi(controlcard,"NPAIR",npair_,0) + call readi(controlcard,"NDIST",ndist_,0) + call reada(controlcard,'DIST_CUT',dist_cut,5.0d0) + call multreadi(controlcard,"IFRAG",ifrag_(1,1),2*nfrag_,0) + call multreadi(controlcard,"IPAIR",ipair_(1,1),2*npair_,0) + call multreada(controlcard,"WFRAG",wfrag_(1),nfrag_,0.0d0) + call multreada(controlcard,"WPAIR",wpair_(1),npair_,0.0d0) +c write (iout,*) "NFRAG",nfrag_," NPAIR",npair_," NDIST",ndist_ +c write (iout,*) "IFRAG" +c do i=1,nfrag_ +c write (iout,*) i,ifrag_(1,i),ifrag_(2,i),wfrag_(i) +c enddo +c write (iout,*) "IPAIR" +c do i=1,npair_ +c write (iout,*) i,ipair_(1,i),ipair_(2,i),wpair_(i) +c enddo + if (.not.refstr .and. nfrag.gt.0) then + write (iout,*) + & "ERROR: no reference structure to compute distance restraints" + write (iout,*) + & "Restraints must be specified explicitly (NDIST=number)" + stop + endif + if (nfrag.lt.2 .and. npair.gt.0) then + write (iout,*) "ERROR: Less than 2 fragments specified", + & " but distance restraints between pairs requested" + stop + endif + call flush(iout) + do i=1,nfrag_ + if (ifrag_(1,i).lt.nstart_sup) ifrag_(1,i)=nstart_sup + if (ifrag_(2,i).gt.nstart_sup+nsup-1) + & ifrag_(2,i)=nstart_sup+nsup-1 +c write (iout,*) i,ifrag_(1,i),ifrag_(2,i),wfrag_(i) + call flush(iout) + if (wfrag_(i).gt.0.0d0) then + do j=ifrag_(1,i),ifrag_(2,i)-1 + do k=j+1,ifrag_(2,i) +c write (iout,*) "j",j," k",k + ddjk=dist(j,k) + if (constr_dist.eq.1) then + nhpb=nhpb+1 + ihpb(nhpb)=j + jhpb(nhpb)=k + dhpb(nhpb)=ddjk + forcon(nhpb)=wfrag_(i) + else if (constr_dist.eq.2) then + if (ddjk.le.dist_cut) then + nhpb=nhpb+1 + ihpb(nhpb)=j + jhpb(nhpb)=k + dhpb(nhpb)=ddjk + forcon(nhpb)=wfrag_(i) + endif + else + nhpb=nhpb+1 + ihpb(nhpb)=j + jhpb(nhpb)=k + dhpb(nhpb)=ddjk + forcon(nhpb)=wfrag_(i)*dexp(-0.5d0*(ddjk/dist_cut)**2) + endif +#ifdef MPI + if (.not.out1file .or. me.eq.king) + & write (iout,'(a,3i5,f8.2,1pe12.2)') "+dist.constr ", + & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) +#else + write (iout,'(a,3i5,f8.2,1pe12.2)') "+dist.constr ", + & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) +#endif + enddo + enddo + endif + enddo + do i=1,npair_ + if (wpair_(i).gt.0.0d0) then + ii = ipair_(1,i) + jj = ipair_(2,i) + if (ii.gt.jj) then + itemp=ii + ii=jj + jj=itemp + endif + do j=ifrag_(1,ii),ifrag_(2,ii) + do k=ifrag_(1,jj),ifrag_(2,jj) + nhpb=nhpb+1 + ihpb(nhpb)=j + jhpb(nhpb)=k + forcon(nhpb)=wpair_(i) + dhpb(nhpb)=dist(j,k) +#ifdef MPI + if (.not.out1file .or. me.eq.king) + & write (iout,'(a,3i5,f8.2,f10.1)') "+dist.constr ", + & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) +#else + write (iout,'(a,3i5,f8.2,f10.1)') "+dist.constr ", + & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) +#endif + enddo + enddo + endif + enddo + do i=1,ndist_ + read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),dhpb(i),dhpb1(i), + & ibecarb(i),forcon(nhpb+1) + if (forcon(nhpb+1).gt.0.0d0) then + nhpb=nhpb+1 + if (ibecarb(i).gt.0) then + ihpb(i)=ihpb(i)+nres + jhpb(i)=jhpb(i)+nres + endif + if (dhpb(nhpb).eq.0.0d0) + & dhpb(nhpb)=dist(ihpb(nhpb),jhpb(nhpb)) + endif + enddo +#ifdef MPI + if (.not.out1file .or. me.eq.king) then +#endif + do i=1,nhpb + write (iout,'(a,3i5,2f8.2,i2,f10.1)') "+dist.constr ", + & i,ihpb(i),jhpb(i),dhpb(i),dhpb1(i),ibecarb(i),forcon(i) + enddo + call flush(iout) +#ifdef MPI + endif +#endif + return + end +c------------------------------------------------------------------------------- + + subroutine read_constr_homology + + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.SETUP' + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.MD' + include 'COMMON.GEO' + include 'COMMON.INTERACT' + double precision odl_temp,sigma_odl_temp + common /przechowalnia/ odl_temp(maxres,maxres,max_template), + & sigma_odl_temp(maxres,maxres,max_template) + character*2 kic2 + character*24 model_ki_dist, model_ki_angle + character*500 controlcard + integer ki, i, j, k, l + logical lprn /.true./ + + call card_concat(controlcard) + call reada(controlcard,"HOMOL_DIST",waga_dist,1.0d0) + call reada(controlcard,"HOMOL_ANGLE",waga_angle,1.0d0) + + write (iout,*) "nnt",nnt," nct",nct + call flush(iout) + lim_odl=0 + lim_dih=0 + do i=1,nres + do j=i+2,nres + do ki=1,constr_homology + sigma_odl_temp(i,j,ki)=0.0d0 + odl_temp(i,j,ki)=0.0d0 + enddo + enddo + enddo + do i=1,nres-3 + do ki=1,constr_homology + dih(ki,i)=0.0d0 + sigma_dih(ki,i)=0.0d0 + enddo + enddo + do ki=1,constr_homology + write(kic2,'(i2)') ki + if (ki.le.9) kic2="0"//kic2(2:2) + + model_ki_dist="model"//kic2//".dist" + model_ki_angle="model"//kic2//".angle" + open (ientin,file=model_ki_dist,status='old') + do irec=1,maxdim !petla do czytania wiezow na odleglosc + read (ientin,*,end=1401) i, j, odl_temp(i+nnt-1,j+nnt-1,ki), + & sigma_odl_temp(i+nnt-1,j+nnt-1,ki) + odl_temp(j+nnt-1,i+nnt-1,ki)=odl_temp(i+nnt-1,j+nnt-1,ki) + sigma_odl_temp(j+nnt-1,i+nnt-1,ki)= + & sigma_odl_temp(i+nnt-1,j+nnt-1,ki) + enddo + 1401 continue + close (ientin) + open (ientin,file=model_ki_angle,status='old') + do irec=1,maxres-3 !petla do czytania wiezow na katy torsyjne + read (ientin,*,end=1402) i, j, k,l,dih(ki,i+nnt-1), + & sigma_dih(ki,i+nnt-1) + if (i+nnt-1.gt.lim_dih) lim_dih=i+nnt-1 + sigma_dih(ki,i+nnt-1)=1.0d0/sigma_dih(ki,i+nnt-1)**2 + enddo + 1402 continue + close (ientin) + enddo + ii=0 + write (iout,*) "nnt",nnt," nct",nct + do i=nnt,nct-2 + do j=i+2,nct + ki=1 +c write (iout,*) "i",i," j",j," constr_homology",constr_homology + do while (ki.le.constr_homology .and. + & sigma_odl_temp(i,j,ki).le.0.0d0) +c write (iout,*) "ki",ki," sigma_odl",sigma_odl_temp(i,j,ki) + ki=ki+1 + enddo +c write (iout,*) "ki",ki + if (ki.gt.constr_homology) cycle + ii=ii+1 + ires_homo(ii)=i + jres_homo(ii)=j + do ki=1,constr_homology + odl(ki,ii)=odl_temp(i,j,ki) + sigma_odl(ki,ii)=1.0d0/sigma_odl_temp(i,j,ki)**2 + enddo + enddo + enddo + lim_odl=ii + if (constr_homology.gt.0) call homology_partition +c Print restraints + if (.not.lprn) return + write (iout,*) "Distance restraints from templates" + do ii=1,lim_odl + write(iout,'(3i5,10(2f8.2,4x))') ii,ires_homo(ii),jres_homo(ii), + & (odl(ki,ii),1.0d0/dsqrt(sigma_odl(ki,ii)),ki=1,constr_homology) + enddo + write (iout,*) "Dihedral angle restraints from templates" + do i=nnt,lim_dih + write (iout,'(i5,10(2f8.2,4x))') i,(rad2deg*dih(ki,i), + & rad2deg/dsqrt(sigma_dih(ki,i)),ki=1,constr_homology) + enddo +c write(iout,*) "TEST CZYTANIA1",odl(1,2,1),odl(1,3,1),odl(1,4,1) +c write(iout,*) "TEST CZYTANIA2",dih(1,1),dih(2,1),dih(3,1) + + + return + end +c---------------------------------------------------------------------- + +#ifdef WINIFL + subroutine flush(iu) + return + end +#endif +#ifdef AIX + subroutine flush(iu) + call flush_(iu) + return + end +#endif + +c------------------------------------------------------------------------------ + subroutine copy_to_tmp(source) + include "DIMENSIONS" + include "COMMON.IOUNITS" + character*(*) source + character* 256 tmpfile + integer ilen + external ilen + logical ex + tmpfile=curdir(:ilen(curdir))//"/"//source(:ilen(source)) + inquire(file=tmpfile,exist=ex) + if (ex) then + write (*,*) "Copying ",tmpfile(:ilen(tmpfile)), + & " to temporary directory..." + write (*,*) "/bin/cp "//tmpfile(:ilen(tmpfile))//" "//tmpdir + call system("/bin/cp "//tmpfile(:ilen(tmpfile))//" "//tmpdir) + endif + return + end +c------------------------------------------------------------------------------ + subroutine move_from_tmp(source) + include "DIMENSIONS" + include "COMMON.IOUNITS" + character*(*) source + integer ilen + external ilen + write (*,*) "Moving ",source(:ilen(source)), + & " from temporary directory to working directory" + write (*,*) "/bin/mv "//source(:ilen(source))//" "//curdir + call system("/bin/mv "//source(:ilen(source))//" "//curdir) + return + end +c------------------------------------------------------------------------------ + subroutine random_init(seed) +C +C Initialize random number generator +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef AMD64 + integer*8 iseedi8 +#endif +#ifdef MPI + include 'mpif.h' + logical OKRandom, prng_restart + real*8 r1 + integer iseed_array(4) +#endif + include 'COMMON.IOUNITS' + include 'COMMON.TIME1' + include 'COMMON.THREAD' + include 'COMMON.SBRIDGE' + include 'COMMON.CONTROL' + include 'COMMON.MCM' + include 'COMMON.MAP' + include 'COMMON.HEADER' +csa include 'COMMON.CSA' + include 'COMMON.CHAIN' + include 'COMMON.MUCA' + include 'COMMON.MD' + include 'COMMON.FFIELD' + include 'COMMON.SETUP' + iseed=-dint(dabs(seed)) + if (iseed.eq.0) then + write (iout,'(/80(1h*)/20x,a/80(1h*))') + & 'Random seed undefined. The program will stop.' + write (*,'(/80(1h*)/20x,a/80(1h*))') + & 'Random seed undefined. The program will stop.' +#ifdef MPI + call mpi_finalize(mpi_comm_world,ierr) +#endif + stop 'Bad random seed.' + endif +#ifdef MPI + if (fg_rank.eq.0) then + seed=seed*(me+1)+1 +#ifdef AMD64 + iseedi8=dint(seed) + if(me.eq.king .or. .not. out1file) + & write (iout,*) 'MPI: node= ', me, ' iseed= ',iseedi8 + write (*,*) 'MPI: node= ', me, ' iseed= ',iseedi8 + OKRandom = prng_restart(me,iseedi8) +#else + do i=1,4 + tmp=65536.0d0**(4-i) + iseed_array(i) = dint(seed/tmp) + seed=seed-iseed_array(i)*tmp + enddo + if(me.eq.king .or. .not. out1file) + & write (iout,*) 'MPI: node= ', me, ' iseed(4)= ', + & (iseed_array(i),i=1,4) + write (*,*) 'MPI: node= ',me, ' iseed(4)= ', + & (iseed_array(i),i=1,4) + OKRandom = prng_restart(me,iseed_array) +#endif + if (OKRandom) then + r1=ran_number(0.0D0,1.0D0) + if(me.eq.king .or. .not. out1file) + & write (iout,*) 'ran_num',r1 + if (r1.lt.0.0d0) OKRandom=.false. + endif + if (.not.OKRandom) then + write (iout,*) 'PRNG IS NOT WORKING!!!' + print *,'PRNG IS NOT WORKING!!!' + if (me.eq.0) then + call flush(iout) + call mpi_abort(mpi_comm_world,error_msg,ierr) + stop + else + write (iout,*) 'too many processors for parallel prng' + write (*,*) 'too many processors for parallel prng' + call flush(iout) + stop + endif + endif + endif +#else + call vrndst(iseed) + write (iout,*) 'ran_num',ran_number(0.0d0,1.0d0) +#endif + return + end diff --git a/source/unres/src_MD-DFA-restraints/refsys.f b/source/unres/src_MD-DFA-restraints/refsys.f new file mode 100644 index 0000000..b57c201 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/refsys.f @@ -0,0 +1,60 @@ + subroutine refsys(i2,i3,i4,e1,e2,e3,fail) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +c this subroutine calculates unity vectors of a local reference system +c defined by atoms (i2), (i3), and (i4). the x axis is the axis from +c atom (i3) to atom (i2), and the xy plane is the plane defined by atoms +c (i2), (i3), and (i4). z axis is directed according to the sign of the +c vector product (i3)-(i2) and (i3)-(i4). sets fail to .true. if atoms +c (i2) and (i3) or (i3) and (i4) coincide or atoms (i2), (i3), and (i4) +c form a linear fragment. returns vectors e1, e2, and e3. + logical fail + double precision e1(3),e2(3),e3(3) + double precision u(3),z(3) + include 'COMMON.IOUNITS' + include "COMMON.CHAIN" + data coinc /1.0d-13/,align /1.0d-13/ + fail=.false. + s1=0.0d0 + s2=0.0d0 + do 1 i=1,3 + zi=c(i,i2)-c(i,i3) + ui=c(i,i4)-c(i,i3) + s1=s1+zi*zi + s2=s2+ui*ui + z(i)=zi + 1 u(i)=ui + s1=sqrt(s1) + s2=sqrt(s2) + if (s1.gt.coinc) goto 2 + write (iout,1000) i2,i3,i1 + fail=.true. + return + 2 if (s2.gt.coinc) goto 4 + write(iout,1000) i3,i4,i1 + fail=.true. + return + 4 s1=1.0/s1 + s2=1.0/s2 + v1=z(2)*u(3)-z(3)*u(2) + v2=z(3)*u(1)-z(1)*u(3) + v3=z(1)*u(2)-z(2)*u(1) + anorm=sqrt(v1*v1+v2*v2+v3*v3) + if (anorm.gt.align) goto 6 + write (iout,1010) i2,i3,i4,i1 + fail=.true. + return + 6 anorm=1.0/anorm + e3(1)=v1*anorm + e3(2)=v2*anorm + e3(3)=v3*anorm + e1(1)=z(1)*s1 + e1(2)=z(2)*s1 + e1(3)=z(3)*s1 + e2(1)=e1(3)*e3(2)-e1(2)*e3(3) + e2(2)=e1(1)*e3(3)-e1(3)*e3(1) + e2(3)=e1(2)*e3(1)-e1(1)*e3(2) + 1000 format (/1x,' * * * error - atoms',i4,' and',i4,' coincide.') + 1010 format (/1x,' * * * error - atoms',2(i4,2h, ),i4,' form a linear') + return + end diff --git a/source/unres/src_MD-DFA-restraints/regularize.F b/source/unres/src_MD-DFA-restraints/regularize.F new file mode 100644 index 0000000..c506b8a --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/regularize.F @@ -0,0 +1,76 @@ + subroutine regularize(ncart,etot,rms,cref0,iretcode) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.HEADER' + include 'COMMON.IOUNITS' + include 'COMMON.MINIM' + double precision przes(3),obrot(3,3),fhpb0(maxdim),varia(maxvar) + double precision cref0(3,ncart) + double precision energia(0:n_ene) + logical non_conv + link_end0=link_end + do i=1,nhpb + fhpb0(i)=forcon(i) + enddo + maxit_reg=2 + print *,'Enter REGULARIZE: nnt=',nnt,' nct=',nct,' nsup=',nsup, + & ' nstart_seq=',nstart_seq,' nstart_sup',nstart_sup + write (iout,'(/a/)') 'Initial energies:' + call geom_to_var(nvar,varia) + call chainbuild + call etotal(energia(0)) + etot=energia(0) + call enerprint(energia(0)) + call fitsq(rms,c(1,nstart_seq),cref0(1,nstart_sup-1), + & nsup,przes,obrot,non_conv) + write (iout,'(a,f10.5)') + & 'Enter REGULARIZE: Initial RMS deviation:',dsqrt(dabs(rms)) + write (*,'(a,f10.5)') + & 'Enter REGULARIZE: Initial RMS deviation:',dsqrt(dabs(rms)) + maxit0=maxit + maxfun0=maxfun + rtolf0=rtolf + maxit=100 + maxfun=200 + rtolf=1.0D-2 + do it=1,maxit_reg + print *,'Regularization: pass:',it +C Minimize with distance constraints, gradually relieving the weight. + call minimize(etot,varia,iretcode,nfun) + print *,'Etot=',Etot + if (iretcode.eq.11) return + call fitsq(rms,c(1,nstart_seq),cref0(1,nstart_sup-1), + & nsup,przes,obrot,non_conv) + rms=dsqrt(rms) + write (iout,'(a,i2,a,f10.5,a,1pe14.5,a,i3/)') + & 'Finish pass',it,', RMS deviation:',rms,', energy',etot, + & ' SUMSL convergence',iretcode + do i=nss+1,nhpb + forcon(i)=0.1D0*forcon(i) + enddo + enddo +C Turn off the distance constraints and re-minimize energy. + print *,'Final minimization ... ' + maxit=maxit0 + maxfun=maxfun0 + rtolf=rtolf0 + link_end=min0(link_end,nss) + call minimize(etot,varia,iretcode,nfun) + print *,'Etot=',Etot + call fitsq(rms,c(1,nstart_seq),cref0(1,nstart_sup-1),nsup, + & przes,obrot,non_conv) + rms=dsqrt(rms) + write (iout,'(a,f10.5,a,1pe14.5,a,i3/)') + & 'Final RMS deviation:',rms,' energy',etot,' SUMSL convergence', + & iretcode + link_end=link_end0 + do i=nss+1,nhpb + forcon(i)=fhpb0(i) + enddo + call var_to_geom(nvar,varia) + call chainbuild + return + end diff --git a/source/unres/src_MD-DFA-restraints/rescode.f b/source/unres/src_MD-DFA-restraints/rescode.f new file mode 100644 index 0000000..2973ef9 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/rmdd.f b/source/unres/src_MD-DFA-restraints/rmdd.f new file mode 100644 index 0000000..799ab47 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/rmsd.F b/source/unres/src_MD-DFA-restraints/rmsd.F new file mode 100644 index 0000000..52e7b37 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/rmsd.F @@ -0,0 +1,140 @@ + 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 + diff --git a/source/unres/src_MD-DFA-restraints/sc_move.F b/source/unres/src_MD-DFA-restraints/sc_move.F new file mode 100644 index 0000000..b6837fd --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/sizes.i b/source/unres/src_MD-DFA-restraints/sizes.i new file mode 100644 index 0000000..45c44ff --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/sizes.i @@ -0,0 +1,83 @@ +c +c +c ################################################### +c ## COPYRIGHT (C) 1992 by Jay William Ponder ## +c ## All Rights Reserved ## +c ################################################### +c +c ############################################################# +c ## ## +c ## sizes.i -- parameter values to set array dimensions ## +c ## ## +c ############################################################# +c +c +c "sizes.i" sets values for critical array dimensions used +c throughout the software; these parameters will fix the size +c of the largest systems that can be handled; values too large +c for the computer's memory and/or swap space to accomodate +c will result in poor performance or outright failure +c +c parameter: maximum allowed number of: +c +c maxatm atoms in the molecular system +c maxval atoms directly bonded to an atom +c maxgrp user-defined groups of atoms +c maxtyp force field atom type definitions +c maxclass force field atom class definitions +c maxkey lines in the keyword file +c maxrot bonds for torsional rotation +c maxvar optimization variables (vector storage) +c maxopt optimization variables (matrix storage) +c maxhess off-diagonal Hessian elements +c maxlight sites for method of lights neighbors +c maxvib vibrational frequencies +c maxgeo distance geometry points +c maxcell unit cells in replicated crystal +c maxring 3-, 4-, or 5-membered rings +c maxfix geometric restraints +c maxbio biopolymer atom definitions +c maxres residues in the macromolecule +c maxamino amino acid residue types +c maxnuc nucleic acid residue types +c maxbnd covalent bonds in molecular system +c maxang bond angles in molecular system +c maxtors torsional angles in molecular system +c maxpi atoms in conjugated pisystem +c maxpib covalent bonds involving pisystem +c maxpit torsional angles involving pisystem +c +c + integer maxatm,maxval,maxgrp + integer maxtyp,maxclass,maxkey + integer maxrot,maxopt + integer maxhess,maxlight,maxvib + integer maxgeo,maxcell,maxring + integer maxfix,maxbio + integer maxamino,maxnuc,maxbnd + integer maxang,maxtors,maxpi + integer maxpib,maxpit + parameter (maxatm=maxres2) + parameter (maxval=8) + parameter (maxgrp=1000) + parameter (maxtyp=3000) + parameter (maxclass=500) + parameter (maxkey=10000) + parameter (maxrot=1000) + parameter (maxopt=1000) + parameter (maxhess=1000000) + parameter (maxlight=8*maxatm) + parameter (maxvib=1000) + parameter (maxgeo=1000) + parameter (maxcell=10000) + parameter (maxring=10000) + parameter (maxfix=10000) + parameter (maxbio=10000) + parameter (maxamino=31) + parameter (maxnuc=12) + parameter (maxbnd=2*maxatm) + parameter (maxang=3*maxatm) + parameter (maxtors=4*maxatm) + parameter (maxpi=100) + parameter (maxpib=2*maxpi) + parameter (maxpit=4*maxpi) diff --git a/source/unres/src_MD-DFA-restraints/sort.f b/source/unres/src_MD-DFA-restraints/sort.f new file mode 100644 index 0000000..46b43d9 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/sort.f @@ -0,0 +1,589 @@ +c +c +c ################################################### +c ## COPYRIGHT (C) 1990 by Jay William Ponder ## +c ## All Rights Reserved ## +c ################################################### +c +c ######################################################### +c ## ## +c ## subroutine sort -- heapsort of an integer array ## +c ## ## +c ######################################################### +c +c +c "sort" takes an input list of integers and sorts it +c into ascending order using the Heapsort algorithm +c +c + subroutine sort (n,list) + implicit none + integer i,j,k,n + integer index,lists + integer list(*) +c +c +c perform the heapsort of the input list +c + k = n/2 + 1 + index = n + dowhile (n .gt. 1) + if (k .gt. 1) then + k = k - 1 + lists = list(k) + else + lists = list(index) + list(index) = list(1) + index = index - 1 + if (index .le. 1) then + list(1) = lists + return + end if + end if + i = k + j = k + k + dowhile (j .le. index) + if (j .lt. index) then + if (list(j) .lt. list(j+1)) j = j + 1 + end if + if (lists .lt. list(j)) then + list(i) = list(j) + i = j + j = j + j + else + j = index + 1 + end if + end do + list(i) = lists + end do + return + end +c +c +c ############################################################## +c ## ## +c ## subroutine sort2 -- heapsort of real array with keys ## +c ## ## +c ############################################################## +c +c +c "sort2" takes an input list of reals and sorts it +c into ascending order using the Heapsort algorithm; +c it also returns a key into the original ordering +c +c + subroutine sort2 (n,list,key) + implicit none + integer i,j,k,n + integer index,keys + integer key(*) + real*8 lists + real*8 list(*) +c +c +c initialize index into the original ordering +c + do i = 1, n + key(i) = i + end do +c +c perform the heapsort of the input list +c + k = n/2 + 1 + index = n + dowhile (n .gt. 1) + if (k .gt. 1) then + k = k - 1 + lists = list(k) + keys = key(k) + else + lists = list(index) + keys = key(index) + list(index) = list(1) + key(index) = key(1) + index = index - 1 + if (index .le. 1) then + list(1) = lists + key(1) = keys + return + end if + end if + i = k + j = k + k + dowhile (j .le. index) + if (j .lt. index) then + if (list(j) .lt. list(j+1)) j = j + 1 + end if + if (lists .lt. list(j)) then + list(i) = list(j) + key(i) = key(j) + i = j + j = j + j + else + j = index + 1 + end if + end do + list(i) = lists + key(i) = keys + end do + return + end +c +c +c ################################################################# +c ## ## +c ## subroutine sort3 -- heapsort of integer array with keys ## +c ## ## +c ################################################################# +c +c +c "sort3" takes an input list of integers and sorts it +c into ascending order using the Heapsort algorithm; +c it also returns a key into the original ordering +c +c + subroutine sort3 (n,list,key) + implicit none + integer i,j,k,n + integer index + integer lists + integer keys + integer list(*) + integer key(*) +c +c +c initialize index into the original ordering +c + do i = 1, n + key(i) = i + end do +c +c perform the heapsort of the input list +c + k = n/2 + 1 + index = n + dowhile (n .gt. 1) + if (k .gt. 1) then + k = k - 1 + lists = list(k) + keys = key(k) + else + lists = list(index) + keys = key(index) + list(index) = list(1) + key(index) = key(1) + index = index - 1 + if (index .le. 1) then + list(1) = lists + key(1) = keys + return + end if + end if + i = k + j = k + k + dowhile (j .le. index) + if (j .lt. index) then + if (list(j) .lt. list(j+1)) j = j + 1 + end if + if (lists .lt. list(j)) then + list(i) = list(j) + key(i) = key(j) + i = j + j = j + j + else + j = index + 1 + end if + end do + list(i) = lists + key(i) = keys + end do + return + end +c +c +c ################################################################# +c ## ## +c ## subroutine sort4 -- heapsort of integer absolute values ## +c ## ## +c ################################################################# +c +c +c "sort4" takes an input list of integers and sorts it into +c ascending absolute value using the Heapsort algorithm +c +c + subroutine sort4 (n,list) + implicit none + integer i,j,k,n + integer index + integer lists + integer list(*) +c +c +c perform the heapsort of the input list +c + k = n/2 + 1 + index = n + dowhile (n .gt. 1) + if (k .gt. 1) then + k = k - 1 + lists = list(k) + else + lists = list(index) + list(index) = list(1) + index = index - 1 + if (index .le. 1) then + list(1) = lists + return + end if + end if + i = k + j = k + k + dowhile (j .le. index) + if (j .lt. index) then + if (abs(list(j)) .lt. abs(list(j+1))) j = j + 1 + end if + if (abs(lists) .lt. abs(list(j))) then + list(i) = list(j) + i = j + j = j + j + else + j = index + 1 + end if + end do + list(i) = lists + end do + return + end +c +c +c ################################################################ +c ## ## +c ## subroutine sort5 -- heapsort of integer array modulo m ## +c ## ## +c ################################################################ +c +c +c "sort5" takes an input list of integers and sorts it +c into ascending order based on each value modulo "m" +c +c + subroutine sort5 (n,list,m) + implicit none + integer i,j,k,m,n + integer index,smod + integer jmod,j1mod + integer lists + integer list(*) +c +c +c perform the heapsort of the input list +c + k = n/2 + 1 + index = n + dowhile (n .gt. 1) + if (k .gt. 1) then + k = k - 1 + lists = list(k) + else + lists = list(index) + list(index) = list(1) + index = index - 1 + if (index .le. 1) then + list(1) = lists + return + end if + end if + i = k + j = k + k + dowhile (j .le. index) + if (j .lt. index) then + jmod = mod(list(j),m) + j1mod = mod(list(j+1),m) + if (jmod .lt. j1mod) then + j = j + 1 + else if (jmod.eq.j1mod .and. list(j).lt.list(j+1)) then + j = j + 1 + end if + end if + smod = mod(lists,m) + jmod = mod(list(j),m) + if (smod .lt. jmod) then + list(i) = list(j) + i = j + j = j + j + else if (smod.eq.jmod .and. lists.lt.list(j)) then + list(i) = list(j) + i = j + j = j + j + else + j = index + 1 + end if + end do + list(i) = lists + end do + return + end +c +c +c ############################################################# +c ## ## +c ## subroutine sort6 -- heapsort of a text string array ## +c ## ## +c ############################################################# +c +c +c "sort6" takes an input list of character strings and sorts +c it into alphabetical order using the Heapsort algorithm +c +c + subroutine sort6 (n,list) + implicit none + integer i,j,k,n + integer index + character*256 lists + character*(*) list(*) +c +c +c perform the heapsort of the input list +c + k = n/2 + 1 + index = n + dowhile (n .gt. 1) + if (k .gt. 1) then + k = k - 1 + lists = list(k) + else + lists = list(index) + list(index) = list(1) + index = index - 1 + if (index .le. 1) then + list(1) = lists + return + end if + end if + i = k + j = k + k + dowhile (j .le. index) + if (j .lt. index) then + if (list(j) .lt. list(j+1)) j = j + 1 + end if + if (lists .lt. list(j)) then + list(i) = list(j) + i = j + j = j + j + else + j = index + 1 + end if + end do + list(i) = lists + end do + return + end +c +c +c ################################################################ +c ## ## +c ## subroutine sort7 -- heapsort of text strings with keys ## +c ## ## +c ################################################################ +c +c +c "sort7" takes an input list of character strings and sorts it +c into alphabetical order using the Heapsort algorithm; it also +c returns a key into the original ordering +c +c + subroutine sort7 (n,list,key) + implicit none + integer i,j,k,n + integer index + integer keys + integer key(*) + character*256 lists + character*(*) list(*) +c +c +c initialize index into the original ordering +c + do i = 1, n + key(i) = i + end do +c +c perform the heapsort of the input list +c + k = n/2 + 1 + index = n + dowhile (n .gt. 1) + if (k .gt. 1) then + k = k - 1 + lists = list(k) + keys = key(k) + else + lists = list(index) + keys = key(index) + list(index) = list(1) + key(index) = key(1) + index = index - 1 + if (index .le. 1) then + list(1) = lists + key(1) = keys + return + end if + end if + i = k + j = k + k + dowhile (j .le. index) + if (j .lt. index) then + if (list(j) .lt. list(j+1)) j = j + 1 + end if + if (lists .lt. list(j)) then + list(i) = list(j) + key(i) = key(j) + i = j + j = j + j + else + j = index + 1 + end if + end do + list(i) = lists + key(i) = keys + end do + return + end +c +c +c ######################################################### +c ## ## +c ## subroutine sort8 -- heapsort to unique integers ## +c ## ## +c ######################################################### +c +c +c "sort8" takes an input list of integers and sorts it into +c ascending order using the Heapsort algorithm, duplicate +c values are removed from the final sorted list +c +c + subroutine sort8 (n,list) + implicit none + integer i,j,k,n + integer index + integer lists + integer list(*) +c +c +c perform the heapsort of the input list +c + k = n/2 + 1 + index = n + dowhile (n .gt. 1) + if (k .gt. 1) then + k = k - 1 + lists = list(k) + else + lists = list(index) + list(index) = list(1) + index = index - 1 + if (index .le. 1) then + list(1) = lists +c +c remove duplicate values from final list +c + j = 1 + do i = 2, n + if (list(i-1) .ne. list(i)) then + j = j + 1 + list(j) = list(i) + end if + end do + if (j .lt. n) n = j + return + end if + end if + i = k + j = k + k + dowhile (j .le. index) + if (j .lt. index) then + if (list(j) .lt. list(j+1)) j = j + 1 + end if + if (lists .lt. list(j)) then + list(i) = list(j) + i = j + j = j + j + else + j = index + 1 + end if + end do + list(i) = lists + end do + return + end +c +c +c ############################################################# +c ## ## +c ## subroutine sort9 -- heapsort to unique text strings ## +c ## ## +c ############################################################# +c +c +c "sort9" takes an input list of character strings and sorts +c it into alphabetical order using the Heapsort algorithm, +c duplicate values are removed from the final sorted list +c +c + subroutine sort9 (n,list) + implicit none + integer i,j,k,n + integer index + character*256 lists + character*(*) list(*) +c +c +c perform the heapsort of the input list +c + k = n/2 + 1 + index = n + dowhile (n .gt. 1) + if (k .gt. 1) then + k = k - 1 + lists = list(k) + else + lists = list(index) + list(index) = list(1) + index = index - 1 + if (index .le. 1) then + list(1) = lists +c +c remove duplicate values from final list +c + j = 1 + do i = 2, n + if (list(i-1) .ne. list(i)) then + j = j + 1 + list(j) = list(i) + end if + end do + if (j .lt. n) n = j + return + end if + end if + i = k + j = k + k + dowhile (j .le. index) + if (j .lt. index) then + if (list(j) .lt. list(j+1)) j = j + 1 + end if + if (lists .lt. list(j)) then + list(i) = list(j) + i = j + j = j + j + else + j = index + 1 + end if + end do + list(i) = lists + end do + return + end diff --git a/source/unres/src_MD-DFA-restraints/ssMD.F b/source/unres/src_MD-DFA-restraints/ssMD.F new file mode 100644 index 0000000..15800ae --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/ssMD.F @@ -0,0 +1,1951 @@ +c---------------------------------------------------------------------------- + subroutine check_energies +c implicit none + +c Includes + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.SBRIDGE' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + +c External functions + double precision ran_number + external ran_number + +c Local variables + integer i,j,k,l,lmax,p,pmax + double precision rmin,rmax + double precision eij + + double precision d + double precision wi,rij,tj,pj + + +c return + + i=5 + j=14 + + d=dsc(1) + rmin=2.0D0 + rmax=12.0D0 + + lmax=10000 + pmax=1 + + do k=1,3 + c(k,i)=0.0D0 + c(k,j)=0.0D0 + c(k,nres+i)=0.0D0 + c(k,nres+j)=0.0D0 + enddo + + do l=1,lmax + +ct wi=ran_number(0.0D0,pi) +c wi=ran_number(0.0D0,pi/6.0D0) +c wi=0.0D0 +ct tj=ran_number(0.0D0,pi) +ct pj=ran_number(0.0D0,pi) +c pj=ran_number(0.0D0,pi/6.0D0) +c pj=0.0D0 + + do p=1,pmax +ct rij=ran_number(rmin,rmax) + + c(1,j)=d*sin(pj)*cos(tj) + c(2,j)=d*sin(pj)*sin(tj) + c(3,j)=d*cos(pj) + + c(3,nres+i)=-rij + + c(1,i)=d*sin(wi) + c(3,i)=-rij-d*cos(wi) + + do k=1,3 + dc(k,nres+i)=c(k,nres+i)-c(k,i) + dc_norm(k,nres+i)=dc(k,nres+i)/d + dc(k,nres+j)=c(k,nres+j)-c(k,j) + dc_norm(k,nres+j)=dc(k,nres+j)/d + enddo + + call dyn_ssbond_ene(i,j,eij) + enddo + enddo + + call exit(1) + + return + end + +C----------------------------------------------------------------------------- + + subroutine dyn_ssbond_ene(resi,resj,eij) +c implicit none + +c Includes + include 'DIMENSIONS' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.CALC' +#ifndef CLUST +#ifndef WHAM + include 'COMMON.MD' +#endif +#endif + +c External functions + double precision h_base + external h_base + +c Input arguments + integer resi,resj + +c Output arguments + double precision eij + +c Local variables + logical havebond +c integer itypi,itypj,k,l + double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi + double precision sig0ij,ljd,sig,fac,e1,e2 + double precision dcosom1(3),dcosom2(3),ed + double precision pom1,pom2 + double precision ljA,ljB,ljXs + double precision d_ljB(1:3) + double precision ssA,ssB,ssC,ssXs + double precision ssxm,ljxm,ssm,ljm + double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3) + double precision f1,f2,h1,h2,hd1,hd2 + double precision omega,delta_inv,deltasq_inv,fac1,fac2 +c-------FIRST METHOD + double precision xm,d_xm(1:3) +c-------END FIRST METHOD +c-------SECOND METHOD +c$$$ double precision ss,d_ss(0:3),ljf,d_ljf(0:3) +c-------END SECOND METHOD + +c-------TESTING CODE + logical checkstop,transgrad + common /sschecks/ checkstop,transgrad + + integer icheck,nicheck,jcheck,njcheck + double precision echeck(-1:1),deps,ssx0,ljx0 +c-------END TESTING CODE + + + i=resi + j=resj + + itypi=itype(i) + dxi=dc_norm(1,nres+i) + dyi=dc_norm(2,nres+i) + dzi=dc_norm(3,nres+i) + dsci_inv=vbld_inv(i+nres) + + itypj=itype(j) + xj=c(1,nres+j)-c(1,nres+i) + yj=c(2,nres+j)-c(2,nres+i) + zj=c(3,nres+j)-c(3,nres+i) + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + dscj_inv=vbld_inv(j+nres) + + chi1=chi(itypi,itypj) + chi2=chi(itypj,itypi) + chi12=chi1*chi2 + chip1=chip(itypi) + chip2=chip(itypj) + chip12=chip1*chip2 + alf1=alp(itypi) + alf2=alp(itypj) + alf12=0.5D0*(alf1+alf2) + + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + rij=dsqrt(rrij) ! sc_angular needs rij to really be the inverse +c The following are set in sc_angular +c erij(1)=xj*rij +c erij(2)=yj*rij +c erij(3)=zj*rij +c om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) +c om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) +c om12=dxi*dxj+dyi*dyj+dzi*dzj + call sc_angular + rij=1.0D0/rij ! Reset this so it makes sense + + sig0ij=sigma(itypi,itypj) + sig=sig0ij*dsqrt(1.0D0/sigsq) + + ljXs=sig-sig0ij + ljA=eps1*eps2rt**2*eps3rt**2 + ljB=ljA*bb(itypi,itypj) + ljA=ljA*aa(itypi,itypj) + ljxm=ljXs+(-2.0D0*aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) + + ssXs=d0cm + deltat1=1.0d0-om1 + deltat2=1.0d0+om2 + deltat12=om2-om1+2.0d0 + cosphi=om12-om1*om2 + ssA=akcm + ssB=akct*deltat12 + ssC=ss_depth + & +akth*(deltat1*deltat1+deltat2*deltat2) + & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi + ssxm=ssXs-0.5D0*ssB/ssA + +c-------TESTING CODE +c$$$c Some extra output +c$$$ ssm=ssC-0.25D0*ssB*ssB/ssA +c$$$ ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj) +c$$$ ssx0=ssB*ssB-4.0d0*ssA*ssC +c$$$ if (ssx0.gt.0.0d0) then +c$$$ ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA +c$$$ else +c$$$ ssx0=ssxm +c$$$ endif +c$$$ ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) +c$$$ write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ", +c$$$ & ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12 +c$$$ return +c-------END TESTING CODE + +c-------TESTING CODE +c Stop and plot energy and derivative as a function of distance + if (checkstop) then + ssm=ssC-0.25D0*ssB*ssB/ssA + ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj) + if (ssm.lt.ljm .and. + & dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then + nicheck=1000 + njcheck=1 + deps=0.5d-7 + else + checkstop=.false. + endif + endif + if (.not.checkstop) then + nicheck=0 + njcheck=-1 + endif + + do icheck=0,nicheck + do jcheck=-1,njcheck + if (checkstop) rij=(ssxm-1.0d0)+ + & ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps +c-------END TESTING CODE + + if (rij.gt.ljxm) then + havebond=.false. + ljd=rij-ljXs + fac=(1.0D0/ljd)**expon + e1=fac*fac*aa(itypi,itypj) + e2=fac*bb(itypi,itypj) + eij=eps1*eps2rt*eps3rt*(e1+e2) + eps2der=eij*eps3rt + eps3der=eij*eps2rt + eij=eij*eps2rt*eps3rt + + sigder=-sig/sigsq + e1=e1*eps1*eps2rt**2*eps3rt**2 + ed=-expon*(e1+eij)/ljd + sigder=ed*sigder + eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 + eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 + eom12=eij*eps1_om12+eps2der*eps2rt_om12 + & -2.0D0*alf12*eps3der+sigder*sigsq_om12 + else if (rij.lt.ssxm) then + havebond=.true. + ssd=rij-ssXs + eij=ssA*ssd*ssd+ssB*ssd+ssC + + ed=2*akcm*ssd+akct*deltat12 + pom1=akct*ssd + pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi + eom1=-2*akth*deltat1-pom1-om2*pom2 + eom2= 2*akth*deltat2+pom1-om1*pom2 + eom12=pom2 + else + omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi + + d_ssxm(1)=0.5D0*akct/ssA + d_ssxm(2)=-d_ssxm(1) + d_ssxm(3)=0.0D0 + + d_ljxm(1)=sig0ij/sqrt(sigsq**3) + d_ljxm(2)=d_ljxm(1)*sigsq_om2 + d_ljxm(3)=d_ljxm(1)*sigsq_om12 + d_ljxm(1)=d_ljxm(1)*sigsq_om1 + +c-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE + xm=0.5d0*(ssxm+ljxm) + do k=1,3 + d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k)) + enddo + if (rij.lt.xm) then + havebond=.true. + ssm=ssC-0.25D0*ssB*ssB/ssA + d_ssm(1)=0.5D0*akct*ssB/ssA + d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1) + d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1) + d_ssm(3)=omega + f1=(rij-xm)/(ssxm-xm) + f2=(rij-ssxm)/(xm-ssxm) + h1=h_base(f1,hd1) + h2=h_base(f2,hd2) + eij=ssm*h1+Ht*h2 + delta_inv=1.0d0/(xm-ssxm) + deltasq_inv=delta_inv*delta_inv + fac=ssm*hd1-Ht*hd2 + fac1=deltasq_inv*fac*(xm-rij) + fac2=deltasq_inv*fac*(rij-ssxm) + ed=delta_inv*(Ht*hd2-ssm*hd1) + eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1) + eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2) + eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3) + else + havebond=.false. + ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj) + d_ljm(1)=-0.5D0*bb(itypi,itypj)/aa(itypi,itypj)*ljB + d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt) + d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- + + alf12/eps3rt) + d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt) + f1=(rij-ljxm)/(xm-ljxm) + f2=(rij-xm)/(ljxm-xm) + h1=h_base(f1,hd1) + h2=h_base(f2,hd2) + eij=Ht*h1+ljm*h2 + delta_inv=1.0d0/(ljxm-xm) + deltasq_inv=delta_inv*delta_inv + fac=Ht*hd1-ljm*hd2 + fac1=deltasq_inv*fac*(ljxm-rij) + fac2=deltasq_inv*fac*(rij-xm) + ed=delta_inv*(ljm*hd2-Ht*hd1) + eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1) + eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2) + eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3) + endif +c-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE + +c-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE +c$$$ ssd=rij-ssXs +c$$$ ljd=rij-ljXs +c$$$ fac1=rij-ljxm +c$$$ fac2=rij-ssxm +c$$$ +c$$$ d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt) +c$$$ d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt) +c$$$ d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt) +c$$$ +c$$$ ssm=ssC-0.25D0*ssB*ssB/ssA +c$$$ d_ssm(1)=0.5D0*akct*ssB/ssA +c$$$ d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1) +c$$$ d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1) +c$$$ d_ssm(3)=omega +c$$$ +c$$$ ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj) +c$$$ do k=1,3 +c$$$ d_ljm(k)=ljm*d_ljB(k) +c$$$ enddo +c$$$ ljm=ljm*ljB +c$$$ +c$$$ ss=ssA*ssd*ssd+ssB*ssd+ssC +c$$$ d_ss(0)=2.0d0*ssA*ssd+ssB +c$$$ d_ss(2)=akct*ssd +c$$$ d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega +c$$$ d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega +c$$$ d_ss(3)=omega +c$$$ +c$$$ ljf=bb(itypi,itypj)/aa(itypi,itypj) +c$$$ ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0) +c$$$ d_ljf(0)=ljf*2.0d0*ljB*fac1 +c$$$ do k=1,3 +c$$$ d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1- +c$$$ & 2.0d0*ljB*fac1*d_ljxm(k)) +c$$$ enddo +c$$$ ljf=ljm+ljf*ljB*fac1*fac1 +c$$$ +c$$$ f1=(rij-ljxm)/(ssxm-ljxm) +c$$$ f2=(rij-ssxm)/(ljxm-ssxm) +c$$$ h1=h_base(f1,hd1) +c$$$ h2=h_base(f2,hd2) +c$$$ eij=ss*h1+ljf*h2 +c$$$ delta_inv=1.0d0/(ljxm-ssxm) +c$$$ deltasq_inv=delta_inv*delta_inv +c$$$ fac=ljf*hd2-ss*hd1 +c$$$ ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac +c$$$ eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac* +c$$$ & (fac1*d_ssxm(1)-fac2*(d_ljxm(1))) +c$$$ eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac* +c$$$ & (fac1*d_ssxm(2)-fac2*(d_ljxm(2))) +c$$$ eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac* +c$$$ & (fac1*d_ssxm(3)-fac2*(d_ljxm(3))) +c$$$ +c$$$ havebond=.false. +c$$$ if (ed.gt.0.0d0) havebond=.true. +c-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE + + endif + + if (havebond) then +#ifndef CLUST +#ifndef WHAM +c if (dyn_ssbond_ij(i,j).eq.1.0d300) then +c write(iout,'(a15,f12.2,f8.1,2i5)') +c & "SSBOND_E_FORM",totT,t_bath,i,j +c endif +#endif +#endif + dyn_ssbond_ij(i,j)=eij + else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then + dyn_ssbond_ij(i,j)=1.0d300 +#ifndef CLUST +#ifndef WHAM +c write(iout,'(a15,f12.2,f8.1,2i5)') +c & "SSBOND_E_BREAK",totT,t_bath,i,j +#endif +#endif + endif + +c-------TESTING CODE + if (checkstop) then + if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') + & "CHECKSTOP",rij,eij,ed + echeck(jcheck)=eij + endif + enddo + if (checkstop) then + write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps + endif + enddo + if (checkstop) then + transgrad=.true. + checkstop=.false. + endif +c-------END TESTING CODE + + do k=1,3 + dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij + dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij + enddo + do k=1,3 + gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k) + enddo + do k=1,3 + gvdwx(k,i)=gvdwx(k,i)-gg(k) + & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) + & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv + gvdwx(k,j)=gvdwx(k,j)+gg(k) + & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) + & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv + enddo +cgrad do k=i,j-1 +cgrad do l=1,3 +cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l) +cgrad enddo +cgrad enddo + + do l=1,3 + gvdwc(l,i)=gvdwc(l,i)-gg(l) + gvdwc(l,j)=gvdwc(l,j)+gg(l) + enddo + + return + end + +C----------------------------------------------------------------------------- + + double precision function h_base(x,deriv) +c A smooth function going 0->1 in range [0,1] +c It should NOT be called outside range [0,1], it will not work there. + implicit none + +c Input arguments + double precision x + +c Output arguments + double precision deriv + +c Local variables + double precision xsq + + +c Two parabolas put together. First derivative zero at extrema +c$$$ if (x.lt.0.5D0) then +c$$$ h_base=2.0D0*x*x +c$$$ deriv=4.0D0*x +c$$$ else +c$$$ deriv=1.0D0-x +c$$$ h_base=1.0D0-2.0D0*deriv*deriv +c$$$ deriv=4.0D0*deriv +c$$$ endif + +c Third degree polynomial. First derivative zero at extrema + h_base=x*x*(3.0d0-2.0d0*x) + deriv=6.0d0*x*(1.0d0-x) + +c Fifth degree polynomial. First and second derivatives zero at extrema +c$$$ xsq=x*x +c$$$ h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0) +c$$$ deriv=x-1.0d0 +c$$$ deriv=deriv*deriv +c$$$ deriv=30.0d0*xsq*deriv + + return + end + +c---------------------------------------------------------------------------- + + subroutine dyn_set_nss +c Adjust nss and other relevant variables based on dyn_ssbond_ij +c implicit none + +c Includes + include 'DIMENSIONS' +#ifdef MPI + include "mpif.h" +#endif + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.SETUP' +#ifndef CLUST +#ifndef WHAM + include 'COMMON.MD' +#endif +#endif + +c Local variables + double precision emin + integer i,j,imin + integer diff,allflag(maxdim),allnss, + & allihpb(maxdim),alljhpb(maxdim), + & newnss,newihpb(maxdim),newjhpb(maxdim) + logical found + integer i_newnss(max_fg_procs),displ(0:max_fg_procs) + integer g_newihpb(maxdim),g_newjhpb(maxdim),g_newnss + + allnss=0 + do i=1,nres-1 + do j=i+1,nres + if (dyn_ssbond_ij(i,j).lt.1.0d300) then + allnss=allnss+1 + allflag(allnss)=0 + allihpb(allnss)=i + alljhpb(allnss)=j + endif + enddo + enddo + +cmc write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss) + + 1 emin=1.0d300 + do i=1,allnss + if (allflag(i).eq.0 .and. + & dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then + emin=dyn_ssbond_ij(allihpb(i),alljhpb(i)) + imin=i + endif + enddo + if (emin.lt.1.0d300) then + allflag(imin)=1 + do i=1,allnss + if (allflag(i).eq.0 .and. + & (allihpb(i).eq.allihpb(imin) .or. + & alljhpb(i).eq.allihpb(imin) .or. + & allihpb(i).eq.alljhpb(imin) .or. + & alljhpb(i).eq.alljhpb(imin))) then + allflag(i)=-1 + endif + enddo + goto 1 + endif + +cmc write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss) + + newnss=0 + do i=1,allnss + if (allflag(i).eq.1) then + newnss=newnss+1 + newihpb(newnss)=allihpb(i) + newjhpb(newnss)=alljhpb(i) + endif + enddo + +#ifdef MPI + if (nfgtasks.gt.1)then + + call MPI_Reduce(newnss,g_newnss,1, + & MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR) + call MPI_Gather(newnss,1,MPI_INTEGER, + & i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR) + displ(0)=0 + do i=1,nfgtasks-1,1 + displ(i)=i_newnss(i-1)+displ(i-1) + enddo + call MPI_Gatherv(newihpb,newnss,MPI_INTEGER, + & g_newihpb,i_newnss,displ,MPI_INTEGER, + & king,FG_COMM,IERR) + call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER, + & g_newjhpb,i_newnss,displ,MPI_INTEGER, + & king,FG_COMM,IERR) + if(fg_rank.eq.0) then +c print *,'g_newnss',g_newnss +c print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss) +c print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss) + newnss=g_newnss + do i=1,newnss + newihpb(i)=g_newihpb(i) + newjhpb(i)=g_newjhpb(i) + enddo + endif + endif +#endif + + diff=newnss-nss + +cmc write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss) + + do i=1,nss + found=.false. + do j=1,newnss + if (idssb(i).eq.newihpb(j) .and. + & jdssb(i).eq.newjhpb(j)) found=.true. + enddo +#ifndef CLUST +#ifndef WHAM + if (.not.found.and.fg_rank.eq.0) + & write(iout,'(a15,f12.2,f8.1,2i5)') + & "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i) +#endif +#endif + enddo + + do i=1,newnss + found=.false. + do j=1,nss + if (newihpb(i).eq.idssb(j) .and. + & newjhpb(i).eq.jdssb(j)) found=.true. + enddo +#ifndef CLUST +#ifndef WHAM + if (.not.found.and.fg_rank.eq.0) + & write(iout,'(a15,f12.2,f8.1,2i5)') + & "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i) +#endif +#endif + enddo + + nss=newnss + do i=1,nss + idssb(i)=newihpb(i) + jdssb(i)=newjhpb(i) + enddo + + return + end + +c---------------------------------------------------------------------------- + +#ifdef WHAM + subroutine read_ssHist + implicit none + +c Includes + include 'DIMENSIONS' + include "DIMENSIONS.FREE" + include 'COMMON.FREE' + +c Local variables + integer i,j + character*80 controlcard + + do i=1,dyn_nssHist + call card_concat(controlcard,.true.) + read(controlcard,*) + & dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0)) + enddo + + return + end +#endif + +c---------------------------------------------------------------------------- + + +C----------------------------------------------------------------------------- +C----------------------------------------------------------------------------- +C----------------------------------------------------------------------------- +C----------------------------------------------------------------------------- +C----------------------------------------------------------------------------- +C----------------------------------------------------------------------------- +C----------------------------------------------------------------------------- + +c$$$c----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine ss_relax(i_in,j_in) +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.INTERACT' +c$$$ +c$$$c Input arguments +c$$$ integer i_in,j_in +c$$$ +c$$$c Local variables +c$$$ integer i,iretcode,nfun_sc +c$$$ logical scfail +c$$$ double precision var(maxvar),e_sc,etot +c$$$ +c$$$ +c$$$ mask_r=.true. +c$$$ do i=nnt,nct +c$$$ mask_side(i)=0 +c$$$ enddo +c$$$ mask_side(i_in)=1 +c$$$ mask_side(j_in)=1 +c$$$ +c$$$c Minimize the two selected side-chains +c$$$ call overlap_sc(scfail) ! Better not fail! +c$$$ call minimize_sc(e_sc,var,iretcode,nfun_sc) +c$$$ +c$$$ mask_r=.false. +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$c------------------------------------------------------------- +c$$$ +c$$$ subroutine minimize_sc(etot_sc,iretcode,nfun) +c$$$c Minimize side-chains only, starting from geom but without modifying +c$$$c bond lengths. +c$$$c If mask_r is already set, only the selected side-chains are minimized, +c$$$c otherwise all side-chains are minimized keeping the backbone frozen. +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.GEO' +c$$$ include 'COMMON.MINIM' +c$$$ integer icall +c$$$ common /srutu/ icall +c$$$ +c$$$c Output arguments +c$$$ double precision etot_sc +c$$$ integer iretcode,nfun +c$$$ +c$$$c External functions/subroutines +c$$$ external func_sc,grad_sc,fdum +c$$$ +c$$$c Local variables +c$$$ integer liv,lv +c$$$ parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2)) +c$$$ integer iv(liv) +c$$$ double precision rdum(1) +c$$$ double precision d(maxvar),v(1:lv),x(maxvar),xx(maxvar) +c$$$ integer idum(1) +c$$$ integer i,nvar_restr +c$$$ +c$$$ +c$$$cmc start_minim=.true. +c$$$ call deflt(2,iv,liv,lv,v) +c$$$* 12 means fresh start, dont call deflt +c$$$ iv(1)=12 +c$$$* max num of fun calls +c$$$ if (maxfun.eq.0) maxfun=500 +c$$$ iv(17)=maxfun +c$$$* max num of iterations +c$$$ if (maxmin.eq.0) maxmin=1000 +c$$$ iv(18)=maxmin +c$$$* controls output +c$$$ iv(19)=1 +c$$$* selects output unit +c$$$ iv(21)=0 +c$$$c iv(21)=iout ! DEBUG +c$$$c iv(21)=8 ! DEBUG +c$$$* 1 means to print out result +c$$$ iv(22)=0 +c$$$c iv(22)=1 ! DEBUG +c$$$* 1 means to print out summary stats +c$$$ iv(23)=0 +c$$$c iv(23)=1 ! DEBUG +c$$$* 1 means to print initial x and d +c$$$ iv(24)=0 +c$$$c iv(24)=1 ! DEBUG +c$$$* min val for v(radfac) default is 0.1 +c$$$ v(24)=0.1D0 +c$$$* max val for v(radfac) default is 4.0 +c$$$ v(25)=2.0D0 +c$$$c v(25)=4.0D0 +c$$$* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) +c$$$* the sumsl default is 0.1 +c$$$ v(26)=0.1D0 +c$$$* false conv if (act fnctn decrease) .lt. v(34) +c$$$* the sumsl default is 100*machep +c$$$ v(34)=v(34)/100.0D0 +c$$$* absolute convergence +c$$$ if (tolf.eq.0.0D0) tolf=1.0D-4 +c$$$ v(31)=tolf +c$$$* relative convergence +c$$$ if (rtolf.eq.0.0D0) rtolf=1.0D-1 +c$$$ v(32)=rtolf +c$$$* controls initial step size +c$$$ v(35)=1.0D-1 +c$$$* large vals of d correspond to small components of step +c$$$ do i=1,nphi +c$$$ d(i)=1.0D-1 +c$$$ enddo +c$$$ do i=nphi+1,nvar +c$$$ d(i)=1.0D-1 +c$$$ enddo +c$$$ +c$$$ call geom_to_var(nvar,x) +c$$$ IF (mask_r) THEN +c$$$ do i=1,nres ! Just in case... +c$$$ mask_phi(i)=0 +c$$$ mask_theta(i)=0 +c$$$ enddo +c$$$ call x2xx(x,xx,nvar_restr) +c$$$ call sumsl(nvar_restr,d,xx,func_sc,grad_sc, +c$$$ & iv,liv,lv,v,idum,rdum,fdum) +c$$$ call xx2x(x,xx) +c$$$ ELSE +c$$$c When minimizing ALL side-chains, etotal_sc is a little +c$$$c faster if we don't set mask_r +c$$$ do i=1,nres +c$$$ mask_phi(i)=0 +c$$$ mask_theta(i)=0 +c$$$ mask_side(i)=1 +c$$$ enddo +c$$$ call x2xx(x,xx,nvar_restr) +c$$$ call sumsl(nvar_restr,d,xx,func_sc,grad_sc, +c$$$ & iv,liv,lv,v,idum,rdum,fdum) +c$$$ call xx2x(x,xx) +c$$$ ENDIF +c$$$ call var_to_geom(nvar,x) +c$$$ call chainbuild_sc +c$$$ etot_sc=v(10) +c$$$ iretcode=iv(1) +c$$$ nfun=iv(6) +c$$$ return +c$$$ end +c$$$ +c$$$C-------------------------------------------------------------------------- +c$$$ +c$$$ subroutine chainbuild_sc +c$$$ implicit none +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.INTERACT' +c$$$ +c$$$c Local variables +c$$$ integer i +c$$$ +c$$$ +c$$$ do i=nnt,nct +c$$$ if (.not.mask_r .or. mask_side(i).eq.1) then +c$$$ call locate_side_chain(i) +c$$$ endif +c$$$ enddo +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$C-------------------------------------------------------------------------- +c$$$ +c$$$ subroutine func_sc(n,x,nf,f,uiparm,urparm,ufparm) +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.MINIM' +c$$$ include 'COMMON.IOUNITS' +c$$$ +c$$$c Input arguments +c$$$ integer n +c$$$ double precision x(maxvar) +c$$$ double precision ufparm +c$$$ external ufparm +c$$$ +c$$$c Input/Output arguments +c$$$ integer nf +c$$$ integer uiparm(1) +c$$$ double precision urparm(1) +c$$$ +c$$$c Output arguments +c$$$ double precision f +c$$$ +c$$$c Local variables +c$$$ double precision energia(0:n_ene) +c$$$#ifdef OSF +c$$$c Variables used to intercept NaNs +c$$$ double precision x_sum +c$$$ integer i_NAN +c$$$#endif +c$$$ +c$$$ +c$$$ nfl=nf +c$$$ icg=mod(nf,2)+1 +c$$$ +c$$$#ifdef OSF +c$$$c Intercept NaNs in the coordinates, before calling etotal_sc +c$$$ x_sum=0.D0 +c$$$ do i_NAN=1,n +c$$$ x_sum=x_sum+x(i_NAN) +c$$$ enddo +c$$$c Calculate the energy only if the coordinates are ok +c$$$ if ((.not.(x_sum.lt.0.D0)) .and. (.not.(x_sum.ge.0.D0))) then +c$$$ write(iout,*)" *** func_restr_sc : Found NaN in coordinates" +c$$$ f=1.0D+77 +c$$$ nf=0 +c$$$ else +c$$$#endif +c$$$ +c$$$ call var_to_geom_restr(n,x) +c$$$ call zerograd +c$$$ call chainbuild_sc +c$$$ call etotal_sc(energia(0)) +c$$$ f=energia(0) +c$$$ if (energia(1).eq.1.0D20 .or. energia(0).eq.1.0D99) nf=0 +c$$$ +c$$$#ifdef OSF +c$$$ endif +c$$$#endif +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$c------------------------------------------------------- +c$$$ +c$$$ subroutine grad_sc(n,x,nf,g,uiparm,urparm,ufparm) +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.INTERACT' +c$$$ include 'COMMON.MINIM' +c$$$ +c$$$c Input arguments +c$$$ integer n +c$$$ double precision x(maxvar) +c$$$ double precision ufparm +c$$$ external ufparm +c$$$ +c$$$c Input/Output arguments +c$$$ integer nf +c$$$ integer uiparm(1) +c$$$ double precision urparm(1) +c$$$ +c$$$c Output arguments +c$$$ double precision g(maxvar) +c$$$ +c$$$c Local variables +c$$$ double precision f,gphii,gthetai,galphai,gomegai +c$$$ integer ig,ind,i,j,k,igall,ij +c$$$ +c$$$ +c$$$ icg=mod(nf,2)+1 +c$$$ if (nf-nfl+1) 20,30,40 +c$$$ 20 call func_sc(n,x,nf,f,uiparm,urparm,ufparm) +c$$$c write (iout,*) 'grad 20' +c$$$ if (nf.eq.0) return +c$$$ goto 40 +c$$$ 30 call var_to_geom_restr(n,x) +c$$$ call chainbuild_sc +c$$$C +c$$$C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. +c$$$C +c$$$ 40 call cartder +c$$$C +c$$$C Convert the Cartesian gradient into internal-coordinate gradient. +c$$$C +c$$$ +c$$$ ig=0 +c$$$ ind=nres-2 +c$$$ do i=2,nres-2 +c$$$ IF (mask_phi(i+2).eq.1) THEN +c$$$ gphii=0.0D0 +c$$$ do j=i+1,nres-1 +c$$$ ind=ind+1 +c$$$ do k=1,3 +c$$$ gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) +c$$$ gphii=gphii+dxdv(k+3,ind)*gradx(k,j,icg) +c$$$ enddo +c$$$ enddo +c$$$ ig=ig+1 +c$$$ g(ig)=gphii +c$$$ ELSE +c$$$ ind=ind+nres-1-i +c$$$ ENDIF +c$$$ enddo +c$$$ +c$$$ +c$$$ ind=0 +c$$$ do i=1,nres-2 +c$$$ IF (mask_theta(i+2).eq.1) THEN +c$$$ ig=ig+1 +c$$$ gthetai=0.0D0 +c$$$ do j=i+1,nres-1 +c$$$ ind=ind+1 +c$$$ do k=1,3 +c$$$ gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) +c$$$ gthetai=gthetai+dxdv(k,ind)*gradx(k,j,icg) +c$$$ enddo +c$$$ enddo +c$$$ g(ig)=gthetai +c$$$ ELSE +c$$$ ind=ind+nres-1-i +c$$$ ENDIF +c$$$ enddo +c$$$ +c$$$ do i=2,nres-1 +c$$$ if (itype(i).ne.10) then +c$$$ IF (mask_side(i).eq.1) THEN +c$$$ ig=ig+1 +c$$$ galphai=0.0D0 +c$$$ do k=1,3 +c$$$ galphai=galphai+dxds(k,i)*gradx(k,i,icg) +c$$$ enddo +c$$$ g(ig)=galphai +c$$$ ENDIF +c$$$ endif +c$$$ enddo +c$$$ +c$$$ +c$$$ do i=2,nres-1 +c$$$ if (itype(i).ne.10) then +c$$$ IF (mask_side(i).eq.1) THEN +c$$$ ig=ig+1 +c$$$ gomegai=0.0D0 +c$$$ do k=1,3 +c$$$ gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) +c$$$ enddo +c$$$ g(ig)=gomegai +c$$$ ENDIF +c$$$ endif +c$$$ enddo +c$$$ +c$$$C +c$$$C Add the components corresponding to local energy terms. +c$$$C +c$$$ +c$$$ ig=0 +c$$$ igall=0 +c$$$ do i=4,nres +c$$$ igall=igall+1 +c$$$ if (mask_phi(i).eq.1) then +c$$$ ig=ig+1 +c$$$ g(ig)=g(ig)+gloc(igall,icg) +c$$$ endif +c$$$ enddo +c$$$ +c$$$ do i=3,nres +c$$$ igall=igall+1 +c$$$ if (mask_theta(i).eq.1) then +c$$$ ig=ig+1 +c$$$ g(ig)=g(ig)+gloc(igall,icg) +c$$$ endif +c$$$ enddo +c$$$ +c$$$ do ij=1,2 +c$$$ do i=2,nres-1 +c$$$ if (itype(i).ne.10) then +c$$$ igall=igall+1 +c$$$ if (mask_side(i).eq.1) then +c$$$ ig=ig+1 +c$$$ g(ig)=g(ig)+gloc(igall,icg) +c$$$ endif +c$$$ endif +c$$$ enddo +c$$$ enddo +c$$$ +c$$$cd do i=1,ig +c$$$cd write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i) +c$$$cd enddo +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$C----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine etotal_sc(energy_sc) +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.INTERACT' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.FFIELD' +c$$$ +c$$$c Output arguments +c$$$ double precision energy_sc(0:n_ene) +c$$$ +c$$$c Local variables +c$$$ double precision evdw,escloc +c$$$ integer i,j +c$$$ +c$$$ +c$$$ do i=1,n_ene +c$$$ energy_sc(i)=0.0D0 +c$$$ enddo +c$$$ +c$$$ if (mask_r) then +c$$$ call egb_sc(evdw) +c$$$ call esc_sc(escloc) +c$$$ else +c$$$ call egb(evdw) +c$$$ call esc(escloc) +c$$$ endif +c$$$ +c$$$ if (evdw.eq.1.0D20) then +c$$$ energy_sc(0)=evdw +c$$$ else +c$$$ energy_sc(0)=wsc*evdw+wscloc*escloc +c$$$ endif +c$$$ energy_sc(1)=evdw +c$$$ energy_sc(12)=escloc +c$$$ +c$$$C +c$$$C Sum up the components of the Cartesian gradient. +c$$$C +c$$$ do i=1,nct +c$$$ do j=1,3 +c$$$ gradx(j,i,icg)=wsc*gvdwx(j,i) +c$$$ enddo +c$$$ enddo +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$C----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine egb_sc(evdw) +c$$$C +c$$$C This subroutine calculates the interaction energy of nonbonded side chains +c$$$C assuming the Gay-Berne potential of interaction. +c$$$C +c$$$ implicit real*8 (a-h,o-z) +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.GEO' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.LOCAL' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.NAMES' +c$$$ include 'COMMON.INTERACT' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.CALC' +c$$$ include 'COMMON.CONTROL' +c$$$ logical lprn +c$$$ evdw=0.0D0 +c$$$ energy_dec=.false. +c$$$c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon +c$$$ evdw=0.0D0 +c$$$ lprn=.false. +c$$$c if (icall.eq.0) lprn=.false. +c$$$ ind=0 +c$$$ do i=iatsc_s,iatsc_e +c$$$ itypi=itype(i) +c$$$ itypi1=itype(i+1) +c$$$ xi=c(1,nres+i) +c$$$ yi=c(2,nres+i) +c$$$ zi=c(3,nres+i) +c$$$ dxi=dc_norm(1,nres+i) +c$$$ dyi=dc_norm(2,nres+i) +c$$$ dzi=dc_norm(3,nres+i) +c$$$c dsci_inv=dsc_inv(itypi) +c$$$ dsci_inv=vbld_inv(i+nres) +c$$$c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres) +c$$$c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi +c$$$C +c$$$C Calculate SC interaction energy. +c$$$C +c$$$ do iint=1,nint_gr(i) +c$$$ do j=istart(i,iint),iend(i,iint) +c$$$ IF (mask_side(j).eq.1.or.mask_side(i).eq.1) THEN +c$$$ ind=ind+1 +c$$$ itypj=itype(j) +c$$$c dscj_inv=dsc_inv(itypj) +c$$$ dscj_inv=vbld_inv(j+nres) +c$$$c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv, +c$$$c & 1.0d0/vbld(j+nres) +c$$$c write (iout,*) "i",i," j", j," itype",itype(i),itype(j) +c$$$ sig0ij=sigma(itypi,itypj) +c$$$ chi1=chi(itypi,itypj) +c$$$ chi2=chi(itypj,itypi) +c$$$ chi12=chi1*chi2 +c$$$ chip1=chip(itypi) +c$$$ chip2=chip(itypj) +c$$$ chip12=chip1*chip2 +c$$$ alf1=alp(itypi) +c$$$ alf2=alp(itypj) +c$$$ alf12=0.5D0*(alf1+alf2) +c$$$C For diagnostics only!!! +c$$$c chi1=0.0D0 +c$$$c chi2=0.0D0 +c$$$c chi12=0.0D0 +c$$$c chip1=0.0D0 +c$$$c chip2=0.0D0 +c$$$c chip12=0.0D0 +c$$$c alf1=0.0D0 +c$$$c alf2=0.0D0 +c$$$c alf12=0.0D0 +c$$$ xj=c(1,nres+j)-xi +c$$$ yj=c(2,nres+j)-yi +c$$$ zj=c(3,nres+j)-zi +c$$$ dxj=dc_norm(1,nres+j) +c$$$ dyj=dc_norm(2,nres+j) +c$$$ dzj=dc_norm(3,nres+j) +c$$$c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi +c$$$c write (iout,*) "j",j," dc_norm", +c$$$c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j) +c$$$ rrij=1.0D0/(xj*xj+yj*yj+zj*zj) +c$$$ rij=dsqrt(rrij) +c$$$C Calculate angle-dependent terms of energy and contributions to their +c$$$C derivatives. +c$$$ call sc_angular +c$$$ sigsq=1.0D0/sigsq +c$$$ sig=sig0ij*dsqrt(sigsq) +c$$$ rij_shift=1.0D0/rij-sig+sig0ij +c$$$c for diagnostics; uncomment +c$$$c rij_shift=1.2*sig0ij +c$$$C I hate to put IF's in the loops, but here don't have another choice!!!! +c$$$ if (rij_shift.le.0.0D0) then +c$$$ evdw=1.0D20 +c$$$cd write (iout,'(2(a3,i3,2x),17(0pf7.3))') +c$$$cd & restyp(itypi),i,restyp(itypj),j, +c$$$cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq) +c$$$ return +c$$$ endif +c$$$ sigder=-sig*sigsq +c$$$c--------------------------------------------------------------- +c$$$ rij_shift=1.0D0/rij_shift +c$$$ fac=rij_shift**expon +c$$$ e1=fac*fac*aa(itypi,itypj) +c$$$ e2=fac*bb(itypi,itypj) +c$$$ evdwij=eps1*eps2rt*eps3rt*(e1+e2) +c$$$ eps2der=evdwij*eps3rt +c$$$ eps3der=evdwij*eps2rt +c$$$c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt, +c$$$c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2 +c$$$ evdwij=evdwij*eps2rt*eps3rt +c$$$ evdw=evdw+evdwij +c$$$ if (lprn) then +c$$$ sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) +c$$$ epsi=bb(itypi,itypj)**2/aa(itypi,itypj) +c$$$ write (iout,'(2(a3,i3,2x),17(0pf7.3))') +c$$$ & restyp(itypi),i,restyp(itypj),j, +c$$$ & epsi,sigm,chi1,chi2,chip1,chip2, +c$$$ & eps1,eps2rt**2,eps3rt**2,sig,sig0ij, +c$$$ & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, +c$$$ & evdwij +c$$$ endif +c$$$ +c$$$ if (energy_dec) write (iout,'(a6,2i,0pf7.3)') +c$$$ & 'evdw',i,j,evdwij +c$$$ +c$$$C Calculate gradient components. +c$$$ e1=e1*eps1*eps2rt**2*eps3rt**2 +c$$$ fac=-expon*(e1+evdwij)*rij_shift +c$$$ sigder=fac*sigder +c$$$ fac=rij*fac +c$$$c fac=0.0d0 +c$$$C Calculate the radial part of the gradient +c$$$ gg(1)=xj*fac +c$$$ gg(2)=yj*fac +c$$$ gg(3)=zj*fac +c$$$C Calculate angular part of the gradient. +c$$$ call sc_grad +c$$$ ENDIF +c$$$ enddo ! j +c$$$ enddo ! iint +c$$$ enddo ! i +c$$$ energy_dec=.false. +c$$$ return +c$$$ end +c$$$ +c$$$c----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine esc_sc(escloc) +c$$$C Calculate the local energy of a side chain and its derivatives in the +c$$$C corresponding virtual-bond valence angles THETA and the spherical angles +c$$$C ALPHA and OMEGA. +c$$$ implicit real*8 (a-h,o-z) +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.GEO' +c$$$ include 'COMMON.LOCAL' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.INTERACT' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.NAMES' +c$$$ include 'COMMON.FFIELD' +c$$$ include 'COMMON.CONTROL' +c$$$ double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3), +c$$$ & ddersc0(3),ddummy(3),xtemp(3),temp(3) +c$$$ common /sccalc/ time11,time12,time112,theti,it,nlobit +c$$$ delta=0.02d0*pi +c$$$ escloc=0.0D0 +c$$$c write (iout,'(a)') 'ESC' +c$$$ do i=loc_start,loc_end +c$$$ IF (mask_side(i).eq.1) THEN +c$$$ it=itype(i) +c$$$ if (it.eq.10) goto 1 +c$$$ nlobit=nlob(it) +c$$$c print *,'i=',i,' it=',it,' nlobit=',nlobit +c$$$c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad +c$$$ theti=theta(i+1)-pipol +c$$$ x(1)=dtan(theti) +c$$$ x(2)=alph(i) +c$$$ x(3)=omeg(i) +c$$$ +c$$$ if (x(2).gt.pi-delta) then +c$$$ xtemp(1)=x(1) +c$$$ xtemp(2)=pi-delta +c$$$ xtemp(3)=x(3) +c$$$ call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) +c$$$ xtemp(2)=pi +c$$$ call enesc(xtemp,escloci1,dersc1,ddummy,.false.) +c$$$ call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2), +c$$$ & escloci,dersc(2)) +c$$$ call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), +c$$$ & ddersc0(1),dersc(1)) +c$$$ call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3), +c$$$ & ddersc0(3),dersc(3)) +c$$$ xtemp(2)=pi-delta +c$$$ call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) +c$$$ xtemp(2)=pi +c$$$ call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) +c$$$ call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1, +c$$$ & dersc0(2),esclocbi,dersc02) +c$$$ call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), +c$$$ & dersc12,dersc01) +c$$$ call splinthet(x(2),0.5d0*delta,ss,ssd) +c$$$ dersc0(1)=dersc01 +c$$$ dersc0(2)=dersc02 +c$$$ dersc0(3)=0.0d0 +c$$$ do k=1,3 +c$$$ dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) +c$$$ enddo +c$$$ dersc(2)=dersc(2)+ssd*(escloci-esclocbi) +c$$$c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, +c$$$c & esclocbi,ss,ssd +c$$$ escloci=ss*escloci+(1.0d0-ss)*esclocbi +c$$$c escloci=esclocbi +c$$$c write (iout,*) escloci +c$$$ else if (x(2).lt.delta) then +c$$$ xtemp(1)=x(1) +c$$$ xtemp(2)=delta +c$$$ xtemp(3)=x(3) +c$$$ call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) +c$$$ xtemp(2)=0.0d0 +c$$$ call enesc(xtemp,escloci1,dersc1,ddummy,.false.) +c$$$ call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2), +c$$$ & escloci,dersc(2)) +c$$$ call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), +c$$$ & ddersc0(1),dersc(1)) +c$$$ call spline2(x(2),delta,-delta,dersc0(3),dersc1(3), +c$$$ & ddersc0(3),dersc(3)) +c$$$ xtemp(2)=delta +c$$$ call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) +c$$$ xtemp(2)=0.0d0 +c$$$ call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) +c$$$ call spline1(x(2),delta,-delta,esclocbi0,esclocbi1, +c$$$ & dersc0(2),esclocbi,dersc02) +c$$$ call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), +c$$$ & dersc12,dersc01) +c$$$ dersc0(1)=dersc01 +c$$$ dersc0(2)=dersc02 +c$$$ dersc0(3)=0.0d0 +c$$$ call splinthet(x(2),0.5d0*delta,ss,ssd) +c$$$ do k=1,3 +c$$$ dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) +c$$$ enddo +c$$$ dersc(2)=dersc(2)+ssd*(escloci-esclocbi) +c$$$c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, +c$$$c & esclocbi,ss,ssd +c$$$ escloci=ss*escloci+(1.0d0-ss)*esclocbi +c$$$c write (iout,*) escloci +c$$$ else +c$$$ call enesc(x,escloci,dersc,ddummy,.false.) +c$$$ endif +c$$$ +c$$$ escloc=escloc+escloci +c$$$ if (energy_dec) write (iout,'(a6,i,0pf7.3)') +c$$$ & 'escloc',i,escloci +c$$$c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc +c$$$ +c$$$ gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ +c$$$ & wscloc*dersc(1) +c$$$ gloc(ialph(i,1),icg)=wscloc*dersc(2) +c$$$ gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3) +c$$$ 1 continue +c$$$ ENDIF +c$$$ enddo +c$$$ return +c$$$ end +c$$$ +c$$$C----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine egb_ij(i_sc,j_sc,evdw) +c$$$C +c$$$C This subroutine calculates the interaction energy of nonbonded side chains +c$$$C assuming the Gay-Berne potential of interaction. +c$$$C +c$$$ implicit real*8 (a-h,o-z) +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.GEO' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.LOCAL' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.NAMES' +c$$$ include 'COMMON.INTERACT' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.CALC' +c$$$ include 'COMMON.CONTROL' +c$$$ logical lprn +c$$$ evdw=0.0D0 +c$$$ energy_dec=.false. +c$$$c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon +c$$$ evdw=0.0D0 +c$$$ lprn=.false. +c$$$ ind=0 +c$$$c$$$ do i=iatsc_s,iatsc_e +c$$$ i=i_sc +c$$$ itypi=itype(i) +c$$$ itypi1=itype(i+1) +c$$$ xi=c(1,nres+i) +c$$$ yi=c(2,nres+i) +c$$$ zi=c(3,nres+i) +c$$$ dxi=dc_norm(1,nres+i) +c$$$ dyi=dc_norm(2,nres+i) +c$$$ dzi=dc_norm(3,nres+i) +c$$$c dsci_inv=dsc_inv(itypi) +c$$$ dsci_inv=vbld_inv(i+nres) +c$$$c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres) +c$$$c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi +c$$$C +c$$$C Calculate SC interaction energy. +c$$$C +c$$$c$$$ do iint=1,nint_gr(i) +c$$$c$$$ do j=istart(i,iint),iend(i,iint) +c$$$ j=j_sc +c$$$ ind=ind+1 +c$$$ itypj=itype(j) +c$$$c dscj_inv=dsc_inv(itypj) +c$$$ dscj_inv=vbld_inv(j+nres) +c$$$c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv, +c$$$c & 1.0d0/vbld(j+nres) +c$$$c write (iout,*) "i",i," j", j," itype",itype(i),itype(j) +c$$$ sig0ij=sigma(itypi,itypj) +c$$$ chi1=chi(itypi,itypj) +c$$$ chi2=chi(itypj,itypi) +c$$$ chi12=chi1*chi2 +c$$$ chip1=chip(itypi) +c$$$ chip2=chip(itypj) +c$$$ chip12=chip1*chip2 +c$$$ alf1=alp(itypi) +c$$$ alf2=alp(itypj) +c$$$ alf12=0.5D0*(alf1+alf2) +c$$$C For diagnostics only!!! +c$$$c chi1=0.0D0 +c$$$c chi2=0.0D0 +c$$$c chi12=0.0D0 +c$$$c chip1=0.0D0 +c$$$c chip2=0.0D0 +c$$$c chip12=0.0D0 +c$$$c alf1=0.0D0 +c$$$c alf2=0.0D0 +c$$$c alf12=0.0D0 +c$$$ xj=c(1,nres+j)-xi +c$$$ yj=c(2,nres+j)-yi +c$$$ zj=c(3,nres+j)-zi +c$$$ dxj=dc_norm(1,nres+j) +c$$$ dyj=dc_norm(2,nres+j) +c$$$ dzj=dc_norm(3,nres+j) +c$$$c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi +c$$$c write (iout,*) "j",j," dc_norm", +c$$$c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j) +c$$$ rrij=1.0D0/(xj*xj+yj*yj+zj*zj) +c$$$ rij=dsqrt(rrij) +c$$$C Calculate angle-dependent terms of energy and contributions to their +c$$$C derivatives. +c$$$ call sc_angular +c$$$ sigsq=1.0D0/sigsq +c$$$ sig=sig0ij*dsqrt(sigsq) +c$$$ rij_shift=1.0D0/rij-sig+sig0ij +c$$$c for diagnostics; uncomment +c$$$c rij_shift=1.2*sig0ij +c$$$C I hate to put IF's in the loops, but here don't have another choice!!!! +c$$$ if (rij_shift.le.0.0D0) then +c$$$ evdw=1.0D20 +c$$$cd write (iout,'(2(a3,i3,2x),17(0pf7.3))') +c$$$cd & restyp(itypi),i,restyp(itypj),j, +c$$$cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq) +c$$$ return +c$$$ endif +c$$$ sigder=-sig*sigsq +c$$$c--------------------------------------------------------------- +c$$$ rij_shift=1.0D0/rij_shift +c$$$ fac=rij_shift**expon +c$$$ e1=fac*fac*aa(itypi,itypj) +c$$$ e2=fac*bb(itypi,itypj) +c$$$ evdwij=eps1*eps2rt*eps3rt*(e1+e2) +c$$$ eps2der=evdwij*eps3rt +c$$$ eps3der=evdwij*eps2rt +c$$$c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt, +c$$$c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2 +c$$$ evdwij=evdwij*eps2rt*eps3rt +c$$$ evdw=evdw+evdwij +c$$$ if (lprn) then +c$$$ sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) +c$$$ epsi=bb(itypi,itypj)**2/aa(itypi,itypj) +c$$$ write (iout,'(2(a3,i3,2x),17(0pf7.3))') +c$$$ & restyp(itypi),i,restyp(itypj),j, +c$$$ & epsi,sigm,chi1,chi2,chip1,chip2, +c$$$ & eps1,eps2rt**2,eps3rt**2,sig,sig0ij, +c$$$ & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, +c$$$ & evdwij +c$$$ endif +c$$$ +c$$$ if (energy_dec) write (iout,'(a6,2i,0pf7.3)') +c$$$ & 'evdw',i,j,evdwij +c$$$ +c$$$C Calculate gradient components. +c$$$ e1=e1*eps1*eps2rt**2*eps3rt**2 +c$$$ fac=-expon*(e1+evdwij)*rij_shift +c$$$ sigder=fac*sigder +c$$$ fac=rij*fac +c$$$c fac=0.0d0 +c$$$C Calculate the radial part of the gradient +c$$$ gg(1)=xj*fac +c$$$ gg(2)=yj*fac +c$$$ gg(3)=zj*fac +c$$$C Calculate angular part of the gradient. +c$$$ call sc_grad +c$$$c$$$ enddo ! j +c$$$c$$$ enddo ! iint +c$$$c$$$ enddo ! i +c$$$ energy_dec=.false. +c$$$ return +c$$$ end +c$$$ +c$$$C----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine perturb_side_chain(i,angle) +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.GEO' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.LOCAL' +c$$$ include 'COMMON.IOUNITS' +c$$$ +c$$$c External functions +c$$$ external ran_number +c$$$ double precision ran_number +c$$$ +c$$$c Input arguments +c$$$ integer i +c$$$ double precision angle ! In degrees +c$$$ +c$$$c Local variables +c$$$ integer i_sc +c$$$ double precision rad_ang,rand_v(3),length,cost,sint +c$$$ +c$$$ +c$$$ i_sc=i+nres +c$$$ rad_ang=angle*deg2rad +c$$$ +c$$$ length=0.0 +c$$$ do while (length.lt.0.01) +c$$$ rand_v(1)=ran_number(0.01D0,1.0D0) +c$$$ rand_v(2)=ran_number(0.01D0,1.0D0) +c$$$ rand_v(3)=ran_number(0.01D0,1.0D0) +c$$$ length=rand_v(1)*rand_v(1)+rand_v(2)*rand_v(2)+ +c$$$ + rand_v(3)*rand_v(3) +c$$$ length=sqrt(length) +c$$$ rand_v(1)=rand_v(1)/length +c$$$ rand_v(2)=rand_v(2)/length +c$$$ rand_v(3)=rand_v(3)/length +c$$$ cost=rand_v(1)*dc_norm(1,i_sc)+rand_v(2)*dc_norm(2,i_sc)+ +c$$$ + rand_v(3)*dc_norm(3,i_sc) +c$$$ length=1.0D0-cost*cost +c$$$ if (length.lt.0.0D0) length=0.0D0 +c$$$ length=sqrt(length) +c$$$ rand_v(1)=rand_v(1)-cost*dc_norm(1,i_sc) +c$$$ rand_v(2)=rand_v(2)-cost*dc_norm(2,i_sc) +c$$$ rand_v(3)=rand_v(3)-cost*dc_norm(3,i_sc) +c$$$ enddo +c$$$ rand_v(1)=rand_v(1)/length +c$$$ rand_v(2)=rand_v(2)/length +c$$$ rand_v(3)=rand_v(3)/length +c$$$ +c$$$ cost=dcos(rad_ang) +c$$$ sint=dsin(rad_ang) +c$$$ dc(1,i_sc)=vbld(i_sc)*(dc_norm(1,i_sc)*cost+rand_v(1)*sint) +c$$$ dc(2,i_sc)=vbld(i_sc)*(dc_norm(2,i_sc)*cost+rand_v(2)*sint) +c$$$ dc(3,i_sc)=vbld(i_sc)*(dc_norm(3,i_sc)*cost+rand_v(3)*sint) +c$$$ dc_norm(1,i_sc)=dc(1,i_sc)*vbld_inv(i_sc) +c$$$ dc_norm(2,i_sc)=dc(2,i_sc)*vbld_inv(i_sc) +c$$$ dc_norm(3,i_sc)=dc(3,i_sc)*vbld_inv(i_sc) +c$$$ c(1,i_sc)=c(1,i)+dc(1,i_sc) +c$$$ c(2,i_sc)=c(2,i)+dc(2,i_sc) +c$$$ c(3,i_sc)=c(3,i)+dc(3,i_sc) +c$$$ +c$$$ call chainbuild_cart +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$c---------------------------------------------------------------------------- +c$$$ +c$$$ subroutine ss_relax3(i_in,j_in) +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.INTERACT' +c$$$ +c$$$c External functions +c$$$ external ran_number +c$$$ double precision ran_number +c$$$ +c$$$c Input arguments +c$$$ integer i_in,j_in +c$$$ +c$$$c Local variables +c$$$ double precision energy_sc(0:n_ene),etot +c$$$ double precision org_dc(3),org_dc_norm(3),org_c(3) +c$$$ double precision ang_pert,rand_fact,exp_fact,beta +c$$$ integer n,i_pert,i +c$$$ logical notdone +c$$$ +c$$$ +c$$$ beta=1.0D0 +c$$$ +c$$$ mask_r=.true. +c$$$ do i=nnt,nct +c$$$ mask_side(i)=0 +c$$$ enddo +c$$$ mask_side(i_in)=1 +c$$$ mask_side(j_in)=1 +c$$$ +c$$$ call etotal_sc(energy_sc) +c$$$ etot=energy_sc(0) +c$$$c write(iout,'(a,3d15.5)')" SS_MC_START ",energy_sc(0), +c$$$c + energy_sc(1),energy_sc(12) +c$$$ +c$$$ notdone=.true. +c$$$ n=0 +c$$$ do while (notdone) +c$$$ if (mod(n,2).eq.0) then +c$$$ i_pert=i_in +c$$$ else +c$$$ i_pert=j_in +c$$$ endif +c$$$ n=n+1 +c$$$ +c$$$ do i=1,3 +c$$$ org_dc(i)=dc(i,i_pert+nres) +c$$$ org_dc_norm(i)=dc_norm(i,i_pert+nres) +c$$$ org_c(i)=c(i,i_pert+nres) +c$$$ enddo +c$$$ ang_pert=ran_number(0.0D0,3.0D0) +c$$$ call perturb_side_chain(i_pert,ang_pert) +c$$$ call etotal_sc(energy_sc) +c$$$ exp_fact=exp(beta*(etot-energy_sc(0))) +c$$$ rand_fact=ran_number(0.0D0,1.0D0) +c$$$ if (rand_fact.lt.exp_fact) then +c$$$c write(iout,'(a,3d15.5)')" SS_MC_ACCEPT ",energy_sc(0), +c$$$c + energy_sc(1),energy_sc(12) +c$$$ etot=energy_sc(0) +c$$$ else +c$$$c write(iout,'(a,3d15.5)')" SS_MC_REJECT ",energy_sc(0), +c$$$c + energy_sc(1),energy_sc(12) +c$$$ do i=1,3 +c$$$ dc(i,i_pert+nres)=org_dc(i) +c$$$ dc_norm(i,i_pert+nres)=org_dc_norm(i) +c$$$ c(i,i_pert+nres)=org_c(i) +c$$$ enddo +c$$$ endif +c$$$ +c$$$ if (n.eq.10000.or.etot.lt.30.0D0) notdone=.false. +c$$$ enddo +c$$$ +c$$$ mask_r=.false. +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$c---------------------------------------------------------------------------- +c$$$ +c$$$ subroutine ss_relax2(etot,iretcode,nfun,i_in,j_in) +c$$$ implicit none +c$$$ include 'DIMENSIONS' +c$$$ integer liv,lv +c$$$ parameter (liv=60,lv=(77+maxres6*(maxres6+17)/2)) +c$$$********************************************************************* +c$$$* OPTIMIZE sets up SUMSL or DFP and provides a simple interface for * +c$$$* the calling subprogram. * +c$$$* when d(i)=1.0, then v(35) is the length of the initial step, * +c$$$* calculated in the usual pythagorean way. * +c$$$* absolute convergence occurs when the function is within v(31) of * +c$$$* zero. unless you know the minimum value in advance, abs convg * +c$$$* is probably not useful. * +c$$$* relative convergence is when the model predicts that the function * +c$$$* will decrease by less than v(32)*abs(fun). * +c$$$********************************************************************* +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.GEO' +c$$$ include 'COMMON.MINIM' +c$$$ include 'COMMON.CHAIN' +c$$$ +c$$$ double precision orig_ss_dc,orig_ss_var,orig_ss_dist +c$$$ common /orig_ss/ orig_ss_dc(3,0:maxres2),orig_ss_var(maxvar), +c$$$ + orig_ss_dist(maxres2,maxres2) +c$$$ +c$$$ double precision etot +c$$$ integer iretcode,nfun,i_in,j_in +c$$$ +c$$$ external dist +c$$$ double precision dist +c$$$ external ss_func,fdum +c$$$ double precision ss_func,fdum +c$$$ +c$$$ integer iv(liv),uiparm(2) +c$$$ double precision v(lv),x(maxres6),d(maxres6),rdum +c$$$ integer i,j,k +c$$$ +c$$$ +c$$$ call deflt(2,iv,liv,lv,v) +c$$$* 12 means fresh start, dont call deflt +c$$$ iv(1)=12 +c$$$* max num of fun calls +c$$$ if (maxfun.eq.0) maxfun=500 +c$$$ iv(17)=maxfun +c$$$* max num of iterations +c$$$ if (maxmin.eq.0) maxmin=1000 +c$$$ iv(18)=maxmin +c$$$* controls output +c$$$ iv(19)=2 +c$$$* selects output unit +c$$$c iv(21)=iout +c$$$ iv(21)=0 +c$$$* 1 means to print out result +c$$$ iv(22)=0 +c$$$* 1 means to print out summary stats +c$$$ iv(23)=0 +c$$$* 1 means to print initial x and d +c$$$ iv(24)=0 +c$$$* min val for v(radfac) default is 0.1 +c$$$ v(24)=0.1D0 +c$$$* max val for v(radfac) default is 4.0 +c$$$ v(25)=2.0D0 +c$$$c v(25)=4.0D0 +c$$$* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) +c$$$* the sumsl default is 0.1 +c$$$ v(26)=0.1D0 +c$$$* false conv if (act fnctn decrease) .lt. v(34) +c$$$* the sumsl default is 100*machep +c$$$ v(34)=v(34)/100.0D0 +c$$$* absolute convergence +c$$$ if (tolf.eq.0.0D0) tolf=1.0D-4 +c$$$ v(31)=tolf +c$$$ v(31)=1.0D-1 +c$$$* relative convergence +c$$$ if (rtolf.eq.0.0D0) rtolf=1.0D-4 +c$$$ v(32)=rtolf +c$$$ v(32)=1.0D-1 +c$$$* controls initial step size +c$$$ v(35)=1.0D-1 +c$$$* large vals of d correspond to small components of step +c$$$ do i=1,6*nres +c$$$ d(i)=1.0D0 +c$$$ enddo +c$$$ +c$$$ do i=0,2*nres +c$$$ do j=1,3 +c$$$ orig_ss_dc(j,i)=dc(j,i) +c$$$ enddo +c$$$ enddo +c$$$ call geom_to_var(nvar,orig_ss_var) +c$$$ +c$$$ do i=1,nres +c$$$ do j=i,nres +c$$$ orig_ss_dist(j,i)=dist(j,i) +c$$$ orig_ss_dist(j+nres,i)=dist(j+nres,i) +c$$$ orig_ss_dist(j,i+nres)=dist(j,i+nres) +c$$$ orig_ss_dist(j+nres,i+nres)=dist(j+nres,i+nres) +c$$$ enddo +c$$$ enddo +c$$$ +c$$$ k=0 +c$$$ do i=1,nres-1 +c$$$ do j=1,3 +c$$$ k=k+1 +c$$$ x(k)=dc(j,i) +c$$$ enddo +c$$$ enddo +c$$$ do i=2,nres-1 +c$$$ if (ialph(i,1).gt.0) then +c$$$ do j=1,3 +c$$$ k=k+1 +c$$$ x(k)=dc(j,i+nres) +c$$$ enddo +c$$$ endif +c$$$ enddo +c$$$ +c$$$ uiparm(1)=i_in +c$$$ uiparm(2)=j_in +c$$$ call smsno(k,d,x,ss_func,iv,liv,lv,v,uiparm,rdum,fdum) +c$$$ etot=v(10) +c$$$ iretcode=iv(1) +c$$$ nfun=iv(6)+iv(30) +c$$$ +c$$$ k=0 +c$$$ do i=1,nres-1 +c$$$ do j=1,3 +c$$$ k=k+1 +c$$$ dc(j,i)=x(k) +c$$$ enddo +c$$$ enddo +c$$$ do i=2,nres-1 +c$$$ if (ialph(i,1).gt.0) then +c$$$ do j=1,3 +c$$$ k=k+1 +c$$$ dc(j,i+nres)=x(k) +c$$$ enddo +c$$$ endif +c$$$ enddo +c$$$ call chainbuild_cart +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$C----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine ss_func(n,x,nf,f,uiparm,urparm,ufparm) +c$$$ implicit none +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.INTERACT' +c$$$ include 'COMMON.SBRIDGE' +c$$$ +c$$$ double precision orig_ss_dc,orig_ss_var,orig_ss_dist +c$$$ common /orig_ss/ orig_ss_dc(3,0:maxres2),orig_ss_var(maxvar), +c$$$ + orig_ss_dist(maxres2,maxres2) +c$$$ +c$$$ integer n +c$$$ double precision x(maxres6) +c$$$ integer nf +c$$$ double precision f +c$$$ integer uiparm(2) +c$$$ real*8 urparm(1) +c$$$ external ufparm +c$$$ double precision ufparm +c$$$ +c$$$ external dist +c$$$ double precision dist +c$$$ +c$$$ integer i,j,k,ss_i,ss_j +c$$$ double precision tempf,var(maxvar) +c$$$ +c$$$ +c$$$ ss_i=uiparm(1) +c$$$ ss_j=uiparm(2) +c$$$ f=0.0D0 +c$$$ +c$$$ k=0 +c$$$ do i=1,nres-1 +c$$$ do j=1,3 +c$$$ k=k+1 +c$$$ dc(j,i)=x(k) +c$$$ enddo +c$$$ enddo +c$$$ do i=2,nres-1 +c$$$ if (ialph(i,1).gt.0) then +c$$$ do j=1,3 +c$$$ k=k+1 +c$$$ dc(j,i+nres)=x(k) +c$$$ enddo +c$$$ endif +c$$$ enddo +c$$$ call chainbuild_cart +c$$$ +c$$$ call geom_to_var(nvar,var) +c$$$ +c$$$c Constraints on all angles +c$$$ do i=1,nvar +c$$$ tempf=var(i)-orig_ss_var(i) +c$$$ f=f+tempf*tempf +c$$$ enddo +c$$$ +c$$$c Constraints on all distances +c$$$ do i=1,nres-1 +c$$$ if (i.gt.1) then +c$$$ tempf=dist(i+nres,i)-orig_ss_dist(i+nres,i) +c$$$ f=f+tempf*tempf +c$$$ endif +c$$$ do j=i+1,nres +c$$$ tempf=dist(j,i)-orig_ss_dist(j,i) +c$$$ if (tempf.lt.0.0D0 .or. j.eq.i+1) f=f+tempf*tempf +c$$$ tempf=dist(j+nres,i)-orig_ss_dist(j+nres,i) +c$$$ if (tempf.lt.0.0D0) f=f+tempf*tempf +c$$$ tempf=dist(j,i+nres)-orig_ss_dist(j,i+nres) +c$$$ if (tempf.lt.0.0D0) f=f+tempf*tempf +c$$$ tempf=dist(j+nres,i+nres)-orig_ss_dist(j+nres,i+nres) +c$$$ if (tempf.lt.0.0D0) f=f+tempf*tempf +c$$$ enddo +c$$$ enddo +c$$$ +c$$$c Constraints for the relevant CYS-CYS +c$$$ tempf=dist(nres+ss_i,nres+ss_j)-8.0D0 +c$$$ f=f+tempf*tempf +c$$$CCCCCCCCCCCCCCCCC ADD SOME ANGULAR STUFF +c$$$ +c$$$c$$$ if (nf.ne.nfl) then +c$$$c$$$ write(iout,'(a,i10,2d15.5)')"IN DIST_FUNC (NF,F,DIST)",nf, +c$$$c$$$ + f,dist(5+nres,14+nres) +c$$$c$$$ endif +c$$$ +c$$$ nfl=nf +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$C----------------------------------------------------------------------------- diff --git a/source/unres/src_MD-DFA-restraints/stochfric.F b/source/unres/src_MD-DFA-restraints/stochfric.F new file mode 100644 index 0000000..74eda61 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/stochfric.F @@ -0,0 +1,626 @@ + subroutine friction_force + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.MD' +#ifndef LANG0 + include 'COMMON.LANGEVIN' +#else + include 'COMMON.LANGEVIN.lang0' +#endif + include 'COMMON.IOUNITS' + double precision gamvec(MAXRES6) + common /syfek/ gamvec + double precision vv(3),vvtot(3,maxres),v_work(MAXRES6), + & ginvfric(maxres2,maxres2) + common /przechowalnia/ ginvfric + + logical lprn /.false./, checkmode /.false./ + + do i=0,MAXRES2 + do j=1,3 + friction(j,i)=0.0d0 + enddo + enddo + + do j=1,3 + d_t_work(j)=d_t(j,0) + enddo + ind=3 + do i=nnt,nct-1 + do j=1,3 + d_t_work(ind+j)=d_t(j,i) + enddo + ind=ind+3 + enddo + do i=nnt,nct + if (itype(i).ne.10) then + do j=1,3 + d_t_work(ind+j)=d_t(j,i+nres) + enddo + ind=ind+3 + endif + enddo + + call fricmat_mult(d_t_work,fric_work) + + if (.not.checkmode) return + + if (lprn) then + write (iout,*) "d_t_work and fric_work" + do i=1,3*dimen + write (iout,'(i3,2e15.5)') i,d_t_work(i),fric_work(i) + enddo + endif + do j=1,3 + friction(j,0)=fric_work(j) + enddo + ind=3 + do i=nnt,nct-1 + do j=1,3 + friction(j,i)=fric_work(ind+j) + enddo + ind=ind+3 + enddo + do i=nnt,nct + if (itype(i).ne.10) then + do j=1,3 + friction(j,i+nres)=fric_work(ind+j) + enddo + ind=ind+3 + endif + enddo + if (lprn) then + write(iout,*) "Friction backbone" + do i=0,nct-1 + write(iout,'(i5,3e15.5,5x,3e15.5)') + & i,(friction(j,i),j=1,3),(d_t(j,i),j=1,3) + enddo + write(iout,*) "Friction side chain" + do i=nnt,nct + write(iout,'(i5,3e15.5,5x,3e15.5)') + & i,(friction(j,i+nres),j=1,3),(d_t(j,i+nres),j=1,3) + enddo + endif + if (lprn) then + do j=1,3 + vv(j)=d_t(j,0) + enddo + do i=nnt,nct + do j=1,3 + vvtot(j,i)=vv(j)+0.5d0*d_t(j,i) + vvtot(j,i+nres)=vv(j)+d_t(j,i+nres) + vv(j)=vv(j)+d_t(j,i) + enddo + enddo + write (iout,*) "vvtot backbone and sidechain" + do i=nnt,nct + write (iout,'(i5,3e15.5,5x,3e15.5)') i,(vvtot(j,i),j=1,3), + & (vvtot(j,i+nres),j=1,3) + enddo + ind=0 + do i=nnt,nct-1 + do j=1,3 + v_work(ind+j)=vvtot(j,i) + enddo + ind=ind+3 + enddo + do i=nnt,nct + do j=1,3 + v_work(ind+j)=vvtot(j,i+nres) + enddo + ind=ind+3 + enddo + write (iout,*) "v_work gamvec and site-based friction forces" + do i=1,dimen1 + write (iout,'(i5,3e15.5)') i,v_work(i),gamvec(i), + & gamvec(i)*v_work(i) + enddo +c do i=1,dimen +c fric_work1(i)=0.0d0 +c do j=1,dimen1 +c fric_work1(i)=fric_work1(i)-A(j,i)*gamvec(j)*v_work(j) +c enddo +c enddo +c write (iout,*) "fric_work and fric_work1" +c do i=1,dimen +c write (iout,'(i5,2e15.5)') i,fric_work(i),fric_work1(i) +c enddo + do i=1,dimen + do j=1,dimen + ginvfric(i,j)=0.0d0 + do k=1,dimen + ginvfric(i,j)=ginvfric(i,j)+ginv(i,k)*fricmat(k,j) + enddo + enddo + enddo + write (iout,*) "ginvfric" + do i=1,dimen + write (iout,'(i5,100f8.3)') i,(ginvfric(i,j),j=1,dimen) + enddo + write (iout,*) "symmetry check" + do i=1,dimen + do j=1,i-1 + write (iout,*) i,j,ginvfric(i,j)-ginvfric(j,i) + enddo + enddo + endif + return + end +c----------------------------------------------------- + subroutine stochastic_force(stochforcvec) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.MD' + include 'COMMON.TIME1' +#ifndef LANG0 + include 'COMMON.LANGEVIN' +#else + include 'COMMON.LANGEVIN.lang0' +#endif + include 'COMMON.IOUNITS' + + double precision x,sig,lowb,highb, + & ff(3),force(3,0:MAXRES2),zeta2,lowb2, + & highb2,sig2,forcvec(MAXRES6),stochforcvec(MAXRES6) + logical lprn /.false./ + do i=0,MAXRES2 + do j=1,3 + stochforc(j,i)=0.0d0 + enddo + enddo + x=0.0d0 + +#ifdef MPI + time00=MPI_Wtime() +#else + time00=tcpu() +#endif +c Compute the stochastic forces acting on bodies. Store in force. + do i=nnt,nct-1 + sig=stdforcp(i) + lowb=-5*sig + highb=5*sig + do j=1,3 + force(j,i)=anorm_distr(x,sig,lowb,highb) + enddo + enddo + do i=nnt,nct + sig2=stdforcsc(i) + lowb2=-5*sig2 + highb2=5*sig2 + do j=1,3 + force(j,i+nres)=anorm_distr(x,sig2,lowb2,highb2) + enddo + enddo +#ifdef MPI + time_fsample=time_fsample+MPI_Wtime()-time00 +#else + time_fsample=time_fsample+tcpu()-time00 +#endif +c Compute the stochastic forces acting on virtual-bond vectors. + do j=1,3 + ff(j)=0.0d0 + enddo + do i=nct-1,nnt,-1 + do j=1,3 + stochforc(j,i)=ff(j)+0.5d0*force(j,i) + enddo + do j=1,3 + ff(j)=ff(j)+force(j,i) + enddo + if (itype(i+1).ne.21) then + do j=1,3 + stochforc(j,i)=stochforc(j,i)+force(j,i+nres+1) + ff(j)=ff(j)+force(j,i+nres+1) + enddo + endif + enddo + do j=1,3 + stochforc(j,0)=ff(j)+force(j,nnt+nres) + enddo + do i=nnt,nct + if (itype(i).ne.10) then + do j=1,3 + stochforc(j,i+nres)=force(j,i+nres) + enddo + endif + enddo + + do j=1,3 + stochforcvec(j)=stochforc(j,0) + enddo + ind=3 + do i=nnt,nct-1 + do j=1,3 + stochforcvec(ind+j)=stochforc(j,i) + enddo + ind=ind+3 + enddo + do i=nnt,nct + if (itype(i).ne.10) then + do j=1,3 + stochforcvec(ind+j)=stochforc(j,i+nres) + enddo + ind=ind+3 + endif + enddo + if (lprn) then + write (iout,*) "stochforcvec" + do i=1,3*dimen + write(iout,'(i5,e15.5)') i,stochforcvec(i) + enddo + write(iout,*) "Stochastic forces backbone" + do i=0,nct-1 + write(iout,'(i5,3e15.5)') i,(stochforc(j,i),j=1,3) + enddo + write(iout,*) "Stochastic forces side chain" + do i=nnt,nct + write(iout,'(i5,3e15.5)') + & i,(stochforc(j,i+nres),j=1,3) + enddo + endif + + if (lprn) then + + ind=0 + do i=nnt,nct-1 + write (iout,*) i,ind + do j=1,3 + forcvec(ind+j)=force(j,i) + enddo + ind=ind+3 + enddo + do i=nnt,nct + write (iout,*) i,ind + do j=1,3 + forcvec(j+ind)=force(j,i+nres) + enddo + ind=ind+3 + enddo + + write (iout,*) "forcvec" + ind=0 + do i=nnt,nct-1 + do j=1,3 + write (iout,'(2i3,2f10.5)') i,j,force(j,i), + & forcvec(ind+j) + enddo + ind=ind+3 + enddo + do i=nnt,nct + do j=1,3 + write (iout,'(2i3,2f10.5)') i,j,force(j,i+nres), + & forcvec(ind+j) + enddo + ind=ind+3 + enddo + + endif + + return + end +c------------------------------------------------------------------ + subroutine setup_fricmat + implicit real*8 (a-h,o-z) +#ifdef MPI + include 'mpif.h' +#endif + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.MD' + include 'COMMON.SETUP' + include 'COMMON.TIME1' +c integer licznik /0/ +c save licznik +#ifndef LANG0 + include 'COMMON.LANGEVIN' +#else + include 'COMMON.LANGEVIN.lang0' +#endif + include 'COMMON.IOUNITS' + integer IERROR + integer i,j,ind,ind1,m + logical lprn /.false./ + double precision dtdi,gamvec(MAXRES2), + & ginvfric(maxres2,maxres2),Ghalf(mmaxres2),fcopy(maxres2,maxres2) + common /syfek/ gamvec + double precision work(8*maxres2) + integer iwork(maxres2) + common /przechowalnia/ ginvfric,Ghalf,fcopy +#ifdef MPI + if (fg_rank.ne.king) goto 10 +#endif +c Zeroing out fricmat + do i=1,dimen + do j=1,dimen + fricmat(i,j)=0.0d0 + enddo + enddo +c Load the friction coefficients corresponding to peptide groups + ind1=0 + do i=nnt,nct-1 + ind1=ind1+1 + gamvec(ind1)=gamp + enddo +c Load the friction coefficients corresponding to side chains + m=nct-nnt + ind=0 + do i=nnt,nct + ind=ind+1 + ii = ind+m + iti=itype(i) + gamvec(ii)=gamsc(iti) + enddo + if (surfarea) call sdarea(gamvec) +c if (lprn) then +c write (iout,*) "Matrix A and vector gamma" +c do i=1,dimen1 +c write (iout,'(i2,$)') i +c do j=1,dimen +c write (iout,'(f4.1,$)') A(i,j) +c enddo +c write (iout,'(f8.3)') gamvec(i) +c enddo +c endif + if (lprn) then + write (iout,*) "Vector gamvec" + do i=1,dimen1 + write (iout,'(i5,f10.5)') i, gamvec(i) + enddo + endif + +c The friction matrix + do k=1,dimen + do i=1,dimen + dtdi=0.0d0 + do j=1,dimen1 + dtdi=dtdi+A(j,k)*A(j,i)*gamvec(j) + enddo + fricmat(k,i)=dtdi + enddo + enddo + + if (lprn) then + write (iout,'(//a)') "Matrix fricmat" + call matout2(dimen,dimen,maxres2,maxres2,fricmat) + endif + if (lang.eq.2 .or. lang.eq.3) then +c Mass-scale the friction matrix if non-direct integration will be performed + do i=1,dimen + do j=1,dimen + Ginvfric(i,j)=0.0d0 + do k=1,dimen + do l=1,dimen + Ginvfric(i,j)=Ginvfric(i,j)+ + & Gsqrm(i,k)*Gsqrm(l,j)*fricmat(k,l) + enddo + enddo + enddo + enddo +c Diagonalize the friction matrix + ind=0 + do i=1,dimen + do j=1,i + ind=ind+1 + Ghalf(ind)=Ginvfric(i,j) + enddo + enddo + call gldiag(maxres2,dimen,dimen,Ghalf,work,fricgam,fricvec, + & ierr,iwork) + if (lprn) then + write (iout,'(//2a)') "Eigenvectors and eigenvalues of the", + & " mass-scaled friction matrix" + call eigout(dimen,dimen,maxres2,maxres2,fricvec,fricgam) + endif +c Precompute matrices for tinker stochastic integrator +#ifndef LANG0 + do i=1,dimen + do j=1,dimen + mt1(i,j)=0.0d0 + mt2(i,j)=0.0d0 + do k=1,dimen + mt1(i,j)=mt1(i,j)+fricvec(k,i)*gsqrm(k,j) + mt2(i,j)=mt2(i,j)+fricvec(k,i)*gsqrp(k,j) + enddo + mt3(j,i)=mt1(i,j) + enddo + enddo +#endif + else if (lang.eq.4) then +c Diagonalize the friction matrix + ind=0 + do i=1,dimen + do j=1,i + ind=ind+1 + Ghalf(ind)=fricmat(i,j) + enddo + enddo + call gldiag(maxres2,dimen,dimen,Ghalf,work,fricgam,fricvec, + & ierr,iwork) + if (lprn) then + write (iout,'(//2a)') "Eigenvectors and eigenvalues of the", + & " friction matrix" + call eigout(dimen,dimen,maxres2,maxres2,fricvec,fricgam) + endif +c Determine the number of zero eigenvalues of the friction matrix + nzero=max0(dimen-dimen1,0) +c do while (fricgam(nzero+1).le.1.0d-5 .and. nzero.lt.dimen) +c nzero=nzero+1 +c enddo + write (iout,*) "Number of zero eigenvalues:",nzero + do i=1,dimen + do j=1,dimen + fricmat(i,j)=0.0d0 + do k=nzero+1,dimen + fricmat(i,j)=fricmat(i,j) + & +fricvec(i,k)*fricvec(j,k)/fricgam(k) + enddo + enddo + enddo + if (lprn) then + write (iout,'(//a)') "Generalized inverse of fricmat" + call matout(dimen,dimen,maxres6,maxres6,fricmat) + endif + endif +#ifdef MPI + 10 continue + if (nfgtasks.gt.1) then + if (fg_rank.eq.0) then +c The matching BROADCAST for fg processors is called in ERGASTULUM +#ifdef MPI + time00=MPI_Wtime() +#else + time00=tcpu() +#endif + call MPI_Bcast(10,1,MPI_INTEGER,king,FG_COMM,IERROR) +#ifdef MPI + time_Bcast=time_Bcast+MPI_Wtime()-time00 +#else + time_Bcast=time_Bcast+tcpu()-time00 +#endif +c print *,"Processor",myrank, +c & " BROADCAST iorder in SETUP_FRICMAT" + endif +c licznik=licznik+1 +c write (iout,*) "setup_fricmat licznik",licznik +#ifdef MPI + time00=MPI_Wtime() +#else + time00=tcpu() +#endif +c Scatter the friction matrix + call MPI_Scatterv(fricmat(1,1),nginv_counts(0), + & nginv_start(0),MPI_DOUBLE_PRECISION,fcopy(1,1), + & myginv_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) +#ifdef TIMING +#ifdef MPI + time_scatter=time_scatter+MPI_Wtime()-time00 + time_scatter_fmat=time_scatter_fmat+MPI_Wtime()-time00 +#else + time_scatter=time_scatter+tcpu()-time00 + time_scatter_fmat=time_scatter_fmat+tcpu()-time00 +#endif +#endif + do i=1,dimen + do j=1,2*my_ng_count + fricmat(j,i)=fcopy(i,j) + enddo + enddo +c write (iout,*) "My chunk of fricmat" +c call MATOUT2(my_ng_count,dimen,maxres2,maxres2,fcopy) + endif +#endif + return + end +c------------------------------------------------------------------------------- + subroutine sdarea(gamvec) +c +c Scale the friction coefficients according to solvent accessible surface areas +c Code adapted from TINKER +c AL 9/3/04 +c + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' +#ifndef LANG0 + include 'COMMON.LANGEVIN' +#else + include 'COMMON.LANGEVIN.lang0' +#endif + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + double precision radius(maxres2),gamvec(maxres2) + parameter (twosix=1.122462048309372981d0) + logical lprn /.false./ +c +c determine new friction coefficients every few SD steps +c +c set the atomic radii to estimates of sigma values +c +c print *,"Entered sdarea" + probe = 0.0d0 + + do i=1,2*nres + radius(i)=0.0d0 + enddo +c Load peptide group radii + do i=nnt,nct-1 + radius(i)=pstok + enddo +c Load side chain radii + do i=nnt,nct + iti=itype(i) + radius(i+nres)=restok(iti) + enddo +c do i=1,2*nres +c write (iout,*) "i",i," radius",radius(i) +c enddo + do i = 1, 2*nres + radius(i) = radius(i) / twosix + if (radius(i) .ne. 0.0d0) radius(i) = radius(i) + probe + end do +c +c scale atomic friction coefficients by accessible area +c + if (lprn) write (iout,*) + & "Original gammas, surface areas, scaling factors, new gammas, ", + & "std's of stochastic forces" + ind=0 + do i=nnt,nct-1 + if (radius(i).gt.0.0d0) then + call surfatom (i,area,radius) + ratio = dmax1(area/(4.0d0*pi*radius(i)**2),1.0d-1) + if (lprn) write (iout,'(i5,3f10.5,$)') + & i,gamvec(ind+1),area,ratio + do j=1,3 + ind=ind+1 + gamvec(ind) = ratio * gamvec(ind) + enddo + stdforcp(i)=stdfp*dsqrt(gamvec(ind)) + if (lprn) write (iout,'(2f10.5)') gamvec(ind),stdforcp(i) + endif + enddo + do i=nnt,nct + if (radius(i+nres).gt.0.0d0) then + call surfatom (i+nres,area,radius) + ratio = dmax1(area/(4.0d0*pi*radius(i+nres)**2),1.0d-1) + if (lprn) write (iout,'(i5,3f10.5,$)') + & i,gamvec(ind+1),area,ratio + do j=1,3 + ind=ind+1 + gamvec(ind) = ratio * gamvec(ind) + enddo + stdforcsc(i)=stdfsc(itype(i))*dsqrt(gamvec(ind)) + if (lprn) write (iout,'(2f10.5)') gamvec(ind),stdforcsc(i) + endif + enddo + + return + end diff --git a/source/unres/src_MD-DFA-restraints/sumsld.f b/source/unres/src_MD-DFA-restraints/sumsld.f new file mode 100644 index 0000000..1ce7b78 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/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_MD-DFA-restraints/surfatom.f b/source/unres/src_MD-DFA-restraints/surfatom.f new file mode 100644 index 0000000..9974842 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/surfatom.f @@ -0,0 +1,494 @@ +c +c +c ################################################### +c ## COPYRIGHT (C) 1996 by Jay William Ponder ## +c ## All Rights Reserved ## +c ################################################### +c +c ################################################################ +c ## ## +c ## subroutine surfatom -- exposed surface area of an atom ## +c ## ## +c ################################################################ +c +c +c "surfatom" performs an analytical computation of the surface +c area of a specified atom; a simplified version of "surface" +c +c literature references: +c +c T. J. Richmond, "Solvent Accessible Surface Area and +c Excluded Volume in Proteins", Journal of Molecular Biology, +c 178, 63-89 (1984) +c +c L. Wesson and D. Eisenberg, "Atomic Solvation Parameters +c Applied to Molecular Dynamics of Proteins in Solution", +c Protein Science, 1, 227-235 (1992) +c +c variables and parameters: +c +c ir number of atom for which area is desired +c area accessible surface area of the atom +c radius radii of each of the individual atoms +c +c + subroutine surfatom (ir,area,radius) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'sizes.i' + include 'COMMON.GEO' + include 'COMMON.IOUNITS' + integer nres,nsup,nstart_sup + double precision c,dc,dc_old,d_c_work,xloc,xrot,dc_norm + common /chain/ c(3,maxres2+2),dc(3,0:maxres2),dc_old(3,0:maxres2), + & xloc(3,maxres),xrot(3,maxres),dc_norm(3,0:maxres2), + & dc_work(MAXRES6),nres,nres0 + integer maxarc + parameter (maxarc=300) + integer i,j,k,m + integer ii,ib,jb + integer io,ir + integer mi,ni,narc + integer key(maxarc) + integer intag(maxarc) + integer intag1(maxarc) + real*8 area,arcsum + real*8 arclen,exang + real*8 delta,delta2 + real*8 eps,rmove + real*8 xr,yr,zr + real*8 rr,rrsq + real*8 rplus,rminus + real*8 axx,axy,axz + real*8 ayx,ayy + real*8 azx,azy,azz + real*8 uxj,uyj,uzj + real*8 tx,ty,tz + real*8 txb,tyb,td + real*8 tr2,tr,txr,tyr + real*8 tk1,tk2 + real*8 thec,the,t,tb + real*8 txk,tyk,tzk + real*8 t1,ti,tf,tt + real*8 txj,tyj,tzj + real*8 ccsq,cc,xysq + real*8 bsqk,bk,cosine + real*8 dsqj,gi,pix2 + real*8 therk,dk,gk + real*8 risqk,rik + real*8 radius(maxatm) + real*8 ri(maxarc),risq(maxarc) + real*8 ux(maxarc),uy(maxarc),uz(maxarc) + real*8 xc(maxarc),yc(maxarc),zc(maxarc) + real*8 xc1(maxarc),yc1(maxarc),zc1(maxarc) + real*8 dsq(maxarc),bsq(maxarc) + real*8 dsq1(maxarc),bsq1(maxarc) + real*8 arci(maxarc),arcf(maxarc) + real*8 ex(maxarc),lt(maxarc),gr(maxarc) + real*8 b(maxarc),b1(maxarc),bg(maxarc) + real*8 kent(maxarc),kout(maxarc) + real*8 ther(maxarc) + logical moved,top + logical omit(maxarc) +c +c +c zero out the surface area for the sphere of interest +c + area = 0.0d0 +c write (2,*) "ir",ir," radius",radius(ir) + if (radius(ir) .eq. 0.0d0) return +c +c set the overlap significance and connectivity shift +c + pix2 = 2.0d0 * pi + delta = 1.0d-8 + delta2 = delta * delta + eps = 1.0d-8 + moved = .false. + rmove = 1.0d-8 +c +c store coordinates and radius of the sphere of interest +c + xr = c(1,ir) + yr = c(2,ir) + zr = c(3,ir) + rr = radius(ir) + rrsq = rr * rr +c +c initialize values of some counters and summations +c + 10 continue + io = 0 + jb = 0 + ib = 0 + arclen = 0.0d0 + exang = 0.0d0 +c +c test each sphere to see if it overlaps the sphere of interest +c + do i = 1, 2*nres + if (i.eq.ir .or. radius(i).eq.0.0d0) goto 30 + rplus = rr + radius(i) + tx = c(1,i) - xr + if (abs(tx) .ge. rplus) goto 30 + ty = c(2,i) - yr + if (abs(ty) .ge. rplus) goto 30 + tz = c(3,i) - zr + if (abs(tz) .ge. rplus) goto 30 +c +c check for sphere overlap by testing distance against radii +c + xysq = tx*tx + ty*ty + if (xysq .lt. delta2) then + tx = delta + ty = 0.0d0 + xysq = delta2 + end if + ccsq = xysq + tz*tz + cc = sqrt(ccsq) + if (rplus-cc .le. delta) goto 30 + rminus = rr - radius(i) +c +c check to see if sphere of interest is completely buried +c + if (cc-abs(rminus) .le. delta) then + if (rminus .le. 0.0d0) goto 170 + goto 30 + end if +c +c check for too many overlaps with sphere of interest +c + if (io .ge. maxarc) then + write (iout,20) + 20 format (/,' SURFATOM -- Increase the Value of MAXARC') + stop + end if +c +c get overlap between current sphere and sphere of interest +c + io = io + 1 + xc1(io) = tx + yc1(io) = ty + zc1(io) = tz + dsq1(io) = xysq + bsq1(io) = ccsq + b1(io) = cc + gr(io) = (ccsq+rplus*rminus) / (2.0d0*rr*b1(io)) + intag1(io) = i + omit(io) = .false. + 30 continue + end do +c +c case where no other spheres overlap the sphere of interest +c + if (io .eq. 0) then + area = 4.0d0 * pi * rrsq + return + end if +c +c case where only one sphere overlaps the sphere of interest +c + if (io .eq. 1) then + area = pix2 * (1.0d0 + gr(1)) + area = mod(area,4.0d0*pi) * rrsq + return + end if +c +c case where many spheres intersect the sphere of interest; +c sort the intersecting spheres by their degree of overlap +c + call sort2 (io,gr,key) + do i = 1, io + k = key(i) + intag(i) = intag1(k) + xc(i) = xc1(k) + yc(i) = yc1(k) + zc(i) = zc1(k) + dsq(i) = dsq1(k) + b(i) = b1(k) + bsq(i) = bsq1(k) + end do +c +c get radius of each overlap circle on surface of the sphere +c + do i = 1, io + gi = gr(i) * rr + bg(i) = b(i) * gi + risq(i) = rrsq - gi*gi + ri(i) = sqrt(risq(i)) + ther(i) = 0.5d0*pi - asin(min(1.0d0,max(-1.0d0,gr(i)))) + end do +c +c find boundary of inaccessible area on sphere of interest +c + do k = 1, io-1 + if (.not. omit(k)) then + txk = xc(k) + tyk = yc(k) + tzk = zc(k) + bk = b(k) + therk = ther(k) +c +c check to see if J circle is intersecting K circle; +c get distance between circle centers and sum of radii +c + do j = k+1, io + if (omit(j)) goto 60 + cc = (txk*xc(j)+tyk*yc(j)+tzk*zc(j))/(bk*b(j)) + cc = acos(min(1.0d0,max(-1.0d0,cc))) + td = therk + ther(j) +c +c check to see if circles enclose separate regions +c + if (cc .ge. td) goto 60 +c +c check for circle J completely inside circle K +c + if (cc+ther(j) .lt. therk) goto 40 +c +c check for circles that are essentially parallel +c + if (cc .gt. delta) goto 50 + 40 continue + omit(j) = .true. + goto 60 +c +c check to see if sphere of interest is completely buried +c + 50 continue + if (pix2-cc .le. td) goto 170 + 60 continue + end do + end if + end do +c +c find T value of circle intersections +c + do k = 1, io + if (omit(k)) goto 110 + omit(k) = .true. + narc = 0 + top = .false. + txk = xc(k) + tyk = yc(k) + tzk = zc(k) + dk = sqrt(dsq(k)) + bsqk = bsq(k) + bk = b(k) + gk = gr(k) * rr + risqk = risq(k) + rik = ri(k) + therk = ther(k) +c +c rotation matrix elements +c + t1 = tzk / (bk*dk) + axx = txk * t1 + axy = tyk * t1 + axz = dk / bk + ayx = tyk / dk + ayy = txk / dk + azx = txk / bk + azy = tyk / bk + azz = tzk / bk + do j = 1, io + if (.not. omit(j)) then + txj = xc(j) + tyj = yc(j) + tzj = zc(j) +c +c rotate spheres so K vector colinear with z-axis +c + uxj = txj*axx + tyj*axy - tzj*axz + uyj = tyj*ayy - txj*ayx + uzj = txj*azx + tyj*azy + tzj*azz + cosine = min(1.0d0,max(-1.0d0,uzj/b(j))) + if (acos(cosine) .lt. therk+ther(j)) then + dsqj = uxj*uxj + uyj*uyj + tb = uzj*gk - bg(j) + txb = uxj * tb + tyb = uyj * tb + td = rik * dsqj + tr2 = risqk*dsqj - tb*tb + tr2 = max(eps,tr2) + tr = sqrt(tr2) + txr = uxj * tr + tyr = uyj * tr +c +c get T values of intersection for K circle +c + tb = (txb+tyr) / td + tb = min(1.0d0,max(-1.0d0,tb)) + tk1 = acos(tb) + if (tyb-txr .lt. 0.0d0) tk1 = pix2 - tk1 + tb = (txb-tyr) / td + tb = min(1.0d0,max(-1.0d0,tb)) + tk2 = acos(tb) + if (tyb+txr .lt. 0.0d0) tk2 = pix2 - tk2 + thec = (rrsq*uzj-gk*bg(j)) / (rik*ri(j)*b(j)) + if (abs(thec) .lt. 1.0d0) then + the = -acos(thec) + else if (thec .ge. 1.0d0) then + the = 0.0d0 + else if (thec .le. -1.0d0) then + the = -pi + end if +c +c see if "tk1" is entry or exit point; check t=0 point; +c "ti" is exit point, "tf" is entry point +c + cosine = min(1.0d0,max(-1.0d0, + & (uzj*gk-uxj*rik)/(b(j)*rr))) + if ((acos(cosine)-ther(j))*(tk2-tk1) .le. 0.0d0) then + ti = tk2 + tf = tk1 + else + ti = tk2 + tf = tk1 + end if + narc = narc + 1 + if (narc .ge. maxarc) then + write (iout,70) + 70 format (/,' SURFATOM -- Increase the Value', + & ' of MAXARC') + stop + end if + if (tf .le. ti) then + arcf(narc) = tf + arci(narc) = 0.0d0 + tf = pix2 + lt(narc) = j + ex(narc) = the + top = .true. + narc = narc + 1 + end if + arcf(narc) = tf + arci(narc) = ti + lt(narc) = j + ex(narc) = the + ux(j) = uxj + uy(j) = uyj + uz(j) = uzj + end if + end if + end do + omit(k) = .false. +c +c special case; K circle without intersections +c + if (narc .le. 0) goto 90 +c +c general case; sum up arclength and set connectivity code +c + call sort2 (narc,arci,key) + arcsum = arci(1) + mi = key(1) + t = arcf(mi) + ni = mi + if (narc .gt. 1) then + do j = 2, narc + m = key(j) + if (t .lt. arci(j)) then + arcsum = arcsum + arci(j) - t + exang = exang + ex(ni) + jb = jb + 1 + if (jb .ge. maxarc) then + write (iout,80) + 80 format (/,' SURFATOM -- Increase the Value', + & ' of MAXARC') + stop + end if + i = lt(ni) + kent(jb) = maxarc*i + k + i = lt(m) + kout(jb) = maxarc*k + i + end if + tt = arcf(m) + if (tt .ge. t) then + t = tt + ni = m + end if + end do + end if + arcsum = arcsum + pix2 - t + if (.not. top) then + exang = exang + ex(ni) + jb = jb + 1 + i = lt(ni) + kent(jb) = maxarc*i + k + i = lt(mi) + kout(jb) = maxarc*k + i + end if + goto 100 + 90 continue + arcsum = pix2 + ib = ib + 1 + 100 continue + arclen = arclen + gr(k)*arcsum + 110 continue + end do + if (arclen .eq. 0.0d0) goto 170 + if (jb .eq. 0) goto 150 +c +c find number of independent boundaries and check connectivity +c + j = 0 + do k = 1, jb + if (kout(k) .ne. 0) then + i = k + 120 continue + m = kout(i) + kout(i) = 0 + j = j + 1 + do ii = 1, jb + if (m .eq. kent(ii)) then + if (ii .eq. k) then + ib = ib + 1 + if (j .eq. jb) goto 150 + goto 130 + end if + i = ii + goto 120 + end if + end do + 130 continue + end if + end do + ib = ib + 1 +c +c attempt to fix connectivity error by moving atom slightly +c + if (moved) then + write (iout,140) ir + 140 format (/,' SURFATOM -- Connectivity Error at Atom',i6) + else + moved = .true. + xr = xr + rmove + yr = yr + rmove + zr = zr + rmove + goto 10 + end if +c +c compute the exposed surface area for the sphere of interest +c + 150 continue + area = ib*pix2 + exang + arclen + area = mod(area,4.0d0*pi) * rrsq +c +c attempt to fix negative area by moving atom slightly +c + if (area .lt. 0.0d0) then + if (moved) then + write (iout,160) ir + 160 format (/,' SURFATOM -- Negative Area at Atom',i6) + else + moved = .true. + xr = xr + rmove + yr = yr + rmove + zr = zr + rmove + goto 10 + end if + end if + 170 continue + return + end diff --git a/source/unres/src_MD-DFA-restraints/test.F b/source/unres/src_MD-DFA-restraints/test.F new file mode 100644 index 0000000..0140ee5 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/test.F @@ -0,0 +1,863 @@ + subroutine test + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.DISTFIT' + include 'COMMON.SBRIDGE' + include 'COMMON.CONTROL' + include 'COMMON.FFIELD' + include 'COMMON.MINIM' + include 'COMMON.CHAIN' + double precision time0,time1 + double precision energy(0:n_ene),ee + double precision var(maxvar),var1(maxvar) + integer j1,j2 + logical debug,accepted + debug=.true. + + + call geom_to_var(nvar,var1) + call chainbuild + call etotal(energy(0)) + etot=energy(0) + call rmsd(rms) + write(iout,*) 'etot=',0,etot,rms + call secondary2(.false.) + + call write_pdb(0,'first structure',etot) + + j1=13 + j2=21 + da=180.0*deg2rad + + + + temp=3000.0d0 + betbol=1.0D0/(1.9858D-3*temp) + jr=iran_num(j1,j2) + d=ran_number(-pi,pi) +c phi(jr)=pinorm(phi(jr)+d) + call chainbuild + call etotal(energy(0)) + etot0=energy(0) + call rmsd(rms) + write(iout,*) 'etot=',1,etot0,rms + call write_pdb(1,'perturb structure',etot0) + + do i=2,500,2 + jr=iran_num(j1,j2) + d=ran_number(-da,da) + phiold=phi(jr) + phi(jr)=pinorm(phi(jr)+d) + call chainbuild + call etotal(energy(0)) + etot=energy(0) + + if (etot.lt.etot0) then + accepted=.true. + else + accepted=.false. + xxr=ran_number(0.0D0,1.0D0) + xxh=betbol*(etot-etot0) + if (xxh.lt.50.0D0) then + xxh=dexp(-xxh) + if (xxh.gt.xxr) accepted=.true. + endif + endif + accepted=.true. +c print *,etot0,etot,accepted + if (accepted) then + etot0=etot + call rmsd(rms) + write(iout,*) 'etot=',i,etot,rms + call write_pdb(i,'MC structure',etot) +c minimize +c call geom_to_var(nvar,var1) + call sc_move(2,nres-1,1,10d0,nft_sc,etot) + call geom_to_var(nvar,var) + call minimize(etot,var,iretcode,nfun) + write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun + call var_to_geom(nvar,var) + call chainbuild + call rmsd(rms) + write(iout,*) 'etot mcm=',i,etot,rms + call write_pdb(i+1,'MCM structure',etot) + call var_to_geom(nvar,var1) +c -------- + else + phi(jr)=phiold + endif + enddo + +c minimize +c call sc_move(2,nres-1,1,10d0,nft_sc,etot) +c call geom_to_var(nvar,var) +c +c call chainbuild +c call write_pdb(998 ,'sc min',etot) +c +c call minimize(etot,var,iretcode,nfun) +c write(iout,*)'------------------------------------------------' +c write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun +c +c call var_to_geom(nvar,var) +c call chainbuild +c call write_pdb(999,'full min',etot) + + + return + end + + + + + subroutine test_local + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + double precision time0,time1 + double precision energy(0:n_ene),ee + double precision varia(maxvar) +c + call chainbuild +c call geom_to_var(nvar,varia) + call write_pdb(1,'first structure',0d0) + + call etotal(energy(0)) + etot=energy(0) + write(iout,*) nnt,nct,etot + + write(iout,*) 'calling sc_move' + call sc_move(nnt,nct,5,10d0,nft_sc,etot) + write(iout,*) nft_sc,etot + call write_pdb(2,'second structure',etot) + + write(iout,*) 'calling local_move' + call local_move_init(.false.) + call local_move(24,29,20d0,50d0) + call chainbuild + call write_pdb(3,'third structure',etot) + + write(iout,*) 'calling sc_move' + call sc_move(24,29,5,10d0,nft_sc,etot) + write(iout,*) nft_sc,etot + call write_pdb(2,'last structure',etot) + + + return + end + + subroutine test_sc + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + double precision time0,time1 + double precision energy(0:n_ene),ee + double precision varia(maxvar) +c + call chainbuild +c call geom_to_var(nvar,varia) + call write_pdb(1,'first structure',0d0) + + call etotal(energy(0)) + etot=energy(0) + write(iout,*) nnt,nct,etot + + write(iout,*) 'calling sc_move' + + call sc_move(nnt,nct,5,10d0,nft_sc,etot) + write(iout,*) nft_sc,etot + call write_pdb(2,'second structure',etot) + + write(iout,*) 'calling sc_move 2nd time' + + call sc_move(nnt,nct,5,1d0,nft_sc,etot) + write(iout,*) nft_sc,etot + call write_pdb(3,'last structure',etot) + return + end +c-------------------------------------------------------- + subroutine bgrow(bstrand,nbstrand,in,ind,new) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + integer bstrand(maxres/3,6) + + ishift=iabs(bstrand(in,ind+4)-new) + + print *,'bgrow',bstrand(in,ind+4),new,ishift + + bstrand(in,ind)=new + + if(ind.eq.1)then + bstrand(nbstrand,5)=bstrand(nbstrand,1) + do i=1,nbstrand-1 + IF (bstrand(nbstrand,3).eq.bstrand(i,3)) THEN + if (bstrand(i,5).lt.bstrand(i,6)) then + bstrand(i,5)=bstrand(i,5)-ishift + else + bstrand(i,5)=bstrand(i,5)+ishift + endif + ENDIF + enddo + else + bstrand(nbstrand,6)=bstrand(nbstrand,2) + do i=1,nbstrand-1 + IF (bstrand(nbstrand,3).eq.bstrand(i,3)) THEN + if (bstrand(i,6).lt.bstrand(i,5)) then + bstrand(i,6)=bstrand(i,6)-ishift + else + bstrand(i,6)=bstrand(i,6)+ishift + endif + ENDIF + enddo + endif + + + return + end + + +c------------------------------------------------- + + subroutine secondary(lprint) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.DISTFIT' + + integer ncont,icont(2,maxres*maxres/2),isec(maxres,3) + logical lprint,not_done + real dcont(maxres*maxres/2),d + real rcomp /7.0/ + real rbeta /5.2/ + real ralfa /5.2/ + real r310 /6.6/ + double precision xpi(3),xpj(3) + + + + call chainbuild +cd call write_pdb(99,'sec structure',0d0) + ncont=0 + nbfrag=0 + nhfrag=0 + do i=1,nres + isec(i,1)=0 + isec(i,2)=0 + isec(i,3)=0 + enddo + + do i=2,nres-3 + do k=1,3 + xpi(k)=0.5d0*(c(k,i-1)+c(k,i)) + enddo + do j=i+2,nres + do k=1,3 + xpj(k)=0.5d0*(c(k,j-1)+c(k,j)) + enddo +cd d = (c(1,i)-c(1,j))*(c(1,i)-c(1,j)) + +cd & (c(2,i)-c(2,j))*(c(2,i)-c(2,j)) + +cd & (c(3,i)-c(3,j))*(c(3,i)-c(3,j)) +cd print *,'CA',i,j,d + d = (xpi(1)-xpj(1))*(xpi(1)-xpj(1)) + + & (xpi(2)-xpj(2))*(xpi(2)-xpj(2)) + + & (xpi(3)-xpj(3))*(xpi(3)-xpj(3)) + if ( d.lt.rcomp*rcomp) then + ncont=ncont+1 + icont(1,ncont)=i + icont(2,ncont)=j + dcont(ncont)=sqrt(d) + endif + enddo + enddo + if (lprint) then + write (iout,*) + write (iout,'(a)') '#PP contact map distances:' + do i=1,ncont + write (iout,'(3i4,f10.5)') + & i,icont(1,i),icont(2,i),dcont(i) + enddo + endif + +c finding parallel beta +cd write (iout,*) '------- looking for parallel beta -----------' + nbeta=0 + nstrand=0 + do i=1,ncont + i1=icont(1,i) + j1=icont(2,i) + if(dcont(i).le.rbeta .and. j1-i1.gt.4 .and. + & isec(i1,1).le.1.and.isec(j1,1).le.1.and. + & (isec(i1,2).ne.isec(j1,2).or.isec(i1,2)*isec(j1,2).eq.0).and. + & (isec(i1,3).ne.isec(j1,3).or.isec(i1,3)*isec(j1,3).eq.0).and. + & (isec(i1,2).ne.isec(j1,3).or.isec(i1,2)*isec(j1,3).eq.0).and. + & (isec(i1,3).ne.isec(j1,2).or.isec(i1,3)*isec(j1,2).eq.0) + & ) then + ii1=i1 + jj1=j1 +cd write (iout,*) i1,j1,dcont(i) + not_done=.true. + do while (not_done) + i1=i1+1 + j1=j1+1 + do j=1,ncont + if (i1.eq.icont(1,j) .and. j1.eq.icont(2,j) + & .and. dcont(j).le.rbeta .and. + & isec(i1,1).le.1.and.isec(j1,1).le.1.and. + & (isec(i1,2).ne.isec(j1,2).or.isec(i1,2)*isec(j1,2).eq.0).and. + & (isec(i1,3).ne.isec(j1,3).or.isec(i1,3)*isec(j1,3).eq.0).and. + & (isec(i1,2).ne.isec(j1,3).or.isec(i1,2)*isec(j1,3).eq.0).and. + & (isec(i1,3).ne.isec(j1,2).or.isec(i1,3)*isec(j1,2).eq.0) + & ) goto 5 + enddo + not_done=.false. + 5 continue +cd write (iout,*) i1,j1,dcont(j),not_done + enddo + j1=j1-1 + i1=i1-1 + if (i1-ii1.gt.1) then + ii1=max0(ii1-1,1) + jj1=max0(jj1-1,1) + nbeta=nbeta+1 + if(lprint)write(iout,*)'parallel beta',nbeta,ii1,i1,jj1,j1 + + nbfrag=nbfrag+1 + bfrag(1,nbfrag)=ii1 + bfrag(2,nbfrag)=i1 + bfrag(3,nbfrag)=jj1 + bfrag(4,nbfrag)=j1 + + do ij=ii1,i1 + isec(ij,1)=isec(ij,1)+1 + isec(ij,1+isec(ij,1))=nbeta + enddo + do ij=jj1,j1 + isec(ij,1)=isec(ij,1)+1 + isec(ij,1+isec(ij,1))=nbeta + enddo + + if(lprint) then + nstrand=nstrand+1 + if (nbeta.le.9) then + write(12,'(a18,i1,a9,i3,a2,i3,a1)') + & "DefPropRes 'strand",nstrand, + & "' 'num = ",ii1-1,"..",i1-1,"'" + else + write(12,'(a18,i2,a9,i3,a2,i3,a1)') + & "DefPropRes 'strand",nstrand, + & "' 'num = ",ii1-1,"..",i1-1,"'" + endif + nstrand=nstrand+1 + if (nbeta.le.9) then + write(12,'(a18,i1,a9,i3,a2,i3,a1)') + & "DefPropRes 'strand",nstrand, + & "' 'num = ",jj1-1,"..",j1-1,"'" + else + write(12,'(a18,i2,a9,i3,a2,i3,a1)') + & "DefPropRes 'strand",nstrand, + & "' 'num = ",jj1-1,"..",j1-1,"'" + endif + write(12,'(a8,4i4)') + & "SetNeigh",ii1-1,i1-1,jj1-1,j1-1 + endif + endif + endif + enddo + +c finding antiparallel beta +cd write (iout,*) '--------- looking for antiparallel beta ---------' + + do i=1,ncont + i1=icont(1,i) + j1=icont(2,i) + if (dcont(i).le.rbeta.and. + & isec(i1,1).le.1.and.isec(j1,1).le.1.and. + & (isec(i1,2).ne.isec(j1,2).or.isec(i1,2)*isec(j1,2).eq.0).and. + & (isec(i1,3).ne.isec(j1,3).or.isec(i1,3)*isec(j1,3).eq.0).and. + & (isec(i1,2).ne.isec(j1,3).or.isec(i1,2)*isec(j1,3).eq.0).and. + & (isec(i1,3).ne.isec(j1,2).or.isec(i1,3)*isec(j1,2).eq.0) + & ) then + ii1=i1 + jj1=j1 +cd write (iout,*) i1,j1,dcont(i) + + not_done=.true. + do while (not_done) + i1=i1+1 + j1=j1-1 + do j=1,ncont + if (i1.eq.icont(1,j).and.j1.eq.icont(2,j) .and. + & isec(i1,1).le.1.and.isec(j1,1).le.1.and. + & (isec(i1,2).ne.isec(j1,2).or.isec(i1,2)*isec(j1,2).eq.0).and. + & (isec(i1,3).ne.isec(j1,3).or.isec(i1,3)*isec(j1,3).eq.0).and. + & (isec(i1,2).ne.isec(j1,3).or.isec(i1,2)*isec(j1,3).eq.0).and. + & (isec(i1,3).ne.isec(j1,2).or.isec(i1,3)*isec(j1,2).eq.0) + & .and. dcont(j).le.rbeta ) goto 6 + enddo + not_done=.false. + 6 continue +cd write (iout,*) i1,j1,dcont(j),not_done + enddo + i1=i1-1 + j1=j1+1 + if (i1-ii1.gt.1) then + if(lprint)write (iout,*)'antiparallel beta', + & nbeta,ii1-1,i1,jj1,j1-1 + + nbfrag=nbfrag+1 + bfrag(1,nbfrag)=max0(ii1-1,1) + bfrag(2,nbfrag)=i1 + bfrag(3,nbfrag)=jj1 + bfrag(4,nbfrag)=max0(j1-1,1) + + nbeta=nbeta+1 + iii1=max0(ii1-1,1) + do ij=iii1,i1 + isec(ij,1)=isec(ij,1)+1 + isec(ij,1+isec(ij,1))=nbeta + enddo + jjj1=max0(j1-1,1) + do ij=jjj1,jj1 + isec(ij,1)=isec(ij,1)+1 + isec(ij,1+isec(ij,1))=nbeta + enddo + + + if (lprint) then + nstrand=nstrand+1 + if (nstrand.le.9) then + write(12,'(a18,i1,a9,i3,a2,i3,a1)') + & "DefPropRes 'strand",nstrand, + & "' 'num = ",ii1-2,"..",i1-1,"'" + else + write(12,'(a18,i2,a9,i3,a2,i3,a1)') + & "DefPropRes 'strand",nstrand, + & "' 'num = ",ii1-2,"..",i1-1,"'" + endif + nstrand=nstrand+1 + if (nstrand.le.9) then + write(12,'(a18,i1,a9,i3,a2,i3,a1)') + & "DefPropRes 'strand",nstrand, + & "' 'num = ",j1-2,"..",jj1-1,"'" + else + write(12,'(a18,i2,a9,i3,a2,i3,a1)') + & "DefPropRes 'strand",nstrand, + & "' 'num = ",j1-2,"..",jj1-1,"'" + endif + write(12,'(a8,4i4)') + & "SetNeigh",ii1-2,i1-1,jj1-1,j1-2 + endif + endif + endif + enddo + + if (nstrand.gt.0.and.lprint) then + write(12,'(a27,$)') "DefPropRes 'sheet' 'strand1" + do i=2,nstrand + if (i.le.9) then + write(12,'(a9,i1,$)') " | strand",i + else + write(12,'(a9,i2,$)') " | strand",i + endif + enddo + write(12,'(a1)') "'" + endif + + +c finding alpha or 310 helix + + nhelix=0 + do i=1,ncont + i1=icont(1,i) + j1=icont(2,i) + if (j1.eq.i1+3.and.dcont(i).le.r310 + & .or.j1.eq.i1+4.and.dcont(i).le.ralfa ) then +cd if (j1.eq.i1+3) write (iout,*) "found 1-4 ",i1,j1,dcont(i) +cd if (j1.eq.i1+4) write (iout,*) "found 1-5 ",i1,j1,dcont(i) + ii1=i1 + jj1=j1 + if (isec(ii1,1).eq.0) then + not_done=.true. + else + not_done=.false. + endif + do while (not_done) + i1=i1+1 + j1=j1+1 + do j=1,ncont + if (i1.eq.icont(1,j) .and. j1.eq.icont(2,j)) goto 10 + enddo + not_done=.false. + 10 continue +cd write (iout,*) i1,j1,not_done + enddo + j1=j1-1 + if (j1-ii1.gt.4) then + nhelix=nhelix+1 +cd write (iout,*)'helix',nhelix,ii1,j1 + + nhfrag=nhfrag+1 + hfrag(1,nhfrag)=ii1 + hfrag(2,nhfrag)=max0(j1-1,1) + + do ij=ii1,j1 + isec(ij,1)=-1 + enddo + if (lprint) then + write (iout,'(a6,i3,2i4)') "Helix",nhelix,ii1-1,j1-2 + if (nhelix.le.9) then + write(12,'(a17,i1,a9,i3,a2,i3,a1)') + & "DefPropRes 'helix",nhelix, + & "' 'num = ",ii1-1,"..",j1-2,"'" + else + write(12,'(a17,i2,a9,i3,a2,i3,a1)') + & "DefPropRes 'helix",nhelix, + & "' 'num = ",ii1-1,"..",j1-2,"'" + endif + endif + endif + endif + enddo + + if (nhelix.gt.0.and.lprint) then + write(12,'(a26,$)') "DefPropRes 'helix' 'helix1" + do i=2,nhelix + if (nhelix.le.9) then + write(12,'(a8,i1,$)') " | helix",i + else + write(12,'(a8,i2,$)') " | helix",i + endif + enddo + write(12,'(a1)') "'" + endif + + if (lprint) then + write(12,'(a37)') "DefPropRes 'coil' '! (helix | sheet)'" + write(12,'(a20)') "XMacStand ribbon.mac" + endif + + + return + end +c---------------------------------------------------------------------------- + + subroutine write_pdb(npdb,titelloc,ee) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + character*50 titelloc1 + character*(*) titelloc + character*3 zahl + character*5 liczba5 + double precision ee + integer npdb,ilen + external ilen + + titelloc1=titelloc + lenpre=ilen(prefix) + if (npdb.lt.1000) then + call numstr(npdb,zahl) + open(ipdb,file=prefix(:lenpre)//'@@'//zahl//'.pdb') + else + if (npdb.lt.10000) then + write(liczba5,'(i1,i4)') 0,npdb + else + write(liczba5,'(i5)') npdb + endif + open(ipdb,file=prefix(:lenpre)//'@@'//liczba5//'.pdb') + endif + call pdbout(ee,titelloc1,ipdb) + close(ipdb) + return + end + +c-------------------------------------------------------- + subroutine softreg + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.GEO' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.VAR' + include 'COMMON.CONTROL' + include 'COMMON.SBRIDGE' + include 'COMMON.FFIELD' + include 'COMMON.MINIM' + include 'COMMON.INTERACT' +c + include 'COMMON.DISTFIT' + integer iff(maxres) + double precision time0,time1 + double precision energy(0:n_ene),ee + double precision var(maxvar) + integer ieval +c + logical debug,ltest,fail + character*50 linia +c + linia='test' + debug=.true. + in_pdb=0 + + + +c------------------------ +c +c freeze sec.elements +c + do i=1,nres + mask_phi(i)=1 + mask_theta(i)=1 + mask_side(i)=1 + iff(i)=0 + enddo + + do j=1,nbfrag + do i=bfrag(1,j),bfrag(2,j) + mask_phi(i)=0 + mask_theta(i)=0 + iff(i)=1 + enddo + if (bfrag(3,j).le.bfrag(4,j)) then + do i=bfrag(3,j),bfrag(4,j) + mask_phi(i)=0 + mask_theta(i)=0 + iff(i)=1 + enddo + else + do i=bfrag(4,j),bfrag(3,j) + mask_phi(i)=0 + mask_theta(i)=0 + iff(i)=1 + enddo + endif + enddo + do j=1,nhfrag + do i=hfrag(1,j),hfrag(2,j) + mask_phi(i)=0 + mask_theta(i)=0 + iff(i)=1 + enddo + enddo + mask_r=.true. + + + + nhpb0=nhpb +c +c store dist. constrains +c + do i=1,nres-3 + do j=i+3,nres + if ( iff(i).eq.1.and.iff(j).eq.1 ) then + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=0.1 + dhpb(nhpb)=DIST(i,j) + endif + enddo + enddo + call hpb_partition + + if (debug) then + call chainbuild + call write_pdb(100+in_pdb,'input reg. structure',0d0) + endif + + + ipot0=ipot + maxmin0=maxmin + maxfun0=maxfun + wstrain0=wstrain + wang0=wang +c +c run soft pot. optimization +c + ipot=6 + wang=3.0 + maxmin=2000 + maxfun=4000 + call geom_to_var(nvar,var) +#ifdef MPI + time0=MPI_WTIME() +#else + time0=tcpu() +#endif + call minimize(etot,var,iretcode,nfun) + + write(iout,*)'SUMSL return code is',iretcode,' eval SOFT',nfun +#ifdef MPI + time1=MPI_WTIME() +#else + time1=tcpu() +#endif + write (iout,'(a,f6.2,f8.2,a)')' Time for soft min.',time1-time0, + & nfun/(time1-time0),' SOFT eval/s' + if (debug) then + call var_to_geom(nvar,var) + call chainbuild + call write_pdb(300+in_pdb,'soft structure',etot) + endif +c +c run full UNRES optimization with constrains and frozen 2D +c the same variables as soft pot. optimizatio +c + ipot=ipot0 + wang=wang0 + maxmin=maxmin0 + maxfun=maxfun0 +#ifdef MPI + time0=MPI_WTIME() +#else + time0=tcpu() +#endif + call minimize(etot,var,iretcode,nfun) + write(iout,*)'SUMSL MASK DIST return code is',iretcode, + & ' eval ',nfun + ieval=nfun +#ifdef MPI + time1=MPI_WTIME() +#else + time1=tcpu() +#endif + write (iout,'(a,f6.2,f8.2,a)') + & ' Time for mask dist min.',time1-time0, + & nfun/(time1-time0),' eval/s' + if (debug) then + call var_to_geom(nvar,var) + call chainbuild + call write_pdb(400+in_pdb,'mask & dist',etot) + endif +c +c switch off constrains and +c run full UNRES optimization with frozen 2D +c + +c +c reset constrains +c + nhpb_c=nhpb + nhpb=nhpb0 + link_start=1 + link_end=nhpb + wstrain=wstrain0 + +#ifdef MPI + time0=MPI_WTIME() +#else + time0=tcpu() +#endif + call minimize(etot,var,iretcode,nfun) + write(iout,*)'SUMSL MASK return code is',iretcode,' eval ',nfun + ieval=ieval+nfun +#ifdef MPI + time1=MPI_WTIME() +#else + time1=tcpu() +#endif + write (iout,'(a,f6.2,f8.2,a)')' Time for mask min.',time1-time0, + & nfun/(time1-time0),' eval/s' + + + if (debug) then + call var_to_geom(nvar,var) + call chainbuild + call write_pdb(500+in_pdb,'mask 2d frozen',etot) + endif + + mask_r=.false. + + +c +c run full UNRES optimization with constrains and NO frozen 2D +c + + nhpb=nhpb_c + link_start=1 + link_end=nhpb + maxfun=maxfun0/5 + + do ico=1,5 + + wstrain=wstrain0/ico +#ifdef MPI + time0=MPI_WTIME() +#else + time0=tcpu() +#endif + call minimize(etot,var,iretcode,nfun) + write(iout,'(a10,f6.3,a14,i3,a6,i5)') + & ' SUMSL DIST',wstrain,' return code is',iretcode, + & ' eval ',nfun + ieval=nfun +#ifdef MPI + time1=MPI_WTIME() +#else + time1=tcpu() +#endif + write (iout,'(a,f6.2,f8.2,a)') + & ' Time for dist min.',time1-time0, + & nfun/(time1-time0),' eval/s' + if (debug) then + call var_to_geom(nvar,var) + call chainbuild + call write_pdb(600+in_pdb+ico,'dist cons',etot) + endif + + enddo +c + nhpb=nhpb0 + link_start=1 + link_end=nhpb + wstrain=wstrain0 + maxfun=maxfun0 + + +c + if (minim) then +#ifdef MPI + time0=MPI_WTIME() +#else + time0=tcpu() +#endif + call minimize(etot,var,iretcode,nfun) + write(iout,*)'------------------------------------------------' + write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun, + & '+ DIST eval',ieval +#ifdef MPI + time1=MPI_WTIME() +#else + time1=tcpu() +#endif + write (iout,'(a,f6.2,f8.2,a)')' Time for full min.',time1-time0, + & nfun/(time1-time0),' eval/s' + + + call var_to_geom(nvar,var) + call chainbuild + call write_pdb(999,'full min',etot) + endif + + return + end + + diff --git a/source/unres/src_MD-DFA-restraints/thread.F b/source/unres/src_MD-DFA-restraints/thread.F new file mode 100644 index 0000000..9f169a0 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/thread.F @@ -0,0 +1,549 @@ + subroutine thread_seq +C Thread the sequence through a database of known structures + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.DBASE' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.THREAD' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + include 'COMMON.HEADER' + include 'COMMON.IOUNITS' + include 'COMMON.TIME1' + include 'COMMON.CONTACTS' + include 'COMMON.MCM' + include 'COMMON.NAMES' +#ifdef MPI + include 'COMMON.INFO' + integer ThreadId,ThreadType,Kwita +#endif + double precision varia(maxvar) + double precision przes(3),obr(3,3) + double precision time_for_thread + logical found_pattern,non_conv + character*32 head_pdb + double precision energia(0:n_ene) + n_ene_comp=nprint_ene +C +C Body +C +#ifdef MPI + if (me.eq.king) then + do i=1,nctasks + nsave_part(i)=0 + enddo + endif + nacc_tot=0 +#endif + Kwita=0 + close(igeom) + close(ipdb) + close(istat) + do i=1,maxthread + do j=1,14 + ener0(j,i)=0.0D0 + ener(j,i)=0.0D0 + enddo + enddo + nres0=nct-nnt+1 + ave_time_for_thread=0.0D0 + max_time_for_thread=0.0D0 +cd print *,'nthread=',nthread,' nseq=',nseq,' nres0=',nres0 + nthread=nexcl+nthread + do ithread=1,nthread + found_pattern=.false. + itrial=0 + do while (.not.found_pattern) + itrial=itrial+1 + if (itrial.gt.1000) then + write (iout,'(/a/)') 'Too many attempts to find pattern.' + nthread=ithread-1 +#ifdef MPI + call recv_stop_sig(Kwita) + call send_stop_sig(-3) +#endif + goto 777 + endif +C Find long enough chain in the database + ii=iran_num(1,nseq) + nres_t=nres_base(1,ii) +C Select the starting position to thread. + print *,'nseq',nseq,' ii=',ii,' nres_t=', + & nres_t,' nres0=',nres0 + if (nres_t.ge.nres0) then + ist=iran_num(0,nres_t-nres0) +#ifdef MPI + if (Kwita.eq.0) call recv_stop_sig(Kwita) + if (Kwita.lt.0) then + write (iout,*) 'Stop signal received. Terminating.' + write (*,*) 'Stop signal received. Terminating.' + nthread=ithread-1 + write (*,*) 'ithread=',ithread,' nthread=',nthread + goto 777 + endif + call pattern_receive +#endif + do i=1,nexcl + if (iexam(1,i).eq.ii .and. iexam(2,i).eq.ist) goto 10 + enddo + found_pattern=.true. + endif +C If this point is reached, the pattern has not yet been examined. + 10 continue +c print *,'found_pattern:',found_pattern + enddo + nexcl=nexcl+1 + iexam(1,nexcl)=ii + iexam(2,nexcl)=ist +#ifdef MPI + if (Kwita.eq.0) call recv_stop_sig(Kwita) + if (Kwita.lt.0) then + write (iout,*) 'Stop signal received. Terminating.' + nthread=ithread-1 + write (*,*) 'ithread=',ithread,' nthread=',nthread + goto 777 + endif + call pattern_send +#endif + ipatt(1,ithread)=ii + ipatt(2,ithread)=ist +#ifdef MPI + write (iout,'(/80(1h*)/a,i4,a,i5,2a,i3,a,i3,a,i3/)') + & 'Processor:',me,' Attempt:',ithread, + & ' pattern: ',str_nam(ii),nres_base(2,ii),':',nres_base(3,ii), + & ' start at res.',ist+1 + write (*,'(a,i4,a,i5,2a,i3,a,i3,a,i3)') 'Processor:',me, + & ' Attempt:',ithread, + & ' pattern: ',str_nam(ii),nres_base(2,ii),':',nres_base(3,ii), + & ' start at res.',ist+1 +#else + write (iout,'(/80(1h*)/a,i5,2a,i3,a,i3,a,i3/)') + & 'Attempt:',ithread, + & ' pattern: ',str_nam(ii),nres_base(2,ii),':',nres_base(3,ii), + & ' start at res.',ist+1 + write (*,'(a,i5,2a,i3,a,i3,a,i3)') + & 'Attempt:',ithread, + & ' pattern: ',str_nam(ii),nres_base(2,ii),':',nres_base(3,ii), + & ' start at res.',ist+1 +#endif + ipattern=ii +C Copy coordinates from the database. + ist=ist-(nnt-1) + do i=nnt,nct + do j=1,3 + c(j,i)=cart_base(j,i+ist,ii) +c cref(j,i)=c(j,i) + enddo +cd write (iout,'(a,i4,3f10.5)') restyp(itype(i)),i,(c(j,i),j=1,3) + enddo +cd call fitsq(rms,c(1,nnt),cref(1,nnt),nct-nnt+1,przes,obr, +cd non_conv) +cd write (iout,'(a,f10.5)') +cd & 'Initial RMS deviation from reference structure:',rms + if (itype(nres).eq.21) then + do j=1,3 + dcj=c(j,nres-2)-c(j,nres-3) + c(j,nres)=c(j,nres-1)+dcj + c(j,2*nres)=c(j,nres) + enddo + endif + if (itype(1).eq.21) then + do j=1,3 + dcj=c(j,4)-c(j,3) + c(j,1)=c(j,2)-dcj + c(j,nres+1)=c(j,1) + enddo + endif + call int_from_cart(.false.,.false.) +cd print *,'Exit INT_FROM_CART.' +cd print *,'nhpb=',nhpb + do i=nss+1,nhpb + ii=ihpb(i) + jj=jhpb(i) + dhpb(i)=dist(ii,jj) +c write (iout,'(2i5,2f10.5)') ihpb(i),jhpb(i),dhpb(i),forcon(i) + enddo +c stop 'End generate' +C Generate SC conformations. + call sc_conf +c call intout +#ifdef MPI +cd print *,'Processor:',me,': exit GEN_SIDE.' +#else +cd print *,'Exit GEN_SIDE.' +#endif +C Calculate initial energy. + call chainbuild + call etotal(energia(0)) + etot=energia(0) + do i=1,n_ene_comp + ener0(i,ithread)=energia(i) + enddo + ener0(n_ene_comp+1,ithread)=energia(0) + if (refstr) then + call rms_nac_nnc(rms,frac,frac_nn,co,.true.) + ener0(n_ene_comp+3,ithread)=contact_fract(ncont,ncont_ref, + & icont,icont_ref) + ener0(n_ene_comp+2,ithread)=rms + ener0(n_ene_comp+4,ithread)=frac + ener0(n_ene_comp+5,ithread)=frac_nn + endif + ener0(n_ene_comp+3,ithread)=0.0d0 +C Minimize energy. +#ifdef MPI + print*,'Processor:',me,' ithread=',ithread,' Start REGULARIZE.' +#else + print*,'ithread=',ithread,' Start REGULARIZE.' +#endif + curr_tim=tcpu() + call regularize(nct-nnt+1,etot,rms, + & cart_base(1,ist+nnt,ipattern),iretcode) + curr_tim1=tcpu() + time_for_thread=curr_tim1-curr_tim + ave_time_for_thread= + & ((ithread-1)*ave_time_for_thread+time_for_thread)/ithread + if (time_for_thread.gt.max_time_for_thread) + & max_time_for_thread=time_for_thread +#ifdef MPI + print *,'Processor',me,': Exit REGULARIZE.' + if (WhatsUp.eq.2) then + write (iout,*) + & 'Sufficient number of confs. collected. Terminating.' + nthread=ithread-1 + goto 777 + else if (WhatsUp.eq.-1) then + nthread=ithread-1 + write (iout,*) 'Time up in REGULARIZE. Call SEND_STOP_SIG.' + if (Kwita.eq.0) call recv_stop_sig(Kwita) + call send_stop_sig(-2) + goto 777 + else if (WhatsUp.eq.-2) then + nthread=ithread-1 + write (iout,*) 'Timeup signal received. Terminating.' + goto 777 + else if (WhatsUp.eq.-3) then + nthread=ithread-1 + write (iout,*) 'Error stop signal received. Terminating.' + goto 777 + endif +#else + print *,'Exit REGULARIZE.' + if (iretcode.eq.11) then + write (iout,'(/a/)') + &'******* Allocated time exceeded in SUMSL. The program will stop.' + nthread=ithread-1 + goto 777 + endif +#endif + head_pdb=titel(:24)//':'//str_nam(ipattern) + if (outpdb) call pdbout(etot,head_pdb,ipdb) + if (outmol2) call mol2out(etot,head_pdb) +c call intout + call briefout(ithread,etot) + link_end0=link_end + link_end=min0(link_end,nss) + write (iout,*) 'link_end=',link_end,' link_end0=',link_end0, + & ' nss=',nss + call etotal(energia(0)) +c call enerprint(energia(0)) + link_end=link_end0 +cd call chainbuild +cd call fitsq(rms,c(1,nnt),cref(1,nnt),nct-nnt+1,przes,obr,non_conv) +cd write (iout,'(a,f10.5)') +cd & 'RMS deviation from reference structure:',dsqrt(rms) + do i=1,n_ene_comp + ener(i,ithread)=energia(i) + enddo + ener(n_ene_comp+1,ithread)=energia(0) + ener(n_ene_comp+3,ithread)=rms + if (refstr) then + call rms_nac_nnc(rms,frac,frac_nn,co,.true.) + ener(n_ene_comp+2,ithread)=rms + ener(n_ene_comp+4,ithread)=frac + ener(n_ene_comp+5,ithread)=frac_nn + endif + call write_stat_thread(ithread,ipattern,ist) +c write (istat,'(i4,2x,a8,i4,11(1pe14.5),2(0pf8.3),f8.5)') +c & ithread,str_nam(ipattern),ist+1,(ener(k,ithread),k=1,11), +c & (ener(k,ithread),k=12,14) +#ifdef MPI + if (me.eq.king) then + nacc_tot=nacc_tot+1 + call pattern_receive + call receive_MCM_info + if (nacc_tot.ge.nthread) then + write (iout,*) + & 'Sufficient number of conformations collected nacc_tot=', + & nacc_tot,'. Stopping other processors and terminating.' + write (*,*) + & 'Sufficient number of conformations collected nacc_tot=', + & nacc_tot,'. Stopping other processors and terminating.' + call recv_stop_sig(Kwita) + if (Kwita.eq.0) call send_stop_sig(-1) + nthread=ithread + goto 777 + endif + else + call send_MCM_info(2) + endif +#endif + if (timlim-curr_tim1-safety .lt. max_time_for_thread) then + write (iout,'(/2a)') + & '********** There would be not enough time for another thread. ', + & 'The program will stop.' + write (*,'(/2a)') + & '********** There would be not enough time for another thread. ', + & 'The program will stop.' + write (iout,'(a,1pe14.4/)') + & 'Elapsed time for last threading step: ',time_for_thread + nthread=ithread +#ifdef MPI + call recv_stop_sig(Kwita) + call send_stop_sig(-2) +#endif + goto 777 + else + curr_tim=curr_tim1 + write (iout,'(a,1pe14.4)') + & 'Elapsed time for this threading step: ',time_for_thread + endif +#ifdef MPI + if (Kwita.eq.0) call recv_stop_sig(Kwita) + if (Kwita.lt.0) then + write (iout,*) 'Stop signal received. Terminating.' + write (*,*) 'Stop signal received. Terminating.' + nthread=ithread + write (*,*) 'nthread=',nthread,' ithread=',ithread + goto 777 + endif +#endif + enddo +#ifdef MPI + call send_stop_sig(-1) +#endif + 777 continue +#ifdef MPI +C Any messages left for me? + call pattern_receive + if (Kwita.eq.0) call recv_stop_sig(Kwita) +#endif + call write_thread_summary +#ifdef MPI + if (king.eq.king) then + Kwita=1 + do while (Kwita.ne.0 .or. nacc_tot.ne.0) + Kwita=0 + nacc_tot=0 + call recv_stop_sig(Kwita) + call receive_MCM_info + enddo + do iproc=1,nprocs-1 + call receive_thread_results(iproc) + enddo + call write_thread_summary + else + call send_thread_results + endif +#endif + return + end +c-------------------------------------------------------------------------- + subroutine write_thread_summary +C Thread the sequence through a database of known structures + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.DBASE' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.THREAD' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + include 'COMMON.HEADER' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.TIME1' +#ifdef MPI + include 'COMMON.INFO' +#endif + dimension ip(maxthread) + double precision energia(0:n_ene) + write (iout,'(30x,a/)') + & ' *********** Summary threading statistics ************' + write (iout,'(a)') 'Initial energies:' + write (iout,'(a4,2x,a12,14a14,3a8)') + & 'No','seq',(ename(print_order(i)),i=1,nprint_ene),'ETOT', + & 'RMSnat','NatCONT','NNCONT','RMS' +C Energy sort patterns + do i=1,nthread + ip(i)=i + enddo + do i=1,nthread-1 + enet=ener(n_ene-1,ip(i)) + jj=i + do j=i+1,nthread + if (ener(n_ene-1,ip(j)).lt.enet) then + jj=j + enet=ener(n_ene-1,ip(j)) + endif + enddo + if (jj.ne.i) then + ipj=ip(jj) + ip(jj)=ip(i) + ip(i)=ipj + endif + enddo + do ik=1,nthread + i=ip(ik) + ii=ipatt(1,i) + ist=nres_base(2,ii)+ipatt(2,i) + do kk=1,n_ene_comp + energia(i)=ener0(kk,i) + enddo + etot=ener0(n_ene_comp+1,i) + rmsnat=ener0(n_ene_comp+2,i) + rms=ener0(n_ene_comp+3,i) + frac=ener0(n_ene_comp+4,i) + frac_nn=ener0(n_ene_comp+5,i) + + if (refstr) then + write (iout,'(i4,2x,a8,i4,14(1pe14.5),0pf8.3,f8.5,f8.5,f8.3)') + & i,str_nam(ii),ist+1, + & (energia(print_order(kk)),kk=1,nprint_ene), + & etot,rmsnat,frac,frac_nn,rms + else + write (iout,'(i4,2x,a8,i4,14(1pe14.5),0pf8.3)') + & i,str_nam(ii),ist+1, + & (energia(print_order(kk)),kk=1,nprint_ene),etot + endif + enddo + write (iout,'(//a)') 'Final energies:' + write (iout,'(a4,2x,a12,17a14,3a8)') + & 'No','seq',(ename(print_order(kk)),kk=1,nprint_ene),'ETOT', + & 'RMSnat','NatCONT','NNCONT','RMS' + do ik=1,nthread + i=ip(ik) + ii=ipatt(1,i) + ist=nres_base(2,ii)+ipatt(2,i) + do kk=1,n_ene_comp + energia(kk)=ener(kk,ik) + enddo + etot=ener(n_ene_comp+1,i) + rmsnat=ener(n_ene_comp+2,i) + rms=ener(n_ene_comp+3,i) + frac=ener(n_ene_comp+4,i) + frac_nn=ener(n_ene_comp+5,i) + write (iout,'(i4,2x,a8,i4,14(1pe14.5),0pf8.3,f8.5,f8.5,f8.3)') + & i,str_nam(ii),ist+1, + & (energia(print_order(kk)),kk=1,nprint_ene), + & etot,rmsnat,frac,frac_nn,rms + enddo + write (iout,'(/a/)') 'IEXAM array:' + write (iout,'(i5)') nexcl + do i=1,nexcl + write (iout,'(2i5)') iexam(1,i),iexam(2,i) + enddo + write (iout,'(/a,1pe14.4/a,1pe14.4/)') + & 'Max. time for threading step ',max_time_for_thread, + & 'Average time for threading step: ',ave_time_for_thread + return + end +c---------------------------------------------------------------------------- + subroutine sc_conf +C Sample (hopefully) optimal SC orientations given backcone conformation. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DBASE' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.THREAD' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + include 'COMMON.HEADER' + include 'COMMON.GEO' + include 'COMMON.IOUNITS' + double precision varia(maxvar) + common /srutu/ icall + double precision energia(0:n_ene) + logical glycine,fail + maxsample=10 + link_end0=link_end + link_end=min0(link_end,nss) + do i=nnt,nct + if (itype(i).ne.10) then +cd print *,'i=',i,' itype=',itype(i),' theta=',theta(i+1) + call gen_side(itype(i),theta(i+1),alph(i),omeg(i),fail) + endif + enddo + call chainbuild + call etotal(energia(0)) + do isample=1,maxsample +C Choose a non-glycine side chain. + glycine=.true. + do while(glycine) + ind_sc=iran_num(nnt,nct) + glycine=(itype(ind_sc).eq.10) + enddo + alph0=alph(ind_sc) + omeg0=omeg(ind_sc) + call gen_side(itype(ind_sc),theta(ind_sc+1),alph(ind_sc), + & omeg(ind_sc),fail) + call chainbuild + call etotal(energia(0)) +cd write (iout,'(a,i5,a,i4,2(a,f8.3),2(a,1pe14.5))') +cd & 'Step:',isample,' SC',ind_sc,' alpha',alph(ind_sc)*rad2deg, +cd & ' omega',omeg(ind_sc)*rad2deg,' old energy',e0,' new energy',e1 + e1=0.0d0 + if (e0.le.e1) then + alph(ind_sc)=alph0 + omeg(ind_sc)=omeg0 + else + e0=e1 + endif + enddo + link_end=link_end0 + return + end +c--------------------------------------------------------------------------- + subroutine write_stat_thread(ithread,ipattern,ist) + implicit real*8 (a-h,o-z) + include "DIMENSIONS" + include "COMMON.CONTROL" + include "COMMON.IOUNITS" + include "COMMON.THREAD" + include "COMMON.FFIELD" + include "COMMON.DBASE" + include "COMMON.NAMES" + double precision energia(0:n_ene) + +#if defined(AIX) || defined(PGI) + open(istat,file=statname,position='append') +#else + open(istat,file=statname,access='append') +#endif + do i=1,n_ene_comp + energia(i)=ener(i,ithread) + enddo + etot=ener(n_ene_comp+1,ithread) + rmsnat=ener(n_ene_comp+2,ithread) + rms=ener(n_ene_comp+3,ithread) + frac=ener(n_ene_comp+4,ithread) + frac_nn=ener(n_ene_comp+5,ithread) + write (istat,'(i4,2x,a8,i4,14(1pe14.5),0pf8.3,f8.5,f8.5,f8.3)') + & ithread,str_nam(ipattern),ist+1, + & (energia(print_order(i)),i=1,nprint_ene), + & etot,rmsnat,frac,frac_nn,rms + close (istat) + return + end diff --git a/source/unres/src_MD-DFA-restraints/timing.F b/source/unres/src_MD-DFA-restraints/timing.F new file mode 100644 index 0000000..5a81655 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/timing.F @@ -0,0 +1,344 @@ +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**************************** +C Next definitions for sgi + real timar(2), etime + seconds = etime(timar) +Cd print *,'seconds=',seconds,' stime=',stime + usrsec = timar(1) + syssec = timar(2) + tcpu=seconds - stime +c**************************** +#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 +c integer*4 i1,mclock + i1 = mclock() + tcpu = (i1+0.0D0)/100.0D0 +#endif +#ifdef WINPGI +**************************** +c next definitions for windows NT Digital fortran + real time_real + call cpu_time(time_real) + tcpu = time_real +#endif +#ifdef WINIFL +**************************** +c next definitions for windows NT Digital fortran + real time_real + call cpu_time(time_real) + tcpu = time_real +#endif + + return + end +C--------------------------------------------------------------------------- + subroutine dajczas(rntime,hrtime,mintime,sectime) + include 'COMMON.IOUNITS' + real*8 rntime,hrtime,mintime,sectime + hrtime=rntime/3600.0D0 + hrtime=aint(hrtime) + mintime=aint((rntime-3600.0D0*hrtime)/60.0D0) + sectime=aint((rntime-3600.0D0*hrtime-60.0D0*mintime)+0.5D0) + if (sectime.eq.60.0D0) then + sectime=0.0D0 + mintime=mintime+1.0D0 + endif + ihr=hrtime + imn=mintime + isc=sectime + write (iout,328) ihr,imn,isc + 328 FORMAT(//'***** Computation time: ',I4 ,' hours ',I2 , + 1 ' minutes ', I2 ,' seconds *****') + return + end +C--------------------------------------------------------------------------- + subroutine print_detailed_timing + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.IOUNITS' + include 'COMMON.TIME1' + include 'COMMON.SETUP' +#ifdef MPI + time1=MPI_WTIME() + write (iout,'(80(1h=)/a/(80(1h=)))') + & "Details of FG communication time" + write (*,'(7(a40,1pe15.5/),40(1h-)/a40,1pe15.5/80(1h=))') + & "BROADCAST:",time_bcast,"REDUCE:",time_reduce, + & "GATHER:",time_gather, + & "SCATTER:",time_scatter,"SENDRECV:",time_sendrecv, + & "BARRIER ene",time_barrier_e, + & "BARRIER grad",time_barrier_g, + & "TOTAL:", + & time_bcast+time_reduce+time_gather+time_scatter+time_sendrecv + write (*,*) fg_rank,myrank, + & ': Total wall clock time',time1-walltime,' sec' + write (*,*) "Processor",fg_rank,myrank, + & ": BROADCAST time",time_bcast," REDUCE time", + & time_reduce," GATHER time",time_gather," SCATTER time", + & time_scatter, + & " SCATTER fmatmult",time_scatter_fmatmult, + & " SCATTER ginvmult",time_scatter_ginvmult, + & " SCATTER fmat",time_scatter_fmat, + & " SCATTER ginv",time_scatter_ginv, + & " SENDRECV",time_sendrecv, + & " BARRIER ene",time_barrier_e, + & " BARRIER GRAD",time_barrier_g, + & " BCAST7",time_bcast7," BCASTC",time_bcastc, + & " BCASTW",time_bcastw," ALLREDUCE",time_allreduce, + & " TOTAL", + & time_bcast+time_reduce+time_gather+time_scatter+ + & time_sendrecv+time_barrier+time_bcastc +#else + time1=tcpu() +#endif + write (*,*) "Processor",fg_rank,myrank," enecalc",time_enecalc + write (*,*) "Processor",fg_rank,myrank," sumene",time_sumene + write (*,*) "Processor",fg_rank,myrank," intfromcart", + & time_intfcart + write (*,*) "Processor",fg_rank,myrank," vecandderiv", + & time_vec + write (*,*) "Processor",fg_rank,myrank," setmatrices", + & time_mat + write (*,*) "Processor",fg_rank,myrank," ginvmult", + & time_ginvmult + write (*,*) "Processor",fg_rank,myrank," fricmatmult", + & time_fricmatmult + write (*,*) "Processor",fg_rank,myrank," inttocart", + & time_inttocart + write (*,*) "Processor",fg_rank,myrank," sumgradient", + & time_sumgradient + write (*,*) "Processor",fg_rank,myrank," intcartderiv", + & time_intcartderiv + if (fg_rank.eq.0) then + write (*,*) "Processor",fg_rank,myrank," lagrangian", + & time_lagrangian + write (*,*) "Processor",fg_rank,myrank," cartgrad", + & time_cartgrad + endif + return + end diff --git a/source/unres/src_MD-DFA-restraints/unres.F b/source/unres/src_MD-DFA-restraints/unres.F new file mode 100644 index 0000000..632374b --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/unres.F @@ -0,0 +1,796 @@ +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C U N R E S C +C C +C Program to carry out conformational search of proteins in an united-residue C +C approximation. C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + + +#ifdef MPI + include 'mpif.h' + include 'COMMON.SETUP' +#endif + include 'COMMON.TIME1' + include 'COMMON.INTERACT' + include 'COMMON.NAMES' + include 'COMMON.GEO' + include 'COMMON.HEADER' + include 'COMMON.CONTROL' + include 'COMMON.CONTACTS' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.REMD' + include 'COMMON.MD' + include 'COMMON.SBRIDGE' + double precision hrtime,mintime,sectime + character*64 text_mode_calc(-2:14) /'test', + & 'SC rotamer distribution', + & 'Energy evaluation or minimization', + & 'Regularization of PDB structure', + & 'Threading of a sequence on PDB structures', + & 'Monte Carlo (with minimization) ', + & 'Energy minimization of multiple conformations', + & 'Checking energy gradient', + & 'Entropic sampling Monte Carlo (with minimization)', + & 'Energy map', + & 'CSA calculations', + & 'Not used 9', + & 'Not used 10', + & 'Soft regularization of PDB structure', + & 'Mesoscopic molecular dynamics (MD) ', + & 'Not used 13', + & 'Replica exchange molecular dynamics (REMD)'/ + external ilen + +c call memmon_print_usage() + + call init_task + if (me.eq.king) + & write(iout,*)'### LAST MODIFIED 03/28/12 23:29 by czarek' + if (me.eq.king) call cinfo +C Read force field parameters and job setup data + call readrtns + if (me.eq.king .or. .not. out1file) then + write (iout,'(2a/)') + & text_mode_calc(modecalc)(:ilen(text_mode_calc(modecalc))), + & ' calculation.' + if (minim) write (iout,'(a)') + & 'Conformations will be energy-minimized.' + write (iout,'(80(1h*)/)') + endif + call flush(iout) +C + if (modecalc.eq.-2) then + call test + stop + else if (modecalc.eq.-1) then + write(iout,*) "call check_sc_map next" + call check_bond + stop + endif +#ifdef MPI + if (fg_rank.gt.0) then +C Fine-grain slaves just do energy and gradient components. + call ergastulum ! slave workhouse in Latin + else +#endif + if (modecalc.eq.0) then + call exec_eeval_or_minim + else if (modecalc.eq.1) then + call exec_regularize + else if (modecalc.eq.2) then + call exec_thread + else if (modecalc.eq.3 .or. modecalc .eq.6) then + call exec_MC + else if (modecalc.eq.4) then + call exec_mult_eeval_or_minim + else if (modecalc.eq.5) then + call exec_checkgrad + else if (ModeCalc.eq.7) then + call exec_map + else if (ModeCalc.eq.8) then + call exec_CSA + else if (modecalc.eq.11) then + call exec_softreg + else if (modecalc.eq.12) then + call exec_MD + else if (modecalc.eq.14) then + call exec_MREMD + else + write (iout,'(a)') 'This calculation type is not supported', + & ModeCalc + endif +#ifdef MPI + endif +C Finish task. + if (fg_rank.eq.0) call finish_task +c call memmon_print_usage() +#ifdef TIMING + call print_detailed_timing +#endif + call MPI_Finalize(ierr) + stop 'Bye Bye...' +#else + call dajczas(tcpu(),hrtime,mintime,sectime) + stop '********** Program terminated normally.' +#endif + end +c-------------------------------------------------------------------------- + subroutine exec_MD + include 'DIMENSIONS' +#ifdef MPI + include "mpif.h" +#endif + include 'COMMON.SETUP' + include 'COMMON.CONTROL' + include 'COMMON.IOUNITS' + if (me.eq.king .or. .not. out1file) + & write (iout,*) "Calling chainbuild" + call chainbuild + call MD + return + end +c--------------------------------------------------------------------------- + subroutine exec_MREMD + include 'DIMENSIONS' +#ifdef MPI + include "mpif.h" + include 'COMMON.SETUP' + include 'COMMON.CONTROL' + include 'COMMON.IOUNITS' + include 'COMMON.REMD' + if (me.eq.king .or. .not. out1file) + & write (iout,*) "Calling chainbuild" + call chainbuild + if (me.eq.king .or. .not. out1file) + & write (iout,*) "Calling REMD" + if (remd_mlist) then + call MREMD + else + do i=1,nrep + remd_m(i)=1 + enddo + call MREMD + endif +#else + write (iout,*) "MREMD works on parallel machines only" +#endif + return + end +c--------------------------------------------------------------------------- + subroutine exec_eeval_or_minim + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.SETUP' + include 'COMMON.TIME1' + include 'COMMON.INTERACT' + include 'COMMON.NAMES' + include 'COMMON.GEO' + include 'COMMON.HEADER' + include 'COMMON.CONTROL' + include 'COMMON.CONTACTS' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.REMD' + include 'COMMON.MD' + include 'COMMON.SBRIDGE' + common /srutu/ icall + double precision energy(0:n_ene) + double precision energy_long(0:n_ene),energy_short(0:n_ene) + double precision varia(maxvar) + if (indpdb.eq.0) call chainbuild +#ifdef MPI + time00=MPI_Wtime() +#else + time00=tcpu() +#endif + call chainbuild_cart + if (split_ene) then + print *,"Processor",myrank," after chainbuild" + icall=1 + call etotal_long(energy_long(0)) + write (iout,*) "Printing long range energy" + call enerprint(energy_long(0)) + call etotal_short(energy_short(0)) + write (iout,*) "Printing short range energy" + call enerprint(energy_short(0)) + do i=0,n_ene + energy(i)=energy_long(i)+energy_short(i) + write (iout,*) i,energy_long(i),energy_short(i),energy(i) + enddo + write (iout,*) "Printing long+short range energy" + call enerprint(energy(0)) + endif + call etotal(energy(0)) +#ifdef MPI + time_ene=MPI_Wtime()-time00 +#else + time_ene=tcpu()-time00 +#endif + write (iout,*) "Time for energy evaluation",time_ene + print *,"after etotal" + etota = energy(0) + etot =etota + call enerprint(energy(0)) + call hairpin(.true.,nharp,iharp) + call secondary2(.true.) + if (minim) then +crc overlap test + if (overlapsc) then + print *, 'Calling OVERLAP_SC' + call overlap_sc(fail) + endif + + if (searchsc) then + call sc_move(2,nres-1,10,1d10,nft_sc,etot) + print *,'SC_move',nft_sc,etot + write(iout,*) 'SC_move',nft_sc,etot + endif + + if (dccart) then + print *, 'Calling MINIM_DC' +#ifdef MPI + time1=MPI_WTIME() +#else + time1=tcpu() +#endif + call minim_dc(etot,iretcode,nfun) + else + if (indpdb.ne.0) then + call bond_regular + call chainbuild + endif + call geom_to_var(nvar,varia) + print *,'Calling MINIMIZE.' +#ifdef MPI + time1=MPI_WTIME() +#else + time1=tcpu() +#endif + call minimize(etot,varia,iretcode,nfun) + endif + print *,'SUMSL return code is',iretcode,' eval ',nfun +#ifdef MPI + evals=nfun/(MPI_WTIME()-time1) +#else + evals=nfun/(tcpu()-time1) +#endif + print *,'# eval/s',evals + print *,'refstr=',refstr + call hairpin(.true.,nharp,iharp) + call secondary2(.true.) + call etotal(energy(0)) + etot = energy(0) + call enerprint(energy(0)) + + call intout + call briefout(0,etot) + if (refstr) call rms_nac_nnc(rms,frac,frac_nn,co,.true.) + write (iout,'(a,i3)') 'SUMSL return code:',iretcode + write (iout,'(a,i20)') '# of energy evaluations:',nfun+1 + write (iout,'(a,f16.3)')'# of energy evaluations/sec:',evals + else + print *,'refstr=',refstr + if (refstr) call rms_nac_nnc(rms,frac,frac_nn,co,.true.) + call briefout(0,etot) + endif + if (outpdb) call pdbout(etot,titel(:32),ipdb) + if (outmol2) call mol2out(etot,titel(:32)) + return + end +c--------------------------------------------------------------------------- + subroutine exec_regularize + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.SETUP' + include 'COMMON.TIME1' + include 'COMMON.INTERACT' + include 'COMMON.NAMES' + include 'COMMON.GEO' + include 'COMMON.HEADER' + include 'COMMON.CONTROL' + include 'COMMON.CONTACTS' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.REMD' + include 'COMMON.MD' + include 'COMMON.SBRIDGE' + double precision energy(0:n_ene) + + call gen_dist_constr + call sc_conf + call intout + call regularize(nct-nnt+1,etot,rms,cref(1,nnt),iretcode) + call etotal(energy(0)) + energy(0)=energy(0)-energy(14) + etot=energy(0) + call enerprint(energy(0)) + call intout + call briefout(0,etot) + if (outpdb) call pdbout(etot,titel(:32),ipdb) + if (outmol2) call mol2out(etot,titel(:32)) + if (refstr) call rms_nac_nnc(rms,frac,frac_nn,co,.true.) + write (iout,'(a,i3)') 'SUMSL return code:',iretcode + return + end +c--------------------------------------------------------------------------- + subroutine exec_thread + include 'DIMENSIONS' +#ifdef MP + include "mpif.h" +#endif + include "COMMON.SETUP" + call thread_seq + return + end +c--------------------------------------------------------------------------- + subroutine exec_MC + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + character*10 nodeinfo + double precision varia(maxvar) +#ifdef MPI + include "mpif.h" +#endif + include "COMMON.SETUP" + include 'COMMON.CONTROL' + call mcm_setup + if (minim) then +#ifdef MPI + if (modecalc.eq.3) then + call do_mcm(ipar) + else + call entmcm + endif +#else + if (modecalc.eq.3) then + call do_mcm(ipar) + else + call entmcm + endif +#endif + else + call monte_carlo + endif + return + end +c--------------------------------------------------------------------------- + subroutine exec_mult_eeval_or_minim + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' + dimension muster(mpi_status_size) +#endif + include 'COMMON.SETUP' + include 'COMMON.TIME1' + include 'COMMON.INTERACT' + include 'COMMON.NAMES' + include 'COMMON.GEO' + include 'COMMON.HEADER' + include 'COMMON.CONTROL' + include 'COMMON.CONTACTS' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.REMD' + include 'COMMON.MD' + include 'COMMON.SBRIDGE' + double precision varia(maxvar) + dimension ind(6) + double precision energy(0:n_ene) + logical eof + eof=.false. +#ifdef MPI + if(me.ne.king) then + call minim_mcmf + return + endif + + close (intin) + open(intin,file=intinname,status='old') + write (istat,'(a5,30a12)')"# ", + & (wname(print_order(i)),i=1,nprint_ene) + if (refstr) then + write (istat,'(a5,30a12)')"# ", + & (ename(print_order(i)),i=1,nprint_ene), + & "ETOT total","RMSD","nat.contact","nnt.contact","cont.order" + else + write (istat,'(a5,30a12)')"# ", + & (ename(print_order(i)),i=1,nprint_ene),"ETOT total" + endif + + if (.not.minim) then + do while (.not. eof) + if (read_cart) then + read (intin,'(e15.10,e15.5)',end=1100,err=1100) time,ene + call read_x(intin,*11) +#ifdef MPI +c Broadcast the order to compute internal coordinates to the slaves. + if (nfgtasks.gt.1) + & call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR) +#endif + call int_from_cart1(.false.) + else + read (intin,'(i5)',end=1100,err=1100) iconf + call read_angles(intin,*11) + call geom_to_var(nvar,varia) + call chainbuild + endif + write (iout,'(a,i7)') 'Conformation #',iconf + call etotal(energy(0)) + call briefout(iconf,energy(0)) + call enerprint(energy(0)) + etot=energy(0) + if (refstr) then + call rms_nac_nnc(rms,frac,frac_nn,co,.true.) + write (istat,'(i5,30(f12.3))') iconf, + & (energy(print_order(i)),i=1,nprint_ene),etot, + & rms,frac,frac_nn,co +cjlee end + else + write (istat,'(i5,30(f12.3))') iconf, + & (energy(print_order(i)),i=1,nprint_ene),etot + endif + enddo +1100 continue + goto 1101 + endif + + mm=0 + imm=0 + nft=0 + ene0=0.0d0 + n=0 + iconf=0 +c do n=1,nzsc + do while (.not. eof) + mm=mm+1 + if (mm.lt.nodes) then + if (read_cart) then + read (intin,'(e15.10,e15.5)',end=11,err=11) time,ene + call read_x(intin,*11) +#ifdef MPI +c Broadcast the order to compute internal coordinates to the slaves. + if (nfgtasks.gt.1) + & call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR) +#endif + call int_from_cart1(.false.) + else + read (intin,'(i5)',end=11,err=11) iconf + call read_angles(intin,*11) + call geom_to_var(nvar,varia) + call chainbuild + endif + + 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(it,etot) +c if (minim) call briefout(it,etot) + if (refstr) then + call rms_nac_nnc(rms,frac,frac_nn,co,.true.) + write (istat,'(i5,30(f12.3))') iconf, + & (energy(print_order(i)),i=1,nprint_ene),etot, + & rms,frac,frac_nn,co + else + write (istat,'(i5,30(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) +#ifdef MPI +c Broadcast the order to compute internal coordinates to the slaves. + if (nfgtasks.gt.1) + & call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR) +#endif + call int_from_cart1(.false.) + else + read (intin,'(i5)',end=11,err=11) iconf + call read_angles(intin,*11) + call geom_to_var(nvar,varia) + call chainbuild + endif + 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(it,etot) + if (refstr) then + call rms_nac_nnc(rms,frac,frac_nn,co,.true.) + write (istat,'(i5,30(f12.3))') iconf, + & (energy(print_order(i)),i=1,nprint_ene),etot, + & rms,frac,frac_nn,co + else + write (istat,'(i5,30(f12.3))') iconf, + & (energy(print_order(i)),i=1,nprint_ene),etot + endif + nmin=nmin+1 + enddo +1101 continue + do i=1, nodes-1 + ind(1)=0 + ind(2)=0 + ind(3)=0 + ind(4)=0 + ind(5)=0 + ind(6)=0 + call mpi_send(ind,6,mpi_integer,i,idint,CG_COMM, + * ierr) + enddo +#else + close (intin) + open(intin,file=intinname,status='old') + write (istat,'(a5,20a12)')"# ", + & (wname(print_order(i)),i=1,nprint_ene) + write (istat,'("# ",20(1pe12.4))') + & (weights(print_order(i)),i=1,nprint_ene) + if (refstr) then + write (istat,'(a5,20a12)')"# ", + & (ename(print_order(i)),i=1,nprint_ene), + & "ETOT total","RMSD","nat.contact","nnt.contact" + else + write (istat,'(a5,14a12)')"# ", + & (ename(print_order(i)),i=1,nprint_ene),"ETOT total" + endif + do while (.not. eof) + if (read_cart) then + read (intin,'(e15.10,e15.5)',end=1100,err=1100) time,ene + call read_x(intin,*11) +#ifdef MPI +c Broadcast the order to compute internal coordinates to the slaves. + if (nfgtasks.gt.1) + & call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR) +#endif + call int_from_cart1(.false.) + else + read (intin,'(i5)',end=1100,err=1100) iconf + call read_angles(intin,*11) + call geom_to_var(nvar,varia) + call chainbuild + endif + write (iout,'(a,i7)') 'Conformation #',iconf + if (minim) call minimize(etot,varia,iretcode,nfun) + call etotal(energy(0)) + + etot=energy(0) + call enerprint(energy(0)) + if (minim) call briefout(it,etot) + if (refstr) then + call rms_nac_nnc(rms,frac,frac_nn,co,.true.) + write (istat,'(i5,18(f12.3))') iconf, + & (energy(print_order(i)),i=1,nprint_ene), + & etot,rms,frac,frac_nn,co +cjlee end + else + write (istat,'(i5,14(f12.3))') iconf, + & (energy(print_order(i)),i=1,nprint_ene),etot + endif + enddo + 11 continue + 1100 continue +#endif + return + end +c--------------------------------------------------------------------------- + subroutine exec_checkgrad + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.SETUP' + include 'COMMON.TIME1' + include 'COMMON.INTERACT' + include 'COMMON.NAMES' + include 'COMMON.GEO' + include 'COMMON.HEADER' + include 'COMMON.CONTROL' + include 'COMMON.CONTACTS' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.REMD' + include 'COMMON.MD' + include 'COMMON.SBRIDGE' + common /srutu/ icall + double precision energy(0:max_ene) +c do i=2,nres +c vbld(i)=vbld(i)+ran_number(-0.1d0,0.1d0) +c if (itype(i).ne.10) +c & vbld(i+nres)=vbld(i+nres)+ran_number(-0.001d0,0.001d0) +c enddo + if (indpdb.eq.0) call chainbuild +c do i=0,nres +c do j=1,3 +c dc(j,i)=dc(j,i)+ran_number(-0.2d0,0.2d0) +c enddo +c enddo +c do i=1,nres-1 +c if (itype(i).ne.10) then +c do j=1,3 +c dc(j,i+nres)=dc(j,i+nres)+ran_number(-0.2d0,0.2d0) +c enddo +c endif +c enddo +c do j=1,3 +c dc(j,0)=ran_number(-0.2d0,0.2d0) +c enddo + usampl=.true. + totT=1.d0 + eq_time=0.0d0 + call read_fragments + read(inp,*) t_bath + call rescale_weights(t_bath) + call chainbuild_cart + call cartprint + call intout + icall=1 + call etotal(energy(0)) + etot = energy(0) + call enerprint(energy(0)) + write (iout,*) "Uconst",Uconst," Uconst_back",uconst_back + print *,'icheckgrad=',icheckgrad + goto (10,20,30) icheckgrad + 10 call check_ecartint + return + 20 call check_cartgrad + return + 30 call check_eint + return + end +c--------------------------------------------------------------------------- + subroutine exec_map +C Energy maps + call map_read + call map + return + end +c--------------------------------------------------------------------------- + subroutine exec_CSA +#ifdef MPI + include "mpif.h" +#endif + include 'DIMENSIONS' + include 'COMMON.IOUNITS' +C Conformational Space Annealling programmed by Jooyoung Lee. +C This method works only with parallel machines! +#ifdef MPI +csa call together + write (iout,*) "CSA is not supported in this version" +#else +csa write (iout,*) "CSA works on parallel machines only" + write (iout,*) "CSA is not supported in this version" +#endif + return + end +c--------------------------------------------------------------------------- + subroutine exec_softreg + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CONTROL' + double precision energy(0:max_ene) + logical debug /.false./ + call chainbuild + call etotal(energy(0)) + call enerprint(energy(0)) + if (.not.lsecondary) then + write(iout,*) 'Calling secondary structure recognition' + call secondary2(debug) + else + write(iout,*) 'Using secondary structure supplied in pdb' + endif + + call softreg + + call etotal(energy(0)) + etot=energy(0) + call enerprint(energy(0)) + call intout + call briefout(0,etot) + call secondary2(.true.) + if (refstr) call rms_nac_nnc(rms,frac,frac_nn,co,.true.) + return + end diff --git a/source/unres/src_MD-DFA-restraints/xdrf/CMakeLists.txt b/source/unres/src_MD-DFA-restraints/xdrf/CMakeLists.txt new file mode 100644 index 0000000..26baa36 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/xdrf/CMakeLists.txt @@ -0,0 +1,19 @@ +# +# CMake project file for UNRESPACK +# + +# m4 macro processor +add_custom_command( + OUTPUT ${CMAKE_CURRENT_BINARY_DIR}/libxdrf.c + COMMAND m4 + ARGS ${CMAKE_CURRENT_SOURCE_DIR}/underscore.m4 ${CMAKE_CURRENT_SOURCE_DIR}/libxdrf.m4 > ${CMAKE_CURRENT_BINARY_DIR}/libxdrf.c + VERBATIM +) + +# add headers from current dir +include_directories(${CMAKE_CURRENT_SOURCE_DIR}) +# compile the libxdrf library +add_library(xdrf STATIC ${CMAKE_CURRENT_BINARY_DIR}/libxdrf.c ftocstr.c) +set(UNRES_XDRFLIB ${CMAKE_CURRENT_BINARY_DIR}/libxdrf.a PARENT_SCOPE) + +#add_dependencies( ${UNRES_BIN} xdrf ) diff --git a/source/unres/src_MD-DFA-restraints/xdrf/Makefile b/source/unres/src_MD-DFA-restraints/xdrf/Makefile new file mode 100644 index 0000000..02c29f6 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/xdrf/Makefile @@ -0,0 +1,27 @@ +# This make file is part of the xdrf package. +# +# (C) 1995 Frans van Hoesel, hoesel@chem.rug.nl +# +# 2006 modified by Cezary Czaplewski + +# Set C compiler and flags for ARCH +CC = gcc +CFLAGS = -O + +M4 = m4 +M4FILE = underscore.m4 + +libxdrf.a: libxdrf.o ftocstr.o + ar cr libxdrf.a $? + +clean: + rm -f libxdrf.o ftocstr.o libxdrf.a + +ftocstr.o: ftocstr.c + $(CC) $(CFLAGS) -c ftocstr.c + +libxdrf.o: libxdrf.m4 $(M4FILE) + $(M4) $(M4FILE) libxdrf.m4 > libxdrf.c + $(CC) $(CFLAGS) -c libxdrf.c + rm -f libxdrf.c + diff --git a/source/unres/src_MD-DFA-restraints/xdrf/Makefile_jubl b/source/unres/src_MD-DFA-restraints/xdrf/Makefile_jubl new file mode 100644 index 0000000..8dc35cf --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/xdrf/Makefile_jubl @@ -0,0 +1,31 @@ +# This make file is part of the xdrf package. +# +# (C) 1995 Frans van Hoesel, hoesel@chem.rug.nl +# +# 2006 modified by Cezary Czaplewski + +# Set C compiler and flags for ARCH +BGLSYS = /bgl/BlueLight/ppcfloor/bglsys + +CC = /usr/bin/blrts_xlc +CPPC = /usr/bin/blrts_xlc + +CFLAGS= -O2 -I$(BGLSYS)/include -L$(BGLSYS)/lib -qarch=440d -qtune=440 + +M4 = m4 +M4FILE = RS6K.m4 + +libxdrf.a: libxdrf.o ftocstr.o xdr_array.o xdr.o xdr_float.o xdr_stdio.o + ar cr libxdrf.a $? + +clean: + rm -f *.o libxdrf.a + +ftocstr.o: ftocstr.c + $(CC) $(CFLAGS) -c ftocstr.c + +libxdrf.o: libxdrf.m4 $(M4FILE) + $(M4) $(M4FILE) libxdrf.m4 > libxdrf.c + $(CC) $(CFLAGS) -c libxdrf.c +# rm -f libxdrf.c + diff --git a/source/unres/src_MD-DFA-restraints/xdrf/Makefile_linux b/source/unres/src_MD-DFA-restraints/xdrf/Makefile_linux new file mode 100644 index 0000000..f03276e --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/xdrf/Makefile_linux @@ -0,0 +1,27 @@ +# This make file is part of the xdrf package. +# +# (C) 1995 Frans van Hoesel, hoesel@chem.rug.nl +# +# 2006 modified by Cezary Czaplewski + +# Set C compiler and flags for ARCH +CC = cc +CFLAGS = -O + +M4 = m4 +M4FILE = underscore.m4 + +libxdrf.a: libxdrf.o ftocstr.o + ar cr libxdrf.a $? + +clean: + rm -f libxdrf.o ftocstr.o libxdrf.a + +ftocstr.o: ftocstr.c + $(CC) $(CFLAGS) -c ftocstr.c + +libxdrf.o: libxdrf.m4 $(M4FILE) + $(M4) $(M4FILE) libxdrf.m4 > libxdrf.c + $(CC) $(CFLAGS) -c libxdrf.c + rm -f libxdrf.c + diff --git a/source/unres/src_MD-DFA-restraints/xdrf/RS6K.m4 b/source/unres/src_MD-DFA-restraints/xdrf/RS6K.m4 new file mode 100644 index 0000000..0331d97 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/xdrf/RS6K.m4 @@ -0,0 +1,20 @@ +divert(-1) +undefine(`len') +# +# do nothing special to FORTRAN function names +# +define(`FUNCTION',`$1') +# +# FORTRAN character strings are passed as follows: +# a pointer to the base of the string is passed in the normal +# argument list, and the length is passed by value as an extra +# argument, after all of the other arguments. +# +define(`ARGS',`($1`'undivert(1))') +define(`SAVE',`divert(1)$1`'divert(0)') +define(`STRING_ARG',`$1_ptr`'SAVE(`, $1_len')') +define(`STRING_ARG_DECL',`char * $1_ptr; int $1_len') +define(`STRING_LEN',`$1_len') +define(`STRING_PTR',`$1_ptr') +divert(0) + diff --git a/source/unres/src_MD-DFA-restraints/xdrf/ftocstr.c b/source/unres/src_MD-DFA-restraints/xdrf/ftocstr.c new file mode 100644 index 0000000..ed2113f --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/xdrf/ftocstr.c @@ -0,0 +1,35 @@ + + +int ftocstr(ds, dl, ss, sl) + char *ds, *ss; /* dst, src ptrs */ + int dl; /* dst max len */ + int sl; /* src len */ +{ + char *p; + + for (p = ss + sl; --p >= ss && *p == ' '; ) ; + sl = p - ss + 1; + dl--; + ds[0] = 0; + if (sl > dl) + return 1; + while (sl--) + (*ds++ = *ss++); + *ds = '\0'; + return 0; +} + + +int ctofstr(ds, dl, ss) + char *ds; /* dest space */ + int dl; /* max dest length */ + char *ss; /* src string (0-term) */ +{ + while (dl && *ss) { + *ds++ = *ss++; + dl--; + } + while (dl--) + *ds++ = ' '; + return 0; +} diff --git a/source/unres/src_MD-DFA-restraints/xdrf/libxdrf.m4 b/source/unres/src_MD-DFA-restraints/xdrf/libxdrf.m4 new file mode 100644 index 0000000..a6da458 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/xdrf/libxdrf.m4 @@ -0,0 +1,1238 @@ +/*____________________________________________________________________________ + | + | libxdrf - portable fortran interface to xdr. some xdr routines + | are C routines for compressed coordinates + | + | version 1.1 + | + | This collection of routines is intended to write and read + | data in a portable way to a file, so data written on one type + | of machine can be read back on a different type. + | + | all fortran routines use an integer 'xdrid', which is an id to the + | current xdr file, and is set by xdrfopen. + | most routines have in integer 'ret' which is the return value. + | The value of 'ret' is zero on failure, and most of the time one + | on succes. + | + | There are three routines useful for C users: + | xdropen(), xdrclose(), xdr3dfcoord(). + | The first two replace xdrstdio_create and xdr_destroy, and *must* be + | used when you plan to use xdr3dfcoord(). (they are also a bit + | easier to interface). For writing data other than compressed coordinates + | you should use the standard C xdr routines (see xdr man page) + | + | xdrfopen(xdrid, filename, mode, ret) + | character *(*) filename + | character *(*) mode + | + | this will open the file with the given filename (string) + | and the given mode, it returns an id in xdrid, which is + | to be used in all other calls to xdrf routines. + | mode is 'w' to create, or update an file, for all other + | values of mode the file is opened for reading + | + | you need to call xdrfclose to flush the output and close + | the file. + | Note that you should not use xdrstdio_create, which comes with the + | standard xdr library + | + | xdrfclose(xdrid, ret) + | flush the data to the file, and closes the file; + | You should not use xdr_destroy (which comes standard with + | the xdr libraries. + | + | xdrfbool(xdrid, bp, ret) + | integer pb + | + | This filter produces values of either 1 or 0 + | + | xdrfchar(xdrid, cp, ret) + | character cp + | + | filter that translate between characters and their xdr representation + | Note that the characters in not compressed and occupies 4 bytes. + | + | xdrfdouble(xdrid, dp, ret) + | double dp + | + | read/write a double. + | + | xdrffloat(xdrid, fp, ret) + | float fp + | + | read/write a float. + | + | xdrfint(xdrid, ip, ret) + | integer ip + | + | read/write integer. + | + | xdrflong(xdrid, lp, ret) + | integer lp + | + | this routine has a possible portablility problem due to 64 bits longs. + | + | xdrfshort(xdrid, sp, ret) + | integer *2 sp + | + | xdrfstring(xdrid, sp, maxsize, ret) + | character *(*) + | integer maxsize + | + | read/write a string, with maximum length given by maxsize + | + | xdrfwrapstring(xdris, sp, ret) + | character *(*) + | + | read/write a string (it is the same as xdrfstring accept that it finds + | the stringlength itself. + | + | xdrfvector(xdrid, cp, size, xdrfproc, ret) + | character *(*) + | integer size + | external xdrfproc + | + | read/write an array pointed to by cp, with number of elements + | defined by 'size'. the routine 'xdrfproc' is the name + | of one of the above routines to read/write data (like xdrfdouble) + | In contrast with the c-version you don't need to specify the + | byte size of an element. + | xdrfstring is not allowed here (it is in the c version) + | + | xdrf3dfcoord(xdrid, fp, size, precision, ret) + | real (*) fp + | real precision + | integer size + | + | this is *NOT* a standard xdr routine. I named it this way, because + | it invites people to use the other xdr routines. + | It is introduced to store specifically 3d coordinates of molecules + | (as found in molecular dynamics) and it writes it in a compressed way. + | It starts by multiplying all numbers by precision and + | rounding the result to integer. effectively converting + | all floating point numbers to fixed point. + | it uses an algorithm for compression that is optimized for + | molecular data, but could be used for other 3d coordinates + | as well. There is subtantial overhead involved, so call this + | routine only if you have a large number of coordinates to read/write + | + | ________________________________________________________________________ + | + | Below are the routines to be used by C programmers. Use the 'normal' + | xdr routines to write integers, floats, etc (see man xdr) + | + | int xdropen(XDR *xdrs, const char *filename, const char *type) + | This will open the file with the given filename and the + | given mode. You should pass it an allocated XDR struct + | in xdrs, to be used in all other calls to xdr routines. + | Mode is 'w' to create, or update an file, and for all + | other values of mode the file is opened for reading. + | You need to call xdrclose to flush the output and close + | the file. + | + | Note that you should not use xdrstdio_create, which + | comes with the standard xdr library. + | + | int xdrclose(XDR *xdrs) + | Flush the data to the file, and close the file; + | You should not use xdr_destroy (which comes standard + | with the xdr libraries). + | + | int xdr3dfcoord(XDR *xdrs, float *fp, int *size, float *precision) + | This is \fInot\fR a standard xdr routine. I named it this + | way, because it invites people to use the other xdr + | routines. + | + | (c) 1995 Frans van Hoesel, hoesel@chem.rug.nl +*/ + + +#include +#include +#include +/* #include +#include */ +#include "xdr.h" +#include +#include +#include "xdrf.h" + +int ftocstr(char *, int, char *, int); +int ctofstr(char *, int, char *); + +#define MAXID 20 +static FILE *xdrfiles[MAXID]; +static XDR *xdridptr[MAXID]; +static char xdrmodes[MAXID]; +static unsigned int cnt; + +typedef void (* FUNCTION(xdrfproc)) (int *, void *, int *); + +void +FUNCTION(xdrfbool) ARGS(`xdrid, pb, ret') +int *xdrid, *ret; +int *pb; +{ + *ret = xdr_bool(xdridptr[*xdrid], (bool_t *) pb); + cnt += sizeof(int); +} + +void +FUNCTION(xdrfchar) ARGS(`xdrid, cp, ret') +int *xdrid, *ret; +char *cp; +{ + *ret = xdr_char(xdridptr[*xdrid], cp); + cnt += sizeof(char); +} + +void +FUNCTION(xdrfdouble) ARGS(`xdrid, dp, ret') +int *xdrid, *ret; +double *dp; +{ + *ret = xdr_double(xdridptr[*xdrid], dp); + cnt += sizeof(double); +} + +void +FUNCTION(xdrffloat) ARGS(`xdrid, fp, ret') +int *xdrid, *ret; +float *fp; +{ + *ret = xdr_float(xdridptr[*xdrid], fp); + cnt += sizeof(float); +} + +void +FUNCTION(xdrfint) ARGS(`xdrid, ip, ret') +int *xdrid, *ret; +int *ip; +{ + *ret = xdr_int(xdridptr[*xdrid], ip); + cnt += sizeof(int); +} + +void +FUNCTION(xdrflong) ARGS(`xdrid, lp, ret') +int *xdrid, *ret; +long *lp; +{ + *ret = xdr_long(xdridptr[*xdrid], lp); + cnt += sizeof(long); +} + +void +FUNCTION(xdrfshort) ARGS(`xdrid, sp, ret') +int *xdrid, *ret; +short *sp; +{ + *ret = xdr_short(xdridptr[*xdrid], sp); + cnt += sizeof(sp); +} + +void +FUNCTION(xdrfuchar) ARGS(`xdrid, ucp, ret') +int *xdrid, *ret; +char *ucp; +{ + *ret = xdr_u_char(xdridptr[*xdrid], ucp); + cnt += sizeof(char); +} + +void +FUNCTION(xdrfulong) ARGS(`xdrid, ulp, ret') +int *xdrid, *ret; +unsigned long *ulp; +{ + *ret = xdr_u_long(xdridptr[*xdrid], ulp); + cnt += sizeof(unsigned long); +} + +void +FUNCTION(xdrfushort) ARGS(`xdrid, usp, ret') +int *xdrid, *ret; +unsigned short *usp; +{ + *ret = xdr_u_short(xdridptr[*xdrid], usp); + cnt += sizeof(unsigned short); +} + +void +FUNCTION(xdrf3dfcoord) ARGS(`xdrid, fp, size, precision, ret') +int *xdrid, *ret; +float *fp; +int *size; +float *precision; +{ + *ret = xdr3dfcoord(xdridptr[*xdrid], fp, size, precision); +} + +void +FUNCTION(xdrfstring) ARGS(`xdrid, STRING_ARG(sp), maxsize, ret') +int *xdrid, *ret; +STRING_ARG_DECL(sp); +int *maxsize; +{ + char *tsp; + + tsp = (char*) malloc(((STRING_LEN(sp)) + 1) * sizeof(char)); + if (tsp == NULL) { + *ret = -1; + return; + } + if (ftocstr(tsp, *maxsize+1, STRING_PTR(sp), STRING_LEN(sp))) { + *ret = -1; + free(tsp); + return; + } + *ret = xdr_string(xdridptr[*xdrid], (char **) &tsp, (u_int) *maxsize); + ctofstr( STRING_PTR(sp), STRING_LEN(sp), tsp); + cnt += *maxsize; + free(tsp); +} + +void +FUNCTION(xdrfwrapstring) ARGS(`xdrid, STRING_ARG(sp), ret') +int *xdrid, *ret; +STRING_ARG_DECL(sp); +{ + char *tsp; + int maxsize; + maxsize = (STRING_LEN(sp)) + 1; + tsp = (char*) malloc(maxsize * sizeof(char)); + if (tsp == NULL) { + *ret = -1; + return; + } + if (ftocstr(tsp, maxsize, STRING_PTR(sp), STRING_LEN(sp))) { + *ret = -1; + free(tsp); + return; + } + *ret = xdr_string(xdridptr[*xdrid], (char **) &tsp, (u_int)maxsize); + ctofstr( STRING_PTR(sp), STRING_LEN(sp), tsp); + cnt += maxsize; + free(tsp); +} + +void +FUNCTION(xdrfopaque) ARGS(`xdrid, cp, ccnt, ret') +int *xdrid, *ret; +caddr_t *cp; +int *ccnt; +{ + *ret = xdr_opaque(xdridptr[*xdrid], (caddr_t)*cp, (u_int)*ccnt); + cnt += *ccnt; +} + +void +FUNCTION(xdrfsetpos) ARGS(`xdrid, pos, ret') +int *xdrid, *ret; +int *pos; +{ + *ret = xdr_setpos(xdridptr[*xdrid], (u_int) *pos); +} + +void +FUNCTION(xdrf) ARGS(`xdrid, pos') +int *xdrid, *pos; +{ + *pos = xdr_getpos(xdridptr[*xdrid]); +} + +void +FUNCTION(xdrfvector) ARGS(`xdrid, cp, size, elproc, ret') +int *xdrid, *ret; +char *cp; +int *size; +FUNCTION(xdrfproc) elproc; +{ + int lcnt; + cnt = 0; + for (lcnt = 0; lcnt < *size; lcnt++) { + elproc(xdrid, (cp+cnt) , ret); + } +} + + +void +FUNCTION(xdrfclose) ARGS(`xdrid, ret') +int *xdrid; +int *ret; +{ + *ret = xdrclose(xdridptr[*xdrid]); + cnt = 0; +} + +void +FUNCTION(xdrfopen) ARGS(`xdrid, STRING_ARG(fp), STRING_ARG(mode), ret') +int *xdrid; +STRING_ARG_DECL(fp); +STRING_ARG_DECL(mode); +int *ret; +{ + char fname[512]; + char fmode[3]; + + if (ftocstr(fname, sizeof(fname), STRING_PTR(fp), STRING_LEN(fp))) { + *ret = 0; + } + if (ftocstr(fmode, sizeof(fmode), STRING_PTR(mode), + STRING_LEN(mode))) { + *ret = 0; + } + + *xdrid = xdropen(NULL, fname, fmode); + if (*xdrid == 0) + *ret = 0; + else + *ret = 1; +} + +/*___________________________________________________________________________ + | + | what follows are the C routines for opening, closing xdr streams + | and the routine to read/write compressed coordinates together + | with some routines to assist in this task (those are marked + | static and cannot be called from user programs) +*/ +#define MAXABS INT_MAX-2 + +#ifndef MIN +#define MIN(x,y) ((x) < (y) ? (x):(y)) +#endif +#ifndef MAX +#define MAX(x,y) ((x) > (y) ? (x):(y)) +#endif +#ifndef SQR +#define SQR(x) ((x)*(x)) +#endif +static int magicints[] = { + 0, 0, 0, 0, 0, 0, 0, 0, 0, + 8, 10, 12, 16, 20, 25, 32, 40, 50, 64, + 80, 101, 128, 161, 203, 256, 322, 406, 512, 645, + 812, 1024, 1290, 1625, 2048, 2580, 3250, 4096, 5060, 6501, + 8192, 10321, 13003, 16384, 20642, 26007, 32768, 41285, 52015, 65536, + 82570, 104031, 131072, 165140, 208063, 262144, 330280, 416127, 524287, 660561, + 832255, 1048576, 1321122, 1664510, 2097152, 2642245, 3329021, 4194304, 5284491, 6658042, + 8388607, 10568983, 13316085, 16777216 }; + +#define FIRSTIDX 9 +/* note that magicints[FIRSTIDX-1] == 0 */ +#define LASTIDX (sizeof(magicints) / sizeof(*magicints)) + + +/*__________________________________________________________________________ + | + | xdropen - open xdr file + | + | This versions differs from xdrstdio_create, because I need to know + | the state of the file (read or write) so I can use xdr3dfcoord + | in eigther read or write mode, and the file descriptor + | so I can close the file (something xdr_destroy doesn't do). + | +*/ + +int xdropen(XDR *xdrs, const char *filename, const char *type) { + static int init_done = 0; + enum xdr_op lmode; + const char *type1; + int xdrid; + + if (init_done == 0) { + for (xdrid = 1; xdrid < MAXID; xdrid++) { + xdridptr[xdrid] = NULL; + } + init_done = 1; + } + xdrid = 1; + while (xdrid < MAXID && xdridptr[xdrid] != NULL) { + xdrid++; + } + if (xdrid == MAXID) { + return 0; + } + if (*type == 'w' || *type == 'W') { + type = "w+"; + type1 = "w+"; + lmode = XDR_ENCODE; + } else if (*type == 'a' || *type == 'A') { + type = "w+"; + type1 = "a+"; + lmode = XDR_ENCODE; + } else { + type = "r"; + type1 = "r"; + lmode = XDR_DECODE; + } + xdrfiles[xdrid] = fopen(filename, type1); + if (xdrfiles[xdrid] == NULL) { + xdrs = NULL; + return 0; + } + xdrmodes[xdrid] = *type; + /* next test isn't usefull in the case of C language + * but is used for the Fortran interface + * (C users are expected to pass the address of an already allocated + * XDR staructure) + */ + if (xdrs == NULL) { + xdridptr[xdrid] = (XDR *) malloc(sizeof(XDR)); + xdrstdio_create(xdridptr[xdrid], xdrfiles[xdrid], lmode); + } else { + xdridptr[xdrid] = xdrs; + xdrstdio_create(xdrs, xdrfiles[xdrid], lmode); + } + return xdrid; +} + +/*_________________________________________________________________________ + | + | xdrclose - close a xdr file + | + | This will flush the xdr buffers, and destroy the xdr stream. + | It also closes the associated file descriptor (this is *not* + | done by xdr_destroy). + | +*/ + +int xdrclose(XDR *xdrs) { + int xdrid; + + if (xdrs == NULL) { + fprintf(stderr, "xdrclose: passed a NULL pointer\n"); + exit(1); + } + for (xdrid = 1; xdrid < MAXID; xdrid++) { + if (xdridptr[xdrid] == xdrs) { + + xdr_destroy(xdrs); + fclose(xdrfiles[xdrid]); + xdridptr[xdrid] = NULL; + return 1; + } + } + fprintf(stderr, "xdrclose: no such open xdr file\n"); + exit(1); + +} + +/*____________________________________________________________________________ + | + | sendbits - encode num into buf using the specified number of bits + | + | This routines appends the value of num to the bits already present in + | the array buf. You need to give it the number of bits to use and you + | better make sure that this number of bits is enough to hold the value + | Also num must be positive. + | +*/ + +static void sendbits(int buf[], int num_of_bits, int num) { + + unsigned int cnt, lastbyte; + int lastbits; + unsigned char * cbuf; + + cbuf = ((unsigned char *)buf) + 3 * sizeof(*buf); + cnt = (unsigned int) buf[0]; + lastbits = buf[1]; + lastbyte =(unsigned int) buf[2]; + while (num_of_bits >= 8) { + lastbyte = (lastbyte << 8) | ((num >> (num_of_bits -8)) /* & 0xff*/); + cbuf[cnt++] = lastbyte >> lastbits; + num_of_bits -= 8; + } + if (num_of_bits > 0) { + lastbyte = (lastbyte << num_of_bits) | num; + lastbits += num_of_bits; + if (lastbits >= 8) { + lastbits -= 8; + cbuf[cnt++] = lastbyte >> lastbits; + } + } + buf[0] = cnt; + buf[1] = lastbits; + buf[2] = lastbyte; + if (lastbits>0) { + cbuf[cnt] = lastbyte << (8 - lastbits); + } +} + +/*_________________________________________________________________________ + | + | sizeofint - calculate bitsize of an integer + | + | return the number of bits needed to store an integer with given max size + | +*/ + +static int sizeofint(const int size) { + unsigned int num = 1; + int num_of_bits = 0; + + while (size >= num && num_of_bits < 32) { + num_of_bits++; + num <<= 1; + } + return num_of_bits; +} + +/*___________________________________________________________________________ + | + | sizeofints - calculate 'bitsize' of compressed ints + | + | given the number of small unsigned integers and the maximum value + | return the number of bits needed to read or write them with the + | routines receiveints and sendints. You need this parameter when + | calling these routines. Note that for many calls I can use + | the variable 'smallidx' which is exactly the number of bits, and + | So I don't need to call 'sizeofints for those calls. +*/ + +static int sizeofints( const int num_of_ints, unsigned int sizes[]) { + int i, num; + unsigned int num_of_bytes, num_of_bits, bytes[32], bytecnt, tmp; + num_of_bytes = 1; + bytes[0] = 1; + num_of_bits = 0; + for (i=0; i < num_of_ints; i++) { + tmp = 0; + for (bytecnt = 0; bytecnt < num_of_bytes; bytecnt++) { + tmp = bytes[bytecnt] * sizes[i] + tmp; + bytes[bytecnt] = tmp & 0xff; + tmp >>= 8; + } + while (tmp != 0) { + bytes[bytecnt++] = tmp & 0xff; + tmp >>= 8; + } + num_of_bytes = bytecnt; + } + num = 1; + num_of_bytes--; + while (bytes[num_of_bytes] >= num) { + num_of_bits++; + num *= 2; + } + return num_of_bits + num_of_bytes * 8; + +} + +/*____________________________________________________________________________ + | + | sendints - send a small set of small integers in compressed format + | + | this routine is used internally by xdr3dfcoord, to send a set of + | small integers to the buffer. + | Multiplication with fixed (specified maximum ) sizes is used to get + | to one big, multibyte integer. Allthough the routine could be + | modified to handle sizes bigger than 16777216, or more than just + | a few integers, this is not done, because the gain in compression + | isn't worth the effort. Note that overflowing the multiplication + | or the byte buffer (32 bytes) is unchecked and causes bad results. + | + */ + +static void sendints(int buf[], const int num_of_ints, const int num_of_bits, + unsigned int sizes[], unsigned int nums[]) { + + int i; + unsigned int bytes[32], num_of_bytes, bytecnt, tmp; + + tmp = nums[0]; + num_of_bytes = 0; + do { + bytes[num_of_bytes++] = tmp & 0xff; + tmp >>= 8; + } while (tmp != 0); + + for (i = 1; i < num_of_ints; i++) { + if (nums[i] >= sizes[i]) { + fprintf(stderr,"major breakdown in sendints num %d doesn't " + "match size %d\n", nums[i], sizes[i]); + exit(1); + } + /* use one step multiply */ + tmp = nums[i]; + for (bytecnt = 0; bytecnt < num_of_bytes; bytecnt++) { + tmp = bytes[bytecnt] * sizes[i] + tmp; + bytes[bytecnt] = tmp & 0xff; + tmp >>= 8; + } + while (tmp != 0) { + bytes[bytecnt++] = tmp & 0xff; + tmp >>= 8; + } + num_of_bytes = bytecnt; + } + if (num_of_bits >= num_of_bytes * 8) { + for (i = 0; i < num_of_bytes; i++) { + sendbits(buf, 8, bytes[i]); + } + sendbits(buf, num_of_bits - num_of_bytes * 8, 0); + } else { + for (i = 0; i < num_of_bytes-1; i++) { + sendbits(buf, 8, bytes[i]); + } + sendbits(buf, num_of_bits- (num_of_bytes -1) * 8, bytes[i]); + } +} + + +/*___________________________________________________________________________ + | + | receivebits - decode number from buf using specified number of bits + | + | extract the number of bits from the array buf and construct an integer + | from it. Return that value. + | +*/ + +static int receivebits(int buf[], int num_of_bits) { + + int cnt, num; + unsigned int lastbits, lastbyte; + unsigned char * cbuf; + int mask = (1 << num_of_bits) -1; + + cbuf = ((unsigned char *)buf) + 3 * sizeof(*buf); + cnt = buf[0]; + lastbits = (unsigned int) buf[1]; + lastbyte = (unsigned int) buf[2]; + + num = 0; + while (num_of_bits >= 8) { + lastbyte = ( lastbyte << 8 ) | cbuf[cnt++]; + num |= (lastbyte >> lastbits) << (num_of_bits - 8); + num_of_bits -=8; + } + if (num_of_bits > 0) { + if (lastbits < num_of_bits) { + lastbits += 8; + lastbyte = (lastbyte << 8) | cbuf[cnt++]; + } + lastbits -= num_of_bits; + num |= (lastbyte >> lastbits) & ((1 << num_of_bits) -1); + } + num &= mask; + buf[0] = cnt; + buf[1] = lastbits; + buf[2] = lastbyte; + return num; +} + +/*____________________________________________________________________________ + | + | receiveints - decode 'small' integers from the buf array + | + | this routine is the inverse from sendints() and decodes the small integers + | written to buf by calculating the remainder and doing divisions with + | the given sizes[]. You need to specify the total number of bits to be + | used from buf in num_of_bits. + | +*/ + +static void receiveints(int buf[], const int num_of_ints, int num_of_bits, + unsigned int sizes[], int nums[]) { + int bytes[32]; + int i, j, num_of_bytes, p, num; + + bytes[1] = bytes[2] = bytes[3] = 0; + num_of_bytes = 0; + while (num_of_bits > 8) { + bytes[num_of_bytes++] = receivebits(buf, 8); + num_of_bits -= 8; + } + if (num_of_bits > 0) { + bytes[num_of_bytes++] = receivebits(buf, num_of_bits); + } + for (i = num_of_ints-1; i > 0; i--) { + num = 0; + for (j = num_of_bytes-1; j >=0; j--) { + num = (num << 8) | bytes[j]; + p = num / sizes[i]; + bytes[j] = p; + num = num - p * sizes[i]; + } + nums[i] = num; + } + nums[0] = bytes[0] | (bytes[1] << 8) | (bytes[2] << 16) | (bytes[3] << 24); +} + +/*____________________________________________________________________________ + | + | xdr3dfcoord - read or write compressed 3d coordinates to xdr file. + | + | this routine reads or writes (depending on how you opened the file with + | xdropen() ) a large number of 3d coordinates (stored in *fp). + | The number of coordinates triplets to write is given by *size. On + | read this number may be zero, in which case it reads as many as were written + | or it may specify the number if triplets to read (which should match the + | number written). + | Compression is achieved by first converting all floating numbers to integer + | using multiplication by *precision and rounding to the nearest integer. + | Then the minimum and maximum value are calculated to determine the range. + | The limited range of integers so found, is used to compress the coordinates. + | In addition the differences between succesive coordinates is calculated. + | If the difference happens to be 'small' then only the difference is saved, + | compressing the data even more. The notion of 'small' is changed dynamically + | and is enlarged or reduced whenever needed or possible. + | Extra compression is achieved in the case of GROMOS and coordinates of + | water molecules. GROMOS first writes out the Oxygen position, followed by + | the two hydrogens. In order to make the differences smaller (and thereby + | compression the data better) the order is changed into first one hydrogen + | then the oxygen, followed by the other hydrogen. This is rather special, but + | it shouldn't harm in the general case. + | + */ + +int xdr3dfcoord(XDR *xdrs, float *fp, int *size, float *precision) { + + + static int *ip = NULL; + static int oldsize; + static int *buf; + + int minint[3], maxint[3], mindiff, *lip, diff; + int lint1, lint2, lint3, oldlint1, oldlint2, oldlint3, smallidx; + int minidx, maxidx; + unsigned sizeint[3], sizesmall[3], bitsizeint[3], size3, *luip; + int flag, k; + int small, smaller, larger, i, is_small, is_smaller, run, prevrun; + float *lfp, lf; + int tmp, *thiscoord, prevcoord[3]; + unsigned int tmpcoord[30]; + + int bufsize, xdrid, lsize; + unsigned int bitsize; + float inv_precision; + int errval = 1; + + /* find out if xdrs is opened for reading or for writing */ + xdrid = 0; + while (xdridptr[xdrid] != xdrs) { + xdrid++; + if (xdrid >= MAXID) { + fprintf(stderr, "xdr error. no open xdr stream\n"); + exit (1); + } + } + if (xdrmodes[xdrid] == 'w') { + + /* xdrs is open for writing */ + + if (xdr_int(xdrs, size) == 0) + return 0; + size3 = *size * 3; + /* when the number of coordinates is small, don't try to compress; just + * write them as floats using xdr_vector + */ + if (*size <= 9 ) { + return (xdr_vector(xdrs, (char *) fp, size3, sizeof(*fp), + (xdrproc_t)xdr_float)); + } + + xdr_float(xdrs, precision); + if (ip == NULL) { + ip = (int *)malloc(size3 * sizeof(*ip)); + if (ip == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + bufsize = size3 * 1.2; + buf = (int *)malloc(bufsize * sizeof(*buf)); + if (buf == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + oldsize = *size; + } else if (*size > oldsize) { + ip = (int *)realloc(ip, size3 * sizeof(*ip)); + if (ip == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + bufsize = size3 * 1.2; + buf = (int *)realloc(buf, bufsize * sizeof(*buf)); + if (buf == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + oldsize = *size; + } + /* buf[0-2] are special and do not contain actual data */ + buf[0] = buf[1] = buf[2] = 0; + minint[0] = minint[1] = minint[2] = INT_MAX; + maxint[0] = maxint[1] = maxint[2] = INT_MIN; + prevrun = -1; + lfp = fp; + lip = ip; + mindiff = INT_MAX; + oldlint1 = oldlint2 = oldlint3 = 0; + while(lfp < fp + size3 ) { + /* find nearest integer */ + if (*lfp >= 0.0) + lf = *lfp * *precision + 0.5; + else + lf = *lfp * *precision - 0.5; + if (fabs(lf) > MAXABS) { + /* scaling would cause overflow */ + errval = 0; + } + lint1 = lf; + if (lint1 < minint[0]) minint[0] = lint1; + if (lint1 > maxint[0]) maxint[0] = lint1; + *lip++ = lint1; + lfp++; + if (*lfp >= 0.0) + lf = *lfp * *precision + 0.5; + else + lf = *lfp * *precision - 0.5; + if (fabs(lf) > MAXABS) { + /* scaling would cause overflow */ + errval = 0; + } + lint2 = lf; + if (lint2 < minint[1]) minint[1] = lint2; + if (lint2 > maxint[1]) maxint[1] = lint2; + *lip++ = lint2; + lfp++; + if (*lfp >= 0.0) + lf = *lfp * *precision + 0.5; + else + lf = *lfp * *precision - 0.5; + if (fabs(lf) > MAXABS) { + /* scaling would cause overflow */ + errval = 0; + } + lint3 = lf; + if (lint3 < minint[2]) minint[2] = lint3; + if (lint3 > maxint[2]) maxint[2] = lint3; + *lip++ = lint3; + lfp++; + diff = abs(oldlint1-lint1)+abs(oldlint2-lint2)+abs(oldlint3-lint3); + if (diff < mindiff && lfp > fp + 3) + mindiff = diff; + oldlint1 = lint1; + oldlint2 = lint2; + oldlint3 = lint3; + } + xdr_int(xdrs, &(minint[0])); + xdr_int(xdrs, &(minint[1])); + xdr_int(xdrs, &(minint[2])); + + xdr_int(xdrs, &(maxint[0])); + xdr_int(xdrs, &(maxint[1])); + xdr_int(xdrs, &(maxint[2])); + + if ((float)maxint[0] - (float)minint[0] >= MAXABS || + (float)maxint[1] - (float)minint[1] >= MAXABS || + (float)maxint[2] - (float)minint[2] >= MAXABS) { + /* turning value in unsigned by subtracting minint + * would cause overflow + */ + errval = 0; + } + sizeint[0] = maxint[0] - minint[0]+1; + sizeint[1] = maxint[1] - minint[1]+1; + sizeint[2] = maxint[2] - minint[2]+1; + + /* check if one of the sizes is to big to be multiplied */ + if ((sizeint[0] | sizeint[1] | sizeint[2] ) > 0xffffff) { + bitsizeint[0] = sizeofint(sizeint[0]); + bitsizeint[1] = sizeofint(sizeint[1]); + bitsizeint[2] = sizeofint(sizeint[2]); + bitsize = 0; /* flag the use of large sizes */ + } else { + bitsize = sizeofints(3, sizeint); + } + lip = ip; + luip = (unsigned int *) ip; + smallidx = FIRSTIDX; + while (smallidx < LASTIDX && magicints[smallidx] < mindiff) { + smallidx++; + } + xdr_int(xdrs, &smallidx); + maxidx = MIN(LASTIDX, smallidx + 8) ; + minidx = maxidx - 8; /* often this equal smallidx */ + smaller = magicints[MAX(FIRSTIDX, smallidx-1)] / 2; + small = magicints[smallidx] / 2; + sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx]; + larger = magicints[maxidx] / 2; + i = 0; + while (i < *size) { + is_small = 0; + thiscoord = (int *)(luip) + i * 3; + if (smallidx < maxidx && i >= 1 && + abs(thiscoord[0] - prevcoord[0]) < larger && + abs(thiscoord[1] - prevcoord[1]) < larger && + abs(thiscoord[2] - prevcoord[2]) < larger) { + is_smaller = 1; + } else if (smallidx > minidx) { + is_smaller = -1; + } else { + is_smaller = 0; + } + if (i + 1 < *size) { + if (abs(thiscoord[0] - thiscoord[3]) < small && + abs(thiscoord[1] - thiscoord[4]) < small && + abs(thiscoord[2] - thiscoord[5]) < small) { + /* interchange first with second atom for better + * compression of water molecules + */ + tmp = thiscoord[0]; thiscoord[0] = thiscoord[3]; + thiscoord[3] = tmp; + tmp = thiscoord[1]; thiscoord[1] = thiscoord[4]; + thiscoord[4] = tmp; + tmp = thiscoord[2]; thiscoord[2] = thiscoord[5]; + thiscoord[5] = tmp; + is_small = 1; + } + + } + tmpcoord[0] = thiscoord[0] - minint[0]; + tmpcoord[1] = thiscoord[1] - minint[1]; + tmpcoord[2] = thiscoord[2] - minint[2]; + if (bitsize == 0) { + sendbits(buf, bitsizeint[0], tmpcoord[0]); + sendbits(buf, bitsizeint[1], tmpcoord[1]); + sendbits(buf, bitsizeint[2], tmpcoord[2]); + } else { + sendints(buf, 3, bitsize, sizeint, tmpcoord); + } + prevcoord[0] = thiscoord[0]; + prevcoord[1] = thiscoord[1]; + prevcoord[2] = thiscoord[2]; + thiscoord = thiscoord + 3; + i++; + + run = 0; + if (is_small == 0 && is_smaller == -1) + is_smaller = 0; + while (is_small && run < 8*3) { + if (is_smaller == -1 && ( + SQR(thiscoord[0] - prevcoord[0]) + + SQR(thiscoord[1] - prevcoord[1]) + + SQR(thiscoord[2] - prevcoord[2]) >= smaller * smaller)) { + is_smaller = 0; + } + + tmpcoord[run++] = thiscoord[0] - prevcoord[0] + small; + tmpcoord[run++] = thiscoord[1] - prevcoord[1] + small; + tmpcoord[run++] = thiscoord[2] - prevcoord[2] + small; + + prevcoord[0] = thiscoord[0]; + prevcoord[1] = thiscoord[1]; + prevcoord[2] = thiscoord[2]; + + i++; + thiscoord = thiscoord + 3; + is_small = 0; + if (i < *size && + abs(thiscoord[0] - prevcoord[0]) < small && + abs(thiscoord[1] - prevcoord[1]) < small && + abs(thiscoord[2] - prevcoord[2]) < small) { + is_small = 1; + } + } + if (run != prevrun || is_smaller != 0) { + prevrun = run; + sendbits(buf, 1, 1); /* flag the change in run-length */ + sendbits(buf, 5, run+is_smaller+1); + } else { + sendbits(buf, 1, 0); /* flag the fact that runlength did not change */ + } + for (k=0; k < run; k+=3) { + sendints(buf, 3, smallidx, sizesmall, &tmpcoord[k]); + } + if (is_smaller != 0) { + smallidx += is_smaller; + if (is_smaller < 0) { + small = smaller; + smaller = magicints[smallidx-1] / 2; + } else { + smaller = small; + small = magicints[smallidx] / 2; + } + sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx]; + } + } + if (buf[1] != 0) buf[0]++;; + xdr_int(xdrs, &(buf[0])); /* buf[0] holds the length in bytes */ + return errval * (xdr_opaque(xdrs, (caddr_t)&(buf[3]), (u_int)buf[0])); + } else { + + /* xdrs is open for reading */ + + if (xdr_int(xdrs, &lsize) == 0) + return 0; + if (*size != 0 && lsize != *size) { + fprintf(stderr, "wrong number of coordinates in xdr3dfcoor; " + "%d arg vs %d in file", *size, lsize); + } + *size = lsize; + size3 = *size * 3; + if (*size <= 9) { + return (xdr_vector(xdrs, (char *) fp, size3, sizeof(*fp), + (xdrproc_t)xdr_float)); + } + xdr_float(xdrs, precision); + if (ip == NULL) { + ip = (int *)malloc(size3 * sizeof(*ip)); + if (ip == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + bufsize = size3 * 1.2; + buf = (int *)malloc(bufsize * sizeof(*buf)); + if (buf == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + oldsize = *size; + } else if (*size > oldsize) { + ip = (int *)realloc(ip, size3 * sizeof(*ip)); + if (ip == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + bufsize = size3 * 1.2; + buf = (int *)realloc(buf, bufsize * sizeof(*buf)); + if (buf == NULL) { + fprintf(stderr,"malloc failed\n"); + exit(1); + } + oldsize = *size; + } + buf[0] = buf[1] = buf[2] = 0; + + xdr_int(xdrs, &(minint[0])); + xdr_int(xdrs, &(minint[1])); + xdr_int(xdrs, &(minint[2])); + + xdr_int(xdrs, &(maxint[0])); + xdr_int(xdrs, &(maxint[1])); + xdr_int(xdrs, &(maxint[2])); + + sizeint[0] = maxint[0] - minint[0]+1; + sizeint[1] = maxint[1] - minint[1]+1; + sizeint[2] = maxint[2] - minint[2]+1; + + /* check if one of the sizes is to big to be multiplied */ + if ((sizeint[0] | sizeint[1] | sizeint[2] ) > 0xffffff) { + bitsizeint[0] = sizeofint(sizeint[0]); + bitsizeint[1] = sizeofint(sizeint[1]); + bitsizeint[2] = sizeofint(sizeint[2]); + bitsize = 0; /* flag the use of large sizes */ + } else { + bitsize = sizeofints(3, sizeint); + } + + xdr_int(xdrs, &smallidx); + maxidx = MIN(LASTIDX, smallidx + 8) ; + minidx = maxidx - 8; /* often this equal smallidx */ + smaller = magicints[MAX(FIRSTIDX, smallidx-1)] / 2; + small = magicints[smallidx] / 2; + sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx] ; + larger = magicints[maxidx]; + + /* buf[0] holds the length in bytes */ + + if (xdr_int(xdrs, &(buf[0])) == 0) + return 0; + if (xdr_opaque(xdrs, (caddr_t)&(buf[3]), (u_int)buf[0]) == 0) + return 0; + buf[0] = buf[1] = buf[2] = 0; + + lfp = fp; + inv_precision = 1.0 / * precision; + run = 0; + i = 0; + lip = ip; + while ( i < lsize ) { + thiscoord = (int *)(lip) + i * 3; + + if (bitsize == 0) { + thiscoord[0] = receivebits(buf, bitsizeint[0]); + thiscoord[1] = receivebits(buf, bitsizeint[1]); + thiscoord[2] = receivebits(buf, bitsizeint[2]); + } else { + receiveints(buf, 3, bitsize, sizeint, thiscoord); + } + + i++; + thiscoord[0] += minint[0]; + thiscoord[1] += minint[1]; + thiscoord[2] += minint[2]; + + prevcoord[0] = thiscoord[0]; + prevcoord[1] = thiscoord[1]; + prevcoord[2] = thiscoord[2]; + + + flag = receivebits(buf, 1); + is_smaller = 0; + if (flag == 1) { + run = receivebits(buf, 5); + is_smaller = run % 3; + run -= is_smaller; + is_smaller--; + } + if (run > 0) { + thiscoord += 3; + for (k = 0; k < run; k+=3) { + receiveints(buf, 3, smallidx, sizesmall, thiscoord); + i++; + thiscoord[0] += prevcoord[0] - small; + thiscoord[1] += prevcoord[1] - small; + thiscoord[2] += prevcoord[2] - small; + if (k == 0) { + /* interchange first with second atom for better + * compression of water molecules + */ + tmp = thiscoord[0]; thiscoord[0] = prevcoord[0]; + prevcoord[0] = tmp; + tmp = thiscoord[1]; thiscoord[1] = prevcoord[1]; + prevcoord[1] = tmp; + tmp = thiscoord[2]; thiscoord[2] = prevcoord[2]; + prevcoord[2] = tmp; + *lfp++ = prevcoord[0] * inv_precision; + *lfp++ = prevcoord[1] * inv_precision; + *lfp++ = prevcoord[2] * inv_precision; + } else { + prevcoord[0] = thiscoord[0]; + prevcoord[1] = thiscoord[1]; + prevcoord[2] = thiscoord[2]; + } + *lfp++ = thiscoord[0] * inv_precision; + *lfp++ = thiscoord[1] * inv_precision; + *lfp++ = thiscoord[2] * inv_precision; + } + } else { + *lfp++ = thiscoord[0] * inv_precision; + *lfp++ = thiscoord[1] * inv_precision; + *lfp++ = thiscoord[2] * inv_precision; + } + smallidx += is_smaller; + if (is_smaller < 0) { + small = smaller; + if (smallidx > FIRSTIDX) { + smaller = magicints[smallidx - 1] /2; + } else { + smaller = 0; + } + } else if (is_smaller > 0) { + smaller = small; + small = magicints[smallidx] / 2; + } + sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx] ; + } + } + return 1; +} + + + diff --git a/source/unres/src_MD-DFA-restraints/xdrf/types.h b/source/unres/src_MD-DFA-restraints/xdrf/types.h new file mode 100644 index 0000000..871f3fd --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/xdrf/types.h @@ -0,0 +1,99 @@ +/* + * Sun RPC is a product of Sun Microsystems, Inc. and is provided for + * unrestricted use provided that this legend is included on all tape + * media and as a part of the software program in whole or part. Users + * may copy or modify Sun RPC without charge, but are not authorized + * to license or distribute it to anyone else except as part of a product or + * program developed by the user. + * + * SUN RPC IS PROVIDED AS IS WITH NO WARRANTIES OF ANY KIND INCLUDING THE + * WARRANTIES OF DESIGN, MERCHANTIBILITY AND FITNESS FOR A PARTICULAR + * PURPOSE, OR ARISING FROM A COURSE OF DEALING, USAGE OR TRADE PRACTICE. + * + * Sun RPC is provided with no support and without any obligation on the + * part of Sun Microsystems, Inc. to assist in its use, correction, + * modification or enhancement. + * + * SUN MICROSYSTEMS, INC. SHALL HAVE NO LIABILITY WITH RESPECT TO THE + * INFRINGEMENT OF COPYRIGHTS, TRADE SECRETS OR ANY PATENTS BY SUN RPC + * OR ANY PART THEREOF. + * + * In no event will Sun Microsystems, Inc. be liable for any lost revenue + * or profits or other special, indirect and consequential damages, even if + * Sun has been advised of the possibility of such damages. + * + * Sun Microsystems, Inc. + * 2550 Garcia Avenue + * Mountain View, California 94043 + */ +/* fixincludes should not add extern "C" to this file */ +/* + * Rpc additions to + */ +#ifndef _RPC_TYPES_H +#define _RPC_TYPES_H 1 + +typedef int bool_t; +typedef int enum_t; +/* This needs to be changed to uint32_t in the future */ +typedef unsigned long rpcprog_t; +typedef unsigned long rpcvers_t; +typedef unsigned long rpcproc_t; +typedef unsigned long rpcprot_t; +typedef unsigned long rpcport_t; + +#define __dontcare__ -1 + +#ifndef FALSE +# define FALSE (0) +#endif + +#ifndef TRUE +# define TRUE (1) +#endif + +#ifndef NULL +# define NULL 0 +#endif + +#include /* For malloc decl. */ +#define mem_alloc(bsize) malloc(bsize) +/* + * XXX: This must not use the second argument, or code in xdr_array.c needs + * to be modified. + */ +#define mem_free(ptr, bsize) free(ptr) + +#ifndef makedev /* ie, we haven't already included it */ +#include +#endif + +#ifndef __u_char_defined +typedef __u_char u_char; +typedef __u_short u_short; +typedef __u_int u_int; +typedef __u_long u_long; +typedef __quad_t quad_t; +typedef __u_quad_t u_quad_t; +typedef __fsid_t fsid_t; +# define __u_char_defined +#endif +#ifndef __daddr_t_defined +typedef __daddr_t daddr_t; +typedef __caddr_t caddr_t; +# define __daddr_t_defined +#endif + +#include +#include + +#include + +#ifndef INADDR_LOOPBACK +#define INADDR_LOOPBACK (u_long)0x7F000001 +#endif +#ifndef MAXHOSTNAMELEN +#define MAXHOSTNAMELEN 64 +#endif + +#endif /* rpc/types.h */ diff --git a/source/unres/src_MD-DFA-restraints/xdrf/underscore.m4 b/source/unres/src_MD-DFA-restraints/xdrf/underscore.m4 new file mode 100644 index 0000000..4d620a0 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/xdrf/underscore.m4 @@ -0,0 +1,19 @@ +divert(-1) +undefine(`len') +# +# append an underscore to FORTRAN function names +# +define(`FUNCTION',`$1_') +# +# FORTRAN character strings are passed as follows: +# a pointer to the base of the string is passed in the normal +# argument list, and the length is passed by value as an extra +# argument, after all of the other arguments. +# +define(`ARGS',`($1`'undivert(1))') +define(`SAVE',`divert(1)$1`'divert(0)') +define(`STRING_ARG',`$1_ptr`'SAVE(`, $1_len')') +define(`STRING_ARG_DECL',`char * $1_ptr; int $1_len') +define(`STRING_LEN',`$1_len') +define(`STRING_PTR',`$1_ptr') +divert(0) diff --git a/source/unres/src_MD-DFA-restraints/xdrf/xdr.c b/source/unres/src_MD-DFA-restraints/xdrf/xdr.c new file mode 100644 index 0000000..33b8544 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/xdrf/xdr.c @@ -0,0 +1,752 @@ +# define INTUSE(name) name +# define INTDEF(name) +/* @(#)xdr.c 2.1 88/07/29 4.0 RPCSRC */ +/* + * Sun RPC is a product of Sun Microsystems, Inc. and is provided for + * unrestricted use provided that this legend is included on all tape + * media and as a part of the software program in whole or part. Users + * may copy or modify Sun RPC without charge, but are not authorized + * to license or distribute it to anyone else except as part of a product or + * program developed by the user. + * + * SUN RPC IS PROVIDED AS IS WITH NO WARRANTIES OF ANY KIND INCLUDING THE + * WARRANTIES OF DESIGN, MERCHANTIBILITY AND FITNESS FOR A PARTICULAR + * PURPOSE, OR ARISING FROM A COURSE OF DEALING, USAGE OR TRADE PRACTICE. + * + * Sun RPC is provided with no support and without any obligation on the + * part of Sun Microsystems, Inc. to assist in its use, correction, + * modification or enhancement. + * + * SUN MICROSYSTEMS, INC. SHALL HAVE NO LIABILITY WITH RESPECT TO THE + * INFRINGEMENT OF COPYRIGHTS, TRADE SECRETS OR ANY PATENTS BY SUN RPC + * OR ANY PART THEREOF. + * + * In no event will Sun Microsystems, Inc. be liable for any lost revenue + * or profits or other special, indirect and consequential damages, even if + * Sun has been advised of the possibility of such damages. + * + * Sun Microsystems, Inc. + * 2550 Garcia Avenue + * Mountain View, California 94043 + */ +#if !defined(lint) && defined(SCCSIDS) +static char sccsid[] = "@(#)xdr.c 1.35 87/08/12"; +#endif + +/* + * xdr.c, Generic XDR routines implementation. + * + * Copyright (C) 1986, Sun Microsystems, Inc. + * + * These are the "generic" xdr routines used to serialize and de-serialize + * most common data items. See xdr.h for more info on the interface to + * xdr. + */ + +#include +#include +#include +#include + +#include "types.h" +#include "xdr.h" + +#ifdef USE_IN_LIBIO +# include +#endif + +/* + * constants specific to the xdr "protocol" + */ +#define XDR_FALSE ((long) 0) +#define XDR_TRUE ((long) 1) +#define LASTUNSIGNED ((u_int) 0-1) + +/* + * for unit alignment + */ +static const char xdr_zero[BYTES_PER_XDR_UNIT] = {0, 0, 0, 0}; + +/* + * Free a data structure using XDR + * Not a filter, but a convenient utility nonetheless + */ +void +xdr_free (xdrproc_t proc, char *objp) +{ + XDR x; + + x.x_op = XDR_FREE; + (*proc) (&x, objp); +} + +/* + * XDR nothing + */ +bool_t +xdr_void (void) +{ + return TRUE; +} +INTDEF(xdr_void) + +/* + * XDR integers + */ +bool_t +xdr_int (XDR *xdrs, int *ip) +{ + +#if INT_MAX < LONG_MAX + long l; + + switch (xdrs->x_op) + { + case XDR_ENCODE: + l = (long) *ip; + return XDR_PUTLONG (xdrs, &l); + + case XDR_DECODE: + if (!XDR_GETLONG (xdrs, &l)) + { + return FALSE; + } + *ip = (int) l; + case XDR_FREE: + return TRUE; + } + return FALSE; +#elif INT_MAX == LONG_MAX + return INTUSE(xdr_long) (xdrs, (long *) ip); +#elif INT_MAX == SHRT_MAX + return INTUSE(xdr_short) (xdrs, (short *) ip); +#else +#error unexpected integer sizes in_xdr_int() +#endif +} +INTDEF(xdr_int) + +/* + * XDR unsigned integers + */ +bool_t +xdr_u_int (XDR *xdrs, u_int *up) +{ +#if UINT_MAX < ULONG_MAX + long l; + + switch (xdrs->x_op) + { + case XDR_ENCODE: + l = (u_long) * up; + return XDR_PUTLONG (xdrs, &l); + + case XDR_DECODE: + if (!XDR_GETLONG (xdrs, &l)) + { + return FALSE; + } + *up = (u_int) (u_long) l; + case XDR_FREE: + return TRUE; + } + return FALSE; +#elif UINT_MAX == ULONG_MAX + return INTUSE(xdr_u_long) (xdrs, (u_long *) up); +#elif UINT_MAX == USHRT_MAX + return INTUSE(xdr_short) (xdrs, (short *) up); +#else +#error unexpected integer sizes in_xdr_u_int() +#endif +} +INTDEF(xdr_u_int) + +/* + * XDR long integers + * The definition of xdr_long() is kept for backward + * compatibility. Instead xdr_int() should be used. + */ +bool_t +xdr_long (XDR *xdrs, long *lp) +{ + + if (xdrs->x_op == XDR_ENCODE + && (sizeof (int32_t) == sizeof (long) + || (int32_t) *lp == *lp)) + return XDR_PUTLONG (xdrs, lp); + + if (xdrs->x_op == XDR_DECODE) + return XDR_GETLONG (xdrs, lp); + + if (xdrs->x_op == XDR_FREE) + return TRUE; + + return FALSE; +} +INTDEF(xdr_long) + +/* + * XDR unsigned long integers + * The definition of xdr_u_long() is kept for backward + * compatibility. Instead xdr_u_int() should be used. + */ +bool_t +xdr_u_long (XDR *xdrs, u_long *ulp) +{ + switch (xdrs->x_op) + { + case XDR_DECODE: + { + long int tmp; + + if (XDR_GETLONG (xdrs, &tmp) == FALSE) + return FALSE; + + *ulp = (uint32_t) tmp; + return TRUE; + } + + case XDR_ENCODE: + if (sizeof (uint32_t) != sizeof (u_long) + && (uint32_t) *ulp != *ulp) + return FALSE; + + return XDR_PUTLONG (xdrs, (long *) ulp); + + case XDR_FREE: + return TRUE; + } + return FALSE; +} +INTDEF(xdr_u_long) + +/* + * XDR hyper integers + * same as xdr_u_hyper - open coded to save a proc call! + */ +bool_t +xdr_hyper (XDR *xdrs, quad_t *llp) +{ + long int t1, t2; + + if (xdrs->x_op == XDR_ENCODE) + { + t1 = (long) ((*llp) >> 32); + t2 = (long) (*llp); + return (XDR_PUTLONG(xdrs, &t1) && XDR_PUTLONG(xdrs, &t2)); + } + + if (xdrs->x_op == XDR_DECODE) + { + if (!XDR_GETLONG(xdrs, &t1) || !XDR_GETLONG(xdrs, &t2)) + return FALSE; + *llp = ((quad_t) t1) << 32; + *llp |= (uint32_t) t2; + return TRUE; + } + + if (xdrs->x_op == XDR_FREE) + return TRUE; + + return FALSE; +} +INTDEF(xdr_hyper) + + +/* + * XDR hyper integers + * same as xdr_hyper - open coded to save a proc call! + */ +bool_t +xdr_u_hyper (XDR *xdrs, u_quad_t *ullp) +{ + long int t1, t2; + + if (xdrs->x_op == XDR_ENCODE) + { + t1 = (unsigned long) ((*ullp) >> 32); + t2 = (unsigned long) (*ullp); + return (XDR_PUTLONG(xdrs, &t1) && XDR_PUTLONG(xdrs, &t2)); + } + + if (xdrs->x_op == XDR_DECODE) + { + if (!XDR_GETLONG(xdrs, &t1) || !XDR_GETLONG(xdrs, &t2)) + return FALSE; + *ullp = ((u_quad_t) t1) << 32; + *ullp |= (uint32_t) t2; + return TRUE; + } + + if (xdrs->x_op == XDR_FREE) + return TRUE; + + return FALSE; +} +INTDEF(xdr_u_hyper) + +bool_t +xdr_longlong_t (XDR *xdrs, quad_t *llp) +{ + return INTUSE(xdr_hyper) (xdrs, llp); +} + +bool_t +xdr_u_longlong_t (XDR *xdrs, u_quad_t *ullp) +{ + return INTUSE(xdr_u_hyper) (xdrs, ullp); +} + +/* + * XDR short integers + */ +bool_t +xdr_short (XDR *xdrs, short *sp) +{ + long l; + + switch (xdrs->x_op) + { + case XDR_ENCODE: + l = (long) *sp; + return XDR_PUTLONG (xdrs, &l); + + case XDR_DECODE: + if (!XDR_GETLONG (xdrs, &l)) + { + return FALSE; + } + *sp = (short) l; + return TRUE; + + case XDR_FREE: + return TRUE; + } + return FALSE; +} +INTDEF(xdr_short) + +/* + * XDR unsigned short integers + */ +bool_t +xdr_u_short (XDR *xdrs, u_short *usp) +{ + long l; + + switch (xdrs->x_op) + { + case XDR_ENCODE: + l = (u_long) * usp; + return XDR_PUTLONG (xdrs, &l); + + case XDR_DECODE: + if (!XDR_GETLONG (xdrs, &l)) + { + return FALSE; + } + *usp = (u_short) (u_long) l; + return TRUE; + + case XDR_FREE: + return TRUE; + } + return FALSE; +} +INTDEF(xdr_u_short) + + +/* + * XDR a char + */ +bool_t +xdr_char (XDR *xdrs, char *cp) +{ + int i; + + i = (*cp); + if (!INTUSE(xdr_int) (xdrs, &i)) + { + return FALSE; + } + *cp = i; + return TRUE; +} + +/* + * XDR an unsigned char + */ +bool_t +xdr_u_char (XDR *xdrs, u_char *cp) +{ + u_int u; + + u = (*cp); + if (!INTUSE(xdr_u_int) (xdrs, &u)) + { + return FALSE; + } + *cp = u; + return TRUE; +} + +/* + * XDR booleans + */ +bool_t +xdr_bool (XDR *xdrs, bool_t *bp) +{ + long lb; + + switch (xdrs->x_op) + { + case XDR_ENCODE: + lb = *bp ? XDR_TRUE : XDR_FALSE; + return XDR_PUTLONG (xdrs, &lb); + + case XDR_DECODE: + if (!XDR_GETLONG (xdrs, &lb)) + { + return FALSE; + } + *bp = (lb == XDR_FALSE) ? FALSE : TRUE; + return TRUE; + + case XDR_FREE: + return TRUE; + } + return FALSE; +} +INTDEF(xdr_bool) + +/* + * XDR enumerations + */ +bool_t +xdr_enum (XDR *xdrs, enum_t *ep) +{ + enum sizecheck + { + SIZEVAL + }; /* used to find the size of an enum */ + + /* + * enums are treated as ints + */ + if (sizeof (enum sizecheck) == 4) + { +#if INT_MAX < LONG_MAX + long l; + + switch (xdrs->x_op) + { + case XDR_ENCODE: + l = *ep; + return XDR_PUTLONG (xdrs, &l); + + case XDR_DECODE: + if (!XDR_GETLONG (xdrs, &l)) + { + return FALSE; + } + *ep = l; + case XDR_FREE: + return TRUE; + + } + return FALSE; +#else + return INTUSE(xdr_long) (xdrs, (long *) ep); +#endif + } + else if (sizeof (enum sizecheck) == sizeof (short)) + { + return INTUSE(xdr_short) (xdrs, (short *) ep); + } + else + { + return FALSE; + } +} +INTDEF(xdr_enum) + +/* + * XDR opaque data + * Allows the specification of a fixed size sequence of opaque bytes. + * cp points to the opaque object and cnt gives the byte length. + */ +bool_t +xdr_opaque (XDR *xdrs, caddr_t cp, u_int cnt) +{ + u_int rndup; + static char crud[BYTES_PER_XDR_UNIT]; + + /* + * if no data we are done + */ + if (cnt == 0) + return TRUE; + + /* + * round byte count to full xdr units + */ + rndup = cnt % BYTES_PER_XDR_UNIT; + if (rndup > 0) + rndup = BYTES_PER_XDR_UNIT - rndup; + + switch (xdrs->x_op) + { + case XDR_DECODE: + if (!XDR_GETBYTES (xdrs, cp, cnt)) + { + return FALSE; + } + if (rndup == 0) + return TRUE; + return XDR_GETBYTES (xdrs, (caddr_t)crud, rndup); + + case XDR_ENCODE: + if (!XDR_PUTBYTES (xdrs, cp, cnt)) + { + return FALSE; + } + if (rndup == 0) + return TRUE; + return XDR_PUTBYTES (xdrs, xdr_zero, rndup); + + case XDR_FREE: + return TRUE; + } + return FALSE; +} +INTDEF(xdr_opaque) + +/* + * XDR counted bytes + * *cpp is a pointer to the bytes, *sizep is the count. + * If *cpp is NULL maxsize bytes are allocated + */ +bool_t +xdr_bytes (xdrs, cpp, sizep, maxsize) + XDR *xdrs; + char **cpp; + u_int *sizep; + u_int maxsize; +{ + char *sp = *cpp; /* sp is the actual string pointer */ + u_int nodesize; + + /* + * first deal with the length since xdr bytes are counted + */ + if (!INTUSE(xdr_u_int) (xdrs, sizep)) + { + return FALSE; + } + nodesize = *sizep; + if ((nodesize > maxsize) && (xdrs->x_op != XDR_FREE)) + { + return FALSE; + } + + /* + * now deal with the actual bytes + */ + switch (xdrs->x_op) + { + case XDR_DECODE: + if (nodesize == 0) + { + return TRUE; + } + if (sp == NULL) + { + *cpp = sp = (char *) mem_alloc (nodesize); + } + if (sp == NULL) + { + fprintf (NULL, "%s", "xdr_bytes: out of memory\n"); + return FALSE; + } + /* fall into ... */ + + case XDR_ENCODE: + return INTUSE(xdr_opaque) (xdrs, sp, nodesize); + + case XDR_FREE: + if (sp != NULL) + { + mem_free (sp, nodesize); + *cpp = NULL; + } + return TRUE; + } + return FALSE; +} +INTDEF(xdr_bytes) + +/* + * Implemented here due to commonality of the object. + */ +bool_t +xdr_netobj (xdrs, np) + XDR *xdrs; + struct netobj *np; +{ + + return INTUSE(xdr_bytes) (xdrs, &np->n_bytes, &np->n_len, MAX_NETOBJ_SZ); +} +INTDEF(xdr_netobj) + +/* + * XDR a discriminated union + * Support routine for discriminated unions. + * You create an array of xdrdiscrim structures, terminated with + * an entry with a null procedure pointer. The routine gets + * the discriminant value and then searches the array of xdrdiscrims + * looking for that value. It calls the procedure given in the xdrdiscrim + * to handle the discriminant. If there is no specific routine a default + * routine may be called. + * If there is no specific or default routine an error is returned. + */ +bool_t +xdr_union (xdrs, dscmp, unp, choices, dfault) + XDR *xdrs; + enum_t *dscmp; /* enum to decide which arm to work on */ + char *unp; /* the union itself */ + const struct xdr_discrim *choices; /* [value, xdr proc] for each arm */ + xdrproc_t dfault; /* default xdr routine */ +{ + enum_t dscm; + + /* + * we deal with the discriminator; it's an enum + */ + if (!INTUSE(xdr_enum) (xdrs, dscmp)) + { + return FALSE; + } + dscm = *dscmp; + + /* + * search choices for a value that matches the discriminator. + * if we find one, execute the xdr routine for that value. + */ + for (; choices->proc != NULL_xdrproc_t; choices++) + { + if (choices->value == dscm) + return (*(choices->proc)) (xdrs, unp, LASTUNSIGNED); + } + + /* + * no match - execute the default xdr routine if there is one + */ + return ((dfault == NULL_xdrproc_t) ? FALSE : + (*dfault) (xdrs, unp, LASTUNSIGNED)); +} +INTDEF(xdr_union) + + +/* + * Non-portable xdr primitives. + * Care should be taken when moving these routines to new architectures. + */ + + +/* + * XDR null terminated ASCII strings + * xdr_string deals with "C strings" - arrays of bytes that are + * terminated by a NULL character. The parameter cpp references a + * pointer to storage; If the pointer is null, then the necessary + * storage is allocated. The last parameter is the max allowed length + * of the string as specified by a protocol. + */ +bool_t +xdr_string (xdrs, cpp, maxsize) + XDR *xdrs; + char **cpp; + u_int maxsize; +{ + char *sp = *cpp; /* sp is the actual string pointer */ + u_int size; + u_int nodesize; + + /* + * first deal with the length since xdr strings are counted-strings + */ + switch (xdrs->x_op) + { + case XDR_FREE: + if (sp == NULL) + { + return TRUE; /* already free */ + } + /* fall through... */ + case XDR_ENCODE: + if (sp == NULL) + return FALSE; + size = strlen (sp); + break; + case XDR_DECODE: + break; + } + if (!INTUSE(xdr_u_int) (xdrs, &size)) + { + return FALSE; + } + if (size > maxsize) + { + return FALSE; + } + nodesize = size + 1; + if (nodesize == 0) + { + /* This means an overflow. It a bug in the caller which + provided a too large maxsize but nevertheless catch it + here. */ + return FALSE; + } + + /* + * now deal with the actual bytes + */ + switch (xdrs->x_op) + { + case XDR_DECODE: + if (sp == NULL) + *cpp = sp = (char *) mem_alloc (nodesize); + if (sp == NULL) + { + fprintf (NULL, "%s", "xdr_string: out of memory\n"); + return FALSE; + } + sp[size] = 0; + /* fall into ... */ + + case XDR_ENCODE: + return INTUSE(xdr_opaque) (xdrs, sp, size); + + case XDR_FREE: + mem_free (sp, nodesize); + *cpp = NULL; + return TRUE; + } + return FALSE; +} +INTDEF(xdr_string) + +/* + * Wrapper for xdr_string that can be called directly from + * routines like clnt_call + */ +bool_t +xdr_wrapstring (xdrs, cpp) + XDR *xdrs; + char **cpp; +{ + if (INTUSE(xdr_string) (xdrs, cpp, LASTUNSIGNED)) + { + return TRUE; + } + return FALSE; +} diff --git a/source/unres/src_MD-DFA-restraints/xdrf/xdr.h b/source/unres/src_MD-DFA-restraints/xdrf/xdr.h new file mode 100644 index 0000000..2602ad9 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/xdrf/xdr.h @@ -0,0 +1,379 @@ +/* + * Sun RPC is a product of Sun Microsystems, Inc. and is provided for + * unrestricted use provided that this legend is included on all tape + * media and as a part of the software program in whole or part. Users + * may copy or modify Sun RPC without charge, but are not authorized + * to license or distribute it to anyone else except as part of a product or + * program developed by the user. + * + * SUN RPC IS PROVIDED AS IS WITH NO WARRANTIES OF ANY KIND INCLUDING THE + * WARRANTIES OF DESIGN, MERCHANTIBILITY AND FITNESS FOR A PARTICULAR + * PURPOSE, OR ARISING FROM A COURSE OF DEALING, USAGE OR TRADE PRACTICE. + * + * Sun RPC is provided with no support and without any obligation on the + * part of Sun Microsystems, Inc. to assist in its use, correction, + * modification or enhancement. + * + * SUN MICROSYSTEMS, INC. SHALL HAVE NO LIABILITY WITH RESPECT TO THE + * INFRINGEMENT OF COPYRIGHTS, TRADE SECRETS OR ANY PATENTS BY SUN RPC + * OR ANY PART THEREOF. + * + * In no event will Sun Microsystems, Inc. be liable for any lost revenue + * or profits or other special, indirect and consequential damages, even if + * Sun has been advised of the possibility of such damages. + * + * Sun Microsystems, Inc. + * 2550 Garcia Avenue + * Mountain View, California 94043 + */ + +/* + * xdr.h, External Data Representation Serialization Routines. + * + * Copyright (C) 1984, Sun Microsystems, Inc. + */ + +#ifndef _RPC_XDR_H +#define _RPC_XDR_H 1 + +#include +#include +#include "types.h" + +/* We need FILE. */ +#include + +__BEGIN_DECLS + +/* + * XDR provides a conventional way for converting between C data + * types and an external bit-string representation. Library supplied + * routines provide for the conversion on built-in C data types. These + * routines and utility routines defined here are used to help implement + * a type encode/decode routine for each user-defined type. + * + * Each data type provides a single procedure which takes two arguments: + * + * bool_t + * xdrproc(xdrs, argresp) + * XDR *xdrs; + * *argresp; + * + * xdrs is an instance of a XDR handle, to which or from which the data + * type is to be converted. argresp is a pointer to the structure to be + * converted. The XDR handle contains an operation field which indicates + * which of the operations (ENCODE, DECODE * or FREE) is to be performed. + * + * XDR_DECODE may allocate space if the pointer argresp is null. This + * data can be freed with the XDR_FREE operation. + * + * We write only one procedure per data type to make it easy + * to keep the encode and decode procedures for a data type consistent. + * In many cases the same code performs all operations on a user defined type, + * because all the hard work is done in the component type routines. + * decode as a series of calls on the nested data types. + */ + +/* + * Xdr operations. XDR_ENCODE causes the type to be encoded into the + * stream. XDR_DECODE causes the type to be extracted from the stream. + * XDR_FREE can be used to release the space allocated by an XDR_DECODE + * request. + */ +enum xdr_op { + XDR_ENCODE = 0, + XDR_DECODE = 1, + XDR_FREE = 2 +}; + +/* + * This is the number of bytes per unit of external data. + */ +#define BYTES_PER_XDR_UNIT (4) +/* + * This only works if the above is a power of 2. But it's defined to be + * 4 by the appropriate RFCs. So it will work. And it's normally quicker + * than the old routine. + */ +#if 1 +#define RNDUP(x) (((x) + BYTES_PER_XDR_UNIT - 1) & ~(BYTES_PER_XDR_UNIT - 1)) +#else /* this is the old routine */ +#define RNDUP(x) ((((x) + BYTES_PER_XDR_UNIT - 1) / BYTES_PER_XDR_UNIT) \ + * BYTES_PER_XDR_UNIT) +#endif + +/* + * The XDR handle. + * Contains operation which is being applied to the stream, + * an operations vector for the particular implementation (e.g. see xdr_mem.c), + * and two private fields for the use of the particular implementation. + */ +typedef struct XDR XDR; +struct XDR + { + enum xdr_op x_op; /* operation; fast additional param */ + struct xdr_ops + { + bool_t (*x_getlong) (XDR *__xdrs, long *__lp); + /* get a long from underlying stream */ + bool_t (*x_putlong) (XDR *__xdrs, __const long *__lp); + /* put a long to " */ + bool_t (*x_getbytes) (XDR *__xdrs, caddr_t __addr, u_int __len); + /* get some bytes from " */ + bool_t (*x_putbytes) (XDR *__xdrs, __const char *__addr, u_int __len); + /* put some bytes to " */ + u_int (*x_getpostn) (__const XDR *__xdrs); + /* returns bytes off from beginning */ + bool_t (*x_setpostn) (XDR *__xdrs, u_int __pos); + /* lets you reposition the stream */ + int32_t *(*x_inline) (XDR *__xdrs, u_int __len); + /* buf quick ptr to buffered data */ + void (*x_destroy) (XDR *__xdrs); + /* free privates of this xdr_stream */ + bool_t (*x_getint32) (XDR *__xdrs, int32_t *__ip); + /* get a int from underlying stream */ + bool_t (*x_putint32) (XDR *__xdrs, __const int32_t *__ip); + /* put a int to " */ + } + *x_ops; + caddr_t x_public; /* users' data */ + caddr_t x_private; /* pointer to private data */ + caddr_t x_base; /* private used for position info */ + u_int x_handy; /* extra private word */ + }; + +/* + * A xdrproc_t exists for each data type which is to be encoded or decoded. + * + * The second argument to the xdrproc_t is a pointer to an opaque pointer. + * The opaque pointer generally points to a structure of the data type + * to be decoded. If this pointer is 0, then the type routines should + * allocate dynamic storage of the appropriate size and return it. + * bool_t (*xdrproc_t)(XDR *, caddr_t *); + */ +typedef bool_t (*xdrproc_t) (XDR *, void *,...); + + +/* + * Operations defined on a XDR handle + * + * XDR *xdrs; + * int32_t *int32p; + * long *longp; + * caddr_t addr; + * u_int len; + * u_int pos; + */ +#define XDR_GETINT32(xdrs, int32p) \ + (*(xdrs)->x_ops->x_getint32)(xdrs, int32p) +#define xdr_getint32(xdrs, int32p) \ + (*(xdrs)->x_ops->x_getint32)(xdrs, int32p) + +#define XDR_PUTINT32(xdrs, int32p) \ + (*(xdrs)->x_ops->x_putint32)(xdrs, int32p) +#define xdr_putint32(xdrs, int32p) \ + (*(xdrs)->x_ops->x_putint32)(xdrs, int32p) + +#define XDR_GETLONG(xdrs, longp) \ + (*(xdrs)->x_ops->x_getlong)(xdrs, longp) +#define xdr_getlong(xdrs, longp) \ + (*(xdrs)->x_ops->x_getlong)(xdrs, longp) + +#define XDR_PUTLONG(xdrs, longp) \ + (*(xdrs)->x_ops->x_putlong)(xdrs, longp) +#define xdr_putlong(xdrs, longp) \ + (*(xdrs)->x_ops->x_putlong)(xdrs, longp) + +#define XDR_GETBYTES(xdrs, addr, len) \ + (*(xdrs)->x_ops->x_getbytes)(xdrs, addr, len) +#define xdr_getbytes(xdrs, addr, len) \ + (*(xdrs)->x_ops->x_getbytes)(xdrs, addr, len) + +#define XDR_PUTBYTES(xdrs, addr, len) \ + (*(xdrs)->x_ops->x_putbytes)(xdrs, addr, len) +#define xdr_putbytes(xdrs, addr, len) \ + (*(xdrs)->x_ops->x_putbytes)(xdrs, addr, len) + +#define XDR_GETPOS(xdrs) \ + (*(xdrs)->x_ops->x_getpostn)(xdrs) +#define xdr_getpos(xdrs) \ + (*(xdrs)->x_ops->x_getpostn)(xdrs) + +#define XDR_SETPOS(xdrs, pos) \ + (*(xdrs)->x_ops->x_setpostn)(xdrs, pos) +#define xdr_setpos(xdrs, pos) \ + (*(xdrs)->x_ops->x_setpostn)(xdrs, pos) + +#define XDR_INLINE(xdrs, len) \ + (*(xdrs)->x_ops->x_inline)(xdrs, len) +#define xdr_inline(xdrs, len) \ + (*(xdrs)->x_ops->x_inline)(xdrs, len) + +#define XDR_DESTROY(xdrs) \ + do { \ + if ((xdrs)->x_ops->x_destroy) \ + (*(xdrs)->x_ops->x_destroy)(xdrs); \ + } while (0) +#define xdr_destroy(xdrs) \ + do { \ + if ((xdrs)->x_ops->x_destroy) \ + (*(xdrs)->x_ops->x_destroy)(xdrs); \ + } while (0) + +/* + * Support struct for discriminated unions. + * You create an array of xdrdiscrim structures, terminated with + * a entry with a null procedure pointer. The xdr_union routine gets + * the discriminant value and then searches the array of structures + * for a matching value. If a match is found the associated xdr routine + * is called to handle that part of the union. If there is + * no match, then a default routine may be called. + * If there is no match and no default routine it is an error. + */ +#define NULL_xdrproc_t ((xdrproc_t)0) +struct xdr_discrim +{ + int value; + xdrproc_t proc; +}; + +/* + * Inline routines for fast encode/decode of primitive data types. + * Caveat emptor: these use single memory cycles to get the + * data from the underlying buffer, and will fail to operate + * properly if the data is not aligned. The standard way to use these + * is to say: + * if ((buf = XDR_INLINE(xdrs, count)) == NULL) + * return (FALSE); + * <<< macro calls >>> + * where ``count'' is the number of bytes of data occupied + * by the primitive data types. + * + * N.B. and frozen for all time: each data type here uses 4 bytes + * of external representation. + */ + +#define IXDR_GET_INT32(buf) ((int32_t)ntohl((uint32_t)*(buf)++)) +#define IXDR_PUT_INT32(buf, v) (*(buf)++ = (int32_t)htonl((uint32_t)(v))) +#define IXDR_GET_U_INT32(buf) ((uint32_t)IXDR_GET_INT32(buf)) +#define IXDR_PUT_U_INT32(buf, v) IXDR_PUT_INT32(buf, (int32_t)(v)) + +/* WARNING: The IXDR_*_LONG defines are removed by Sun for new platforms + * and shouldn't be used any longer. Code which use this defines or longs + * in the RPC code will not work on 64bit Solaris platforms ! + */ +#define IXDR_GET_LONG(buf) ((long)IXDR_GET_U_INT32(buf)) +#define IXDR_PUT_LONG(buf, v) ((long)IXDR_PUT_INT32(buf, (long)(v))) +#define IXDR_GET_U_LONG(buf) ((u_long)IXDR_GET_LONG(buf)) +#define IXDR_PUT_U_LONG(buf, v) IXDR_PUT_LONG(buf, (long)(v)) + + +#define IXDR_GET_BOOL(buf) ((bool_t)IXDR_GET_LONG(buf)) +#define IXDR_GET_ENUM(buf, t) ((t)IXDR_GET_LONG(buf)) +#define IXDR_GET_SHORT(buf) ((short)IXDR_GET_LONG(buf)) +#define IXDR_GET_U_SHORT(buf) ((u_short)IXDR_GET_LONG(buf)) + +#define IXDR_PUT_BOOL(buf, v) IXDR_PUT_LONG(buf, (long)(v)) +#define IXDR_PUT_ENUM(buf, v) IXDR_PUT_LONG(buf, (long)(v)) +#define IXDR_PUT_SHORT(buf, v) IXDR_PUT_LONG(buf, (long)(v)) +#define IXDR_PUT_U_SHORT(buf, v) IXDR_PUT_LONG(buf, (long)(v)) + +/* + * These are the "generic" xdr routines. + * None of these can have const applied because it's not possible to + * know whether the call is a read or a write to the passed parameter + * also, the XDR structure is always updated by some of these calls. + */ +extern bool_t xdr_void (void) __THROW; +extern bool_t xdr_short (XDR *__xdrs, short *__sp) __THROW; +extern bool_t xdr_u_short (XDR *__xdrs, u_short *__usp) __THROW; +extern bool_t xdr_int (XDR *__xdrs, int *__ip) __THROW; +extern bool_t xdr_u_int (XDR *__xdrs, u_int *__up) __THROW; +extern bool_t xdr_long (XDR *__xdrs, long *__lp) __THROW; +extern bool_t xdr_u_long (XDR *__xdrs, u_long *__ulp) __THROW; +extern bool_t xdr_hyper (XDR *__xdrs, quad_t *__llp) __THROW; +extern bool_t xdr_u_hyper (XDR *__xdrs, u_quad_t *__ullp) __THROW; +extern bool_t xdr_longlong_t (XDR *__xdrs, quad_t *__llp) __THROW; +extern bool_t xdr_u_longlong_t (XDR *__xdrs, u_quad_t *__ullp) __THROW; +extern bool_t xdr_int8_t (XDR *__xdrs, int8_t *__ip) __THROW; +extern bool_t xdr_uint8_t (XDR *__xdrs, uint8_t *__up) __THROW; +extern bool_t xdr_int16_t (XDR *__xdrs, int16_t *__ip) __THROW; +extern bool_t xdr_uint16_t (XDR *__xdrs, uint16_t *__up) __THROW; +extern bool_t xdr_int32_t (XDR *__xdrs, int32_t *__ip) __THROW; +extern bool_t xdr_uint32_t (XDR *__xdrs, uint32_t *__up) __THROW; +extern bool_t xdr_int64_t (XDR *__xdrs, int64_t *__ip) __THROW; +extern bool_t xdr_uint64_t (XDR *__xdrs, uint64_t *__up) __THROW; +extern bool_t xdr_quad_t (XDR *__xdrs, quad_t *__ip) __THROW; +extern bool_t xdr_u_quad_t (XDR *__xdrs, u_quad_t *__up) __THROW; +extern bool_t xdr_bool (XDR *__xdrs, bool_t *__bp) __THROW; +extern bool_t xdr_enum (XDR *__xdrs, enum_t *__ep) __THROW; +extern bool_t xdr_array (XDR * _xdrs, caddr_t *__addrp, u_int *__sizep, + u_int __maxsize, u_int __elsize, xdrproc_t __elproc) + __THROW; +extern bool_t xdr_bytes (XDR *__xdrs, char **__cpp, u_int *__sizep, + u_int __maxsize) __THROW; +extern bool_t xdr_opaque (XDR *__xdrs, caddr_t __cp, u_int __cnt) __THROW; +extern bool_t xdr_string (XDR *__xdrs, char **__cpp, u_int __maxsize) __THROW; +extern bool_t xdr_union (XDR *__xdrs, enum_t *__dscmp, char *__unp, + __const struct xdr_discrim *__choices, + xdrproc_t dfault) __THROW; +extern bool_t xdr_char (XDR *__xdrs, char *__cp) __THROW; +extern bool_t xdr_u_char (XDR *__xdrs, u_char *__cp) __THROW; +extern bool_t xdr_vector (XDR *__xdrs, char *__basep, u_int __nelem, + u_int __elemsize, xdrproc_t __xdr_elem) __THROW; +extern bool_t xdr_float (XDR *__xdrs, float *__fp) __THROW; +extern bool_t xdr_double (XDR *__xdrs, double *__dp) __THROW; +extern bool_t xdr_reference (XDR *__xdrs, caddr_t *__xpp, u_int __size, + xdrproc_t __proc) __THROW; +extern bool_t xdr_pointer (XDR *__xdrs, char **__objpp, + u_int __obj_size, xdrproc_t __xdr_obj) __THROW; +extern bool_t xdr_wrapstring (XDR *__xdrs, char **__cpp) __THROW; +extern u_long xdr_sizeof (xdrproc_t, void *) __THROW; + +/* + * Common opaque bytes objects used by many rpc protocols; + * declared here due to commonality. + */ +#define MAX_NETOBJ_SZ 1024 +struct netobj +{ + u_int n_len; + char *n_bytes; +}; +typedef struct netobj netobj; +extern bool_t xdr_netobj (XDR *__xdrs, struct netobj *__np) __THROW; + +/* + * These are the public routines for the various implementations of + * xdr streams. + */ + +/* XDR using memory buffers */ +extern void xdrmem_create (XDR *__xdrs, __const caddr_t __addr, + u_int __size, enum xdr_op __xop) __THROW; + +/* XDR using stdio library */ +extern void xdrstdio_create (XDR *__xdrs, FILE *__file, enum xdr_op __xop) + __THROW; + +/* XDR pseudo records for tcp */ +extern void xdrrec_create (XDR *__xdrs, u_int __sendsize, + u_int __recvsize, caddr_t __tcp_handle, + int (*__readit) (char *, char *, int), + int (*__writeit) (char *, char *, int)) __THROW; + +/* make end of xdr record */ +extern bool_t xdrrec_endofrecord (XDR *__xdrs, bool_t __sendnow) __THROW; + +/* move to beginning of next record */ +extern bool_t xdrrec_skiprecord (XDR *__xdrs) __THROW; + +/* true if no more input */ +extern bool_t xdrrec_eof (XDR *__xdrs) __THROW; + +/* free memory buffers for xdr */ +extern void xdr_free (xdrproc_t __proc, char *__objp) __THROW; + +__END_DECLS + +#endif /* rpc/xdr.h */ diff --git a/source/unres/src_MD-DFA-restraints/xdrf/xdr_array.c b/source/unres/src_MD-DFA-restraints/xdrf/xdr_array.c new file mode 100644 index 0000000..836405c --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/xdrf/xdr_array.c @@ -0,0 +1,174 @@ +# define INTUSE(name) name +# define INTDEF(name) +/* @(#)xdr_array.c 2.1 88/07/29 4.0 RPCSRC */ +/* + * Sun RPC is a product of Sun Microsystems, Inc. and is provided for + * unrestricted use provided that this legend is included on all tape + * media and as a part of the software program in whole or part. Users + * may copy or modify Sun RPC without charge, but are not authorized + * to license or distribute it to anyone else except as part of a product or + * program developed by the user. + * + * SUN RPC IS PROVIDED AS IS WITH NO WARRANTIES OF ANY KIND INCLUDING THE + * WARRANTIES OF DESIGN, MERCHANTIBILITY AND FITNESS FOR A PARTICULAR + * PURPOSE, OR ARISING FROM A COURSE OF DEALING, USAGE OR TRADE PRACTICE. + * + * Sun RPC is provided with no support and without any obligation on the + * part of Sun Microsystems, Inc. to assist in its use, correction, + * modification or enhancement. + * + * SUN MICROSYSTEMS, INC. SHALL HAVE NO LIABILITY WITH RESPECT TO THE + * INFRINGEMENT OF COPYRIGHTS, TRADE SECRETS OR ANY PATENTS BY SUN RPC + * OR ANY PART THEREOF. + * + * In no event will Sun Microsystems, Inc. be liable for any lost revenue + * or profits or other special, indirect and consequential damages, even if + * Sun has been advised of the possibility of such damages. + * + * Sun Microsystems, Inc. + * 2550 Garcia Avenue + * Mountain View, California 94043 + */ +#if !defined(lint) && defined(SCCSIDS) +static char sccsid[] = "@(#)xdr_array.c 1.10 87/08/11 Copyr 1984 Sun Micro"; +#endif + +/* + * xdr_array.c, Generic XDR routines implementation. + * + * Copyright (C) 1984, Sun Microsystems, Inc. + * + * These are the "non-trivial" xdr primitives used to serialize and de-serialize + * arrays. See xdr.h for more info on the interface to xdr. + */ + +#include +#include +#include "types.h" +#include "xdr.h" +#include +#include + +#ifdef USE_IN_LIBIO +# include +#endif + +#define LASTUNSIGNED ((u_int)0-1) + + +/* + * XDR an array of arbitrary elements + * *addrp is a pointer to the array, *sizep is the number of elements. + * If addrp is NULL (*sizep * elsize) bytes are allocated. + * elsize is the size (in bytes) of each element, and elproc is the + * xdr procedure to call to handle each element of the array. + */ +bool_t +xdr_array (xdrs, addrp, sizep, maxsize, elsize, elproc) + XDR *xdrs; + caddr_t *addrp; /* array pointer */ + u_int *sizep; /* number of elements */ + u_int maxsize; /* max numberof elements */ + u_int elsize; /* size in bytes of each element */ + xdrproc_t elproc; /* xdr routine to handle each element */ +{ + u_int i; + caddr_t target = *addrp; + u_int c; /* the actual element count */ + bool_t stat = TRUE; + u_int nodesize; + + /* like strings, arrays are really counted arrays */ + if (!INTUSE(xdr_u_int) (xdrs, sizep)) + { + return FALSE; + } + c = *sizep; + /* + * XXX: Let the overflow possibly happen with XDR_FREE because mem_free() + * doesn't actually use its second argument anyway. + */ + if ((c > maxsize || c > UINT_MAX / elsize) && (xdrs->x_op != XDR_FREE)) + { + return FALSE; + } + nodesize = c * elsize; + + /* + * if we are deserializing, we may need to allocate an array. + * We also save time by checking for a null array if we are freeing. + */ + if (target == NULL) + switch (xdrs->x_op) + { + case XDR_DECODE: + if (c == 0) + return TRUE; + *addrp = target = mem_alloc (nodesize); + if (target == NULL) + { + fprintf (stderr, "%s", "xdr_array: out of memory\n"); + return FALSE; + } + __bzero (target, nodesize); + break; + + case XDR_FREE: + return TRUE; + default: + break; + } + + /* + * now we xdr each element of array + */ + for (i = 0; (i < c) && stat; i++) + { + stat = (*elproc) (xdrs, target, LASTUNSIGNED); + target += elsize; + } + + /* + * the array may need freeing + */ + if (xdrs->x_op == XDR_FREE) + { + mem_free (*addrp, nodesize); + *addrp = NULL; + } + return stat; +} +INTDEF(xdr_array) + +/* + * xdr_vector(): + * + * XDR a fixed length array. Unlike variable-length arrays, + * the storage of fixed length arrays is static and unfreeable. + * > basep: base of the array + * > size: size of the array + * > elemsize: size of each element + * > xdr_elem: routine to XDR each element + */ +bool_t +xdr_vector (xdrs, basep, nelem, elemsize, xdr_elem) + XDR *xdrs; + char *basep; + u_int nelem; + u_int elemsize; + xdrproc_t xdr_elem; +{ + u_int i; + char *elptr; + + elptr = basep; + for (i = 0; i < nelem; i++) + { + if (!(*xdr_elem) (xdrs, elptr, LASTUNSIGNED)) + { + return FALSE; + } + elptr += elemsize; + } + return TRUE; +} diff --git a/source/unres/src_MD-DFA-restraints/xdrf/xdr_float.c b/source/unres/src_MD-DFA-restraints/xdrf/xdr_float.c new file mode 100644 index 0000000..15d3c88 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/xdrf/xdr_float.c @@ -0,0 +1,307 @@ +/* @(#)xdr_float.c 2.1 88/07/29 4.0 RPCSRC */ +/* + * Sun RPC is a product of Sun Microsystems, Inc. and is provided for + * unrestricted use provided that this legend is included on all tape + * media and as a part of the software program in whole or part. Users + * may copy or modify Sun RPC without charge, but are not authorized + * to license or distribute it to anyone else except as part of a product or + * program developed by the user. + * + * SUN RPC IS PROVIDED AS IS WITH NO WARRANTIES OF ANY KIND INCLUDING THE + * WARRANTIES OF DESIGN, MERCHANTIBILITY AND FITNESS FOR A PARTICULAR + * PURPOSE, OR ARISING FROM A COURSE OF DEALING, USAGE OR TRADE PRACTICE. + * + * Sun RPC is provided with no support and without any obligation on the + * part of Sun Microsystems, Inc. to assist in its use, correction, + * modification or enhancement. + * + * SUN MICROSYSTEMS, INC. SHALL HAVE NO LIABILITY WITH RESPECT TO THE + * INFRINGEMENT OF COPYRIGHTS, TRADE SECRETS OR ANY PATENTS BY SUN RPC + * OR ANY PART THEREOF. + * + * In no event will Sun Microsystems, Inc. be liable for any lost revenue + * or profits or other special, indirect and consequential damages, even if + * Sun has been advised of the possibility of such damages. + * + * Sun Microsystems, Inc. + * 2550 Garcia Avenue + * Mountain View, California 94043 + */ +#if !defined(lint) && defined(SCCSIDS) +static char sccsid[] = "@(#)xdr_float.c 1.12 87/08/11 Copyr 1984 Sun Micro"; +#endif + +/* + * xdr_float.c, Generic XDR routines implementation. + * + * Copyright (C) 1984, Sun Microsystems, Inc. + * + * These are the "floating point" xdr routines used to (de)serialize + * most common data items. See xdr.h for more info on the interface to + * xdr. + */ + +#include +#include + +#include "types.h" +#include "xdr.h" + +/* + * NB: Not portable. + * This routine works on Suns (Sky / 68000's) and Vaxen. + */ + +#define LSW (__FLOAT_WORD_ORDER == __BIG_ENDIAN) + +#ifdef vax + +/* What IEEE single precision floating point looks like on a Vax */ +struct ieee_single { + unsigned int mantissa: 23; + unsigned int exp : 8; + unsigned int sign : 1; +}; + +/* Vax single precision floating point */ +struct vax_single { + unsigned int mantissa1 : 7; + unsigned int exp : 8; + unsigned int sign : 1; + unsigned int mantissa2 : 16; +}; + +#define VAX_SNG_BIAS 0x81 +#define IEEE_SNG_BIAS 0x7f + +static struct sgl_limits { + struct vax_single s; + struct ieee_single ieee; +} sgl_limits[2] = { + {{ 0x7f, 0xff, 0x0, 0xffff }, /* Max Vax */ + { 0x0, 0xff, 0x0 }}, /* Max IEEE */ + {{ 0x0, 0x0, 0x0, 0x0 }, /* Min Vax */ + { 0x0, 0x0, 0x0 }} /* Min IEEE */ +}; +#endif /* vax */ + +bool_t +xdr_float(xdrs, fp) + XDR *xdrs; + float *fp; +{ +#ifdef vax + struct ieee_single is; + struct vax_single vs, *vsp; + struct sgl_limits *lim; + int i; +#endif + switch (xdrs->x_op) { + + case XDR_ENCODE: +#ifdef vax + vs = *((struct vax_single *)fp); + for (i = 0, lim = sgl_limits; + i < sizeof(sgl_limits)/sizeof(struct sgl_limits); + i++, lim++) { + if ((vs.mantissa2 == lim->s.mantissa2) && + (vs.exp == lim->s.exp) && + (vs.mantissa1 == lim->s.mantissa1)) { + is = lim->ieee; + goto shipit; + } + } + is.exp = vs.exp - VAX_SNG_BIAS + IEEE_SNG_BIAS; + is.mantissa = (vs.mantissa1 << 16) | vs.mantissa2; + shipit: + is.sign = vs.sign; + return (XDR_PUTLONG(xdrs, (long *)&is)); +#else + if (sizeof(float) == sizeof(long)) + return (XDR_PUTLONG(xdrs, (long *)fp)); + else if (sizeof(float) == sizeof(int)) { + long tmp = *(int *)fp; + return (XDR_PUTLONG(xdrs, &tmp)); + } + break; +#endif + + case XDR_DECODE: +#ifdef vax + vsp = (struct vax_single *)fp; + if (!XDR_GETLONG(xdrs, (long *)&is)) + return (FALSE); + for (i = 0, lim = sgl_limits; + i < sizeof(sgl_limits)/sizeof(struct sgl_limits); + i++, lim++) { + if ((is.exp == lim->ieee.exp) && + (is.mantissa == lim->ieee.mantissa)) { + *vsp = lim->s; + goto doneit; + } + } + vsp->exp = is.exp - IEEE_SNG_BIAS + VAX_SNG_BIAS; + vsp->mantissa2 = is.mantissa; + vsp->mantissa1 = (is.mantissa >> 16); + doneit: + vsp->sign = is.sign; + return (TRUE); +#else + if (sizeof(float) == sizeof(long)) + return (XDR_GETLONG(xdrs, (long *)fp)); + else if (sizeof(float) == sizeof(int)) { + long tmp; + if (XDR_GETLONG(xdrs, &tmp)) { + *(int *)fp = tmp; + return (TRUE); + } + } + break; +#endif + + case XDR_FREE: + return (TRUE); + } + return (FALSE); +} + +/* + * This routine works on Suns (Sky / 68000's) and Vaxen. + */ + +#ifdef vax +/* What IEEE double precision floating point looks like on a Vax */ +struct ieee_double { + unsigned int mantissa1 : 20; + unsigned int exp : 11; + unsigned int sign : 1; + unsigned int mantissa2 : 32; +}; + +/* Vax double precision floating point */ +struct vax_double { + unsigned int mantissa1 : 7; + unsigned int exp : 8; + unsigned int sign : 1; + unsigned int mantissa2 : 16; + unsigned int mantissa3 : 16; + unsigned int mantissa4 : 16; +}; + +#define VAX_DBL_BIAS 0x81 +#define IEEE_DBL_BIAS 0x3ff +#define MASK(nbits) ((1 << nbits) - 1) + +static struct dbl_limits { + struct vax_double d; + struct ieee_double ieee; +} dbl_limits[2] = { + {{ 0x7f, 0xff, 0x0, 0xffff, 0xffff, 0xffff }, /* Max Vax */ + { 0x0, 0x7ff, 0x0, 0x0 }}, /* Max IEEE */ + {{ 0x0, 0x0, 0x0, 0x0, 0x0, 0x0}, /* Min Vax */ + { 0x0, 0x0, 0x0, 0x0 }} /* Min IEEE */ +}; + +#endif /* vax */ + + +bool_t +xdr_double(xdrs, dp) + XDR *xdrs; + double *dp; +{ +#ifdef vax + struct ieee_double id; + struct vax_double vd; + register struct dbl_limits *lim; + int i; +#endif + + switch (xdrs->x_op) { + + case XDR_ENCODE: +#ifdef vax + vd = *((struct vax_double *)dp); + for (i = 0, lim = dbl_limits; + i < sizeof(dbl_limits)/sizeof(struct dbl_limits); + i++, lim++) { + if ((vd.mantissa4 == lim->d.mantissa4) && + (vd.mantissa3 == lim->d.mantissa3) && + (vd.mantissa2 == lim->d.mantissa2) && + (vd.mantissa1 == lim->d.mantissa1) && + (vd.exp == lim->d.exp)) { + id = lim->ieee; + goto shipit; + } + } + id.exp = vd.exp - VAX_DBL_BIAS + IEEE_DBL_BIAS; + id.mantissa1 = (vd.mantissa1 << 13) | (vd.mantissa2 >> 3); + id.mantissa2 = ((vd.mantissa2 & MASK(3)) << 29) | + (vd.mantissa3 << 13) | + ((vd.mantissa4 >> 3) & MASK(13)); + shipit: + id.sign = vd.sign; + dp = (double *)&id; +#endif + if (2*sizeof(long) == sizeof(double)) { + long *lp = (long *)dp; + return (XDR_PUTLONG(xdrs, lp+!LSW) && + XDR_PUTLONG(xdrs, lp+LSW)); + } else if (2*sizeof(int) == sizeof(double)) { + int *ip = (int *)dp; + long tmp[2]; + tmp[0] = ip[!LSW]; + tmp[1] = ip[LSW]; + return (XDR_PUTLONG(xdrs, tmp) && + XDR_PUTLONG(xdrs, tmp+1)); + } + break; + + case XDR_DECODE: +#ifdef vax + lp = (long *)&id; + if (!XDR_GETLONG(xdrs, lp++) || !XDR_GETLONG(xdrs, lp)) + return (FALSE); + for (i = 0, lim = dbl_limits; + i < sizeof(dbl_limits)/sizeof(struct dbl_limits); + i++, lim++) { + if ((id.mantissa2 == lim->ieee.mantissa2) && + (id.mantissa1 == lim->ieee.mantissa1) && + (id.exp == lim->ieee.exp)) { + vd = lim->d; + goto doneit; + } + } + vd.exp = id.exp - IEEE_DBL_BIAS + VAX_DBL_BIAS; + vd.mantissa1 = (id.mantissa1 >> 13); + vd.mantissa2 = ((id.mantissa1 & MASK(13)) << 3) | + (id.mantissa2 >> 29); + vd.mantissa3 = (id.mantissa2 >> 13); + vd.mantissa4 = (id.mantissa2 << 3); + doneit: + vd.sign = id.sign; + *dp = *((double *)&vd); + return (TRUE); +#else + if (2*sizeof(long) == sizeof(double)) { + long *lp = (long *)dp; + return (XDR_GETLONG(xdrs, lp+!LSW) && + XDR_GETLONG(xdrs, lp+LSW)); + } else if (2*sizeof(int) == sizeof(double)) { + int *ip = (int *)dp; + long tmp[2]; + if (XDR_GETLONG(xdrs, tmp+!LSW) && + XDR_GETLONG(xdrs, tmp+LSW)) { + ip[0] = tmp[0]; + ip[1] = tmp[1]; + return (TRUE); + } + } + break; +#endif + + case XDR_FREE: + return (TRUE); + } + return (FALSE); +} diff --git a/source/unres/src_MD-DFA-restraints/xdrf/xdr_stdio.c b/source/unres/src_MD-DFA-restraints/xdrf/xdr_stdio.c new file mode 100644 index 0000000..12b1709 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/xdrf/xdr_stdio.c @@ -0,0 +1,196 @@ +/* + * Sun RPC is a product of Sun Microsystems, Inc. and is provided for + * unrestricted use provided that this legend is included on all tape + * media and as a part of the software program in whole or part. Users + * may copy or modify Sun RPC without charge, but are not authorized + * to license or distribute it to anyone else except as part of a product or + * program developed by the user. + * + * SUN RPC IS PROVIDED AS IS WITH NO WARRANTIES OF ANY KIND INCLUDING THE + * WARRANTIES OF DESIGN, MERCHANTIBILITY AND FITNESS FOR A PARTICULAR + * PURPOSE, OR ARISING FROM A COURSE OF DEALING, USAGE OR TRADE PRACTICE. + * + * Sun RPC is provided with no support and without any obligation on the + * part of Sun Microsystems, Inc. to assist in its use, correction, + * modification or enhancement. + * + * SUN MICROSYSTEMS, INC. SHALL HAVE NO LIABILITY WITH RESPECT TO THE + * INFRINGEMENT OF COPYRIGHTS, TRADE SECRETS OR ANY PATENTS BY SUN RPC + * OR ANY PART THEREOF. + * + * In no event will Sun Microsystems, Inc. be liable for any lost revenue + * or profits or other special, indirect and consequential damages, even if + * Sun has been advised of the possibility of such damages. + * + * Sun Microsystems, Inc. + * 2550 Garcia Avenue + * Mountain View, California 94043 + */ + +/* + * xdr_stdio.c, XDR implementation on standard i/o file. + * + * Copyright (C) 1984, Sun Microsystems, Inc. + * + * This set of routines implements a XDR on a stdio stream. + * XDR_ENCODE serializes onto the stream, XDR_DECODE de-serializes + * from the stream. + */ + +#include "types.h" +#include +#include "xdr.h" + +#ifdef USE_IN_LIBIO +# include +# define fflush(s) INTUSE(_IO_fflush) (s) +# define fread(p, m, n, s) INTUSE(_IO_fread) (p, m, n, s) +# define ftell(s) INTUSE(_IO_ftell) (s) +# define fwrite(p, m, n, s) INTUSE(_IO_fwrite) (p, m, n, s) +#endif + +static bool_t xdrstdio_getlong (XDR *, long *); +static bool_t xdrstdio_putlong (XDR *, const long *); +static bool_t xdrstdio_getbytes (XDR *, caddr_t, u_int); +static bool_t xdrstdio_putbytes (XDR *, const char *, u_int); +static u_int xdrstdio_getpos (const XDR *); +static bool_t xdrstdio_setpos (XDR *, u_int); +static int32_t *xdrstdio_inline (XDR *, u_int); +static void xdrstdio_destroy (XDR *); +static bool_t xdrstdio_getint32 (XDR *, int32_t *); +static bool_t xdrstdio_putint32 (XDR *, const int32_t *); + +/* + * Ops vector for stdio type XDR + */ +static const struct xdr_ops xdrstdio_ops = +{ + xdrstdio_getlong, /* deserialize a long int */ + xdrstdio_putlong, /* serialize a long int */ + xdrstdio_getbytes, /* deserialize counted bytes */ + xdrstdio_putbytes, /* serialize counted bytes */ + xdrstdio_getpos, /* get offset in the stream */ + xdrstdio_setpos, /* set offset in the stream */ + xdrstdio_inline, /* prime stream for inline macros */ + xdrstdio_destroy, /* destroy stream */ + xdrstdio_getint32, /* deserialize a int */ + xdrstdio_putint32 /* serialize a int */ +}; + +/* + * Initialize a stdio xdr stream. + * Sets the xdr stream handle xdrs for use on the stream file. + * Operation flag is set to op. + */ +void +xdrstdio_create (XDR *xdrs, FILE *file, enum xdr_op op) +{ + xdrs->x_op = op; + /* We have to add the const since the `struct xdr_ops' in `struct XDR' + is not `const'. */ + xdrs->x_ops = (struct xdr_ops *) &xdrstdio_ops; + xdrs->x_private = (caddr_t) file; + xdrs->x_handy = 0; + xdrs->x_base = 0; +} + +/* + * Destroy a stdio xdr stream. + * Cleans up the xdr stream handle xdrs previously set up by xdrstdio_create. + */ +static void +xdrstdio_destroy (XDR *xdrs) +{ + (void) fflush ((FILE *) xdrs->x_private); + /* xx should we close the file ?? */ +}; + +static bool_t +xdrstdio_getlong (XDR *xdrs, long *lp) +{ + u_int32_t mycopy; + + if (fread ((caddr_t) &mycopy, 4, 1, (FILE *) xdrs->x_private) != 1) + return FALSE; + *lp = (long) ntohl (mycopy); + return TRUE; +} + +static bool_t +xdrstdio_putlong (XDR *xdrs, const long *lp) +{ + int32_t mycopy = htonl ((u_int32_t) *lp); + + if (fwrite ((caddr_t) &mycopy, 4, 1, (FILE *) xdrs->x_private) != 1) + return FALSE; + return TRUE; +} + +static bool_t +xdrstdio_getbytes (XDR *xdrs, const caddr_t addr, u_int len) +{ + if ((len != 0) && (fread (addr, (int) len, 1, + (FILE *) xdrs->x_private) != 1)) + return FALSE; + return TRUE; +} + +static bool_t +xdrstdio_putbytes (XDR *xdrs, const char *addr, u_int len) +{ + if ((len != 0) && (fwrite (addr, (int) len, 1, + (FILE *) xdrs->x_private) != 1)) + return FALSE; + return TRUE; +} + +static u_int +xdrstdio_getpos (const XDR *xdrs) +{ + return (u_int) ftell ((FILE *) xdrs->x_private); +} + +static bool_t +xdrstdio_setpos (XDR *xdrs, u_int pos) +{ + return fseek ((FILE *) xdrs->x_private, (long) pos, 0) < 0 ? FALSE : TRUE; +} + +static int32_t * +xdrstdio_inline (XDR *xdrs, u_int len) +{ + /* + * Must do some work to implement this: must insure + * enough data in the underlying stdio buffer, + * that the buffer is aligned so that we can indirect through a + * long *, and stuff this pointer in xdrs->x_buf. Doing + * a fread or fwrite to a scratch buffer would defeat + * most of the gains to be had here and require storage + * management on this buffer, so we don't do this. + */ + return NULL; +} + +static bool_t +xdrstdio_getint32 (XDR *xdrs, int32_t *ip) +{ + int32_t mycopy; + + if (fread ((caddr_t) &mycopy, 4, 1, (FILE *) xdrs->x_private) != 1) + return FALSE; + *ip = ntohl (mycopy); + return TRUE; +} + +static bool_t +xdrstdio_putint32 (XDR *xdrs, const int32_t *ip) +{ + int32_t mycopy = htonl (*ip); + + ip = &mycopy; + if (fwrite ((caddr_t) ip, 4, 1, (FILE *) xdrs->x_private) != 1) + return FALSE; + return TRUE; +} + +/* libc_hidden_def (xdrstdio_create) */ diff --git a/source/unres/src_MD-DFA-restraints/xdrf/xdrf.h b/source/unres/src_MD-DFA-restraints/xdrf/xdrf.h new file mode 100644 index 0000000..dedf5a2 --- /dev/null +++ b/source/unres/src_MD-DFA-restraints/xdrf/xdrf.h @@ -0,0 +1,10 @@ +/*_________________________________________________________________ + | + | xdrf.h - include file for C routines that want to use the + | functions below. +*/ + +int xdropen(XDR *xdrs, const char *filename, const char *type); +int xdrclose(XDR *xdrs) ; +int xdr3dfcoord(XDR *xdrs, float *fp, int *size, float *precision) ; + diff --git a/source/unres/src_MD/Makefile~adam b/source/unres/src_MD/Makefile~adam new file mode 120000 index 0000000..8453cdd --- /dev/null +++ b/source/unres/src_MD/Makefile~adam @@ -0,0 +1 @@ +Makefile_MPICH_ifort \ No newline at end of file diff --git a/source/wham/src-M-NEWCORR/DIMENSIONS b/source/wham/src-M-NEWCORR/DIMENSIONS index 154f3df..be8fab6 100644 --- a/source/wham/src-M-NEWCORR/DIMENSIONS +++ b/source/wham/src-M-NEWCORR/DIMENSIONS @@ -13,8 +13,8 @@ C Max. number of coarse-grain processors c parameter (max_cg_procs=maxprocs) C Max. number of AA residues integer maxres -c parameter (maxres=250) - parameter (maxres=100) + parameter (maxres=400) +c parameter (maxres=100) C Appr. max. number of interaction sites integer maxres2 parameter (maxres2=2*maxres) diff --git a/source/wham/src-restraints-DFA/Makefile_MPICH_ifort b/source/wham/src-restraints-DFA/Makefile_MPICH_ifort index 6e2ba17..9024977 100644 --- a/source/wham/src-restraints-DFA/Makefile_MPICH_ifort +++ b/source/wham/src-restraints-DFA/Makefile_MPICH_ifort @@ -2,7 +2,7 @@ INSTALL_DIR = /users/software/mpich-1.2.7p1_intel-10.1_em64_ssh BIN = ../../../bin/wham FC= ifort OPT = -mcmodel=medium -O3 -ip -w -#OPT = -mcmodel=medium -g -CB +OPT = -mcmodel=medium -g -CB FFLAGS = ${OPT} -c -I. -I./include_unres -I$(INSTALL_DIR)/include LIBS = -L$(INSTALL_DIR)/lib -lmpich -lpmpich xdrf/libxdrf.a diff --git a/source/wham/src-restraints-DFA/dfa.F b/source/wham/src-restraints-DFA/dfa.F index 576910c..b157520 100644 --- a/source/wham/src-restraints-DFA/dfa.F +++ b/source/wham/src-restraints-DFA/dfa.F @@ -1085,10 +1085,12 @@ c end of sheet energy and force c write(*,*)'SHETF:',shetfx(j),shetfy(j),shetfz(j) enddo + write (2,*) "vbeta",vbeta," beta_inc",beta_inc vbeta=vbeta*beta_inc enebet=vbeta edfabeta=enebet + write (2,*) "vbeta",vbeta," enebet",enebet," edfabeta",edfabeta do j=1,nca gdfab(1,j+ishiftca)=gdfab(1,j+ishiftca)-shetfx(j) gdfab(2,j+ishiftca)=gdfab(2,j+ishiftca)-shetfy(j) @@ -2187,6 +2189,7 @@ c vbeta=0.0D0 vbetp=0.0D0 vbetm=0.0D0 + write (2,*) "vbeta",vbeta do i=1,inb-7 do j=i+4,inb-3 @@ -2267,9 +2270,9 @@ cd yshe2=0 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 + write(2,*)'1', i,j,dtmp1,dtmp2,dtmp3 + write(2,*)'2', y,yy1,yy2 + write(2,*)'3', yshe1,yshe2 cc if (dtmp3.le.-35.0d0) then c vbetap(i,j)=-dp45*exp(dtmp3) @@ -2396,7 +2399,9 @@ c vbetam2(i,j)=-r_pair_mat(i+2,j+1)*exp(y+yy2+yshe2) 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 + write(2,*) 'uup,uum:', uup, uum + write (2,*) "vbetap1",vbetap1(i,j)," vbetap2",vbetap2(i,j) + write (2,*) "vbeta",vbeta c uup=vbetap1(i,j)+vbetap2(i,j) c uum=vbetam1(i,j)+vbetam2(i,j) @@ -2405,6 +2410,8 @@ c uum=vbetam1(i,j)+vbetam2(i,j) vbetp=vbetp+uup vbetm=vbetm+uum vbeta=vbeta+vbet(i,j) + write (2,*) "i",i," j",j," vbet",vbet(i,j), + & " vbeta",vbeta ci elseif(istrand(i,j).eq.0)then ci vbet(i,j)=0 diff --git a/source/wham/src-restraints-DFA/enecalc1.F b/source/wham/src-restraints-DFA/enecalc1.F index 09971f2..da3e41b 100644 --- a/source/wham/src-restraints-DFA/enecalc1.F +++ b/source/wham/src-restraints-DFA/enecalc1.F @@ -196,12 +196,16 @@ c call pdbout(ii+1,beta_h(ib,ipar),efree,energia(0),0.0d0,rmsdev) & iii+1,indstart(me1)+iii," T", & 1.0d0/(1.987D-3*beta_h(ib,ipar)) call enerprint(energia(0),fT) - itmp=ipdb - ipdb=iout - call pdbout(iii+1,beta_h(ib,ipar), - & eini,energia(0),0.0d0,rmsdev) - write (iout,*) - ipdb=itmp +c itmp=ipdb +c ipdb=iout +c call pdbout(iii+1,beta_h(ib,ipar), +c & eini,energia(0),0.0d0,rmsdev) +c write (iout,*) +c ipdb=itmp + itmp=igeom + igeom=iout + call cartout(i) + igeom=itmp errmsg_count=errmsg_count+1 if (errmsg_count.gt.maxerrmsg_count) diff --git a/source/wham/src-restraints-DFA/energy_p_new.F b/source/wham/src-restraints-DFA/energy_p_new.F index e9d735c..a9cbc0e 100644 --- a/source/wham/src-restraints-DFA/energy_p_new.F +++ b/source/wham/src-restraints-DFA/energy_p_new.F @@ -116,13 +116,13 @@ c write(iout,*) "TEST_ENE1 ehomology_constr=",ehomology_constr C BARTEK for dfa test! if (wdfa_dist.gt.0) call edfad(edfadis) -c write(iout,*)'edfad is finished!', wdfa_dist,edfadis + write(iout,*)'edfad is finished!', wdfa_dist,edfadis if (wdfa_tor.gt.0) call edfat(edfator) -c write(iout,*)'edfat is finished!', wdfa_tor,edfator + write(iout,*)'edfat is finished!', wdfa_tor,edfator if (wdfa_nei.gt.0) call edfan(edfanei) -c write(iout,*)'edfan is finished!', wdfa_nei,edfanei + write(iout,*)'edfan is finished!', wdfa_nei,edfanei if (wdfa_beta.gt.0) call edfab(edfabet) -c write(iout,*)'edfab is finished!', wdfa_beta,edfabet + write(iout,*)'edfab is finished!', wdfa_beta,edfabet c write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t #ifdef SPLITELE diff --git a/source/wham/src-restraints-DFA/geomout.F b/source/wham/src-restraints-DFA/geomout.F index 35f3d77..c38ffd2 100644 --- a/source/wham/src-restraints-DFA/geomout.F +++ b/source/wham/src-restraints-DFA/geomout.F @@ -168,3 +168,30 @@ c endif 200 format (8F10.4) return end +c------------------------------------------------------------------------------ + subroutine cartout(i) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.HEADER' + include 'COMMON.SBRIDGE' + double precision time +#if defined(AIX) || defined(PGI) +c open(igeom,file=cartname,position="append") +#else +c open(igeom,file=cartname,access="append") +#endif + write (igeom,'("Conformation",i10)') i + write (igeom,'(i4,$)') + & nss,(ihpb(j),jhpb(j),j=1,nss) + write(igeom,*) + write (igeom,'(8f10.5)') + & ((c(k,j),k=1,3),j=1,nres), + & ((c(k,j+nres),k=1,3),j=nnt,nct) +c close(igeom) + return + end diff --git a/source/wham/src/Makefile_MPICH_ifort b/source/wham/src/Makefile_MPICH_ifort index 1d4a159..abbc1bc 100644 --- a/source/wham/src/Makefile_MPICH_ifort +++ b/source/wham/src/Makefile_MPICH_ifort @@ -69,7 +69,7 @@ E0LL2Y: ${objects} ${objects_compar} xdrf/libxdrf.a ./compinfo ${FC} -c ${FFLAGS} cinfo.f $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ - ${LIBS} -static-intel -o ${BIN}/wham_ifort_MPICH_E0LL2Y-DEBUG.exe + ${LIBS} -static-intel -o ${BIN}/wham_ifort_MPICH_E0LL2Y.exe xdrf/libxdrf.a: cd xdrf && make diff --git a/source/wham/src/enecalc1.F b/source/wham/src/enecalc1.F index 857aec0..4b9414d 100644 --- a/source/wham/src/enecalc1.F +++ b/source/wham/src/enecalc1.F @@ -153,6 +153,7 @@ c & " kfac",kfac,"quot",quot," fT",fT & wtor_d,wsccor,wbond #endif call etotal(energia(0),fT) +#define DEBUG #ifdef DEBUG write (iout,*) "Conformation",i call enerprint(energia(0),fT) @@ -160,6 +161,7 @@ c write (iout,'(2i5,21f8.2)') i,iparm,(energia(k),k=1,21) c write (iout,*) "ftors",ftors c call intout #endif +#undef DEBUG if (energia(0).ge.1.0d20) then write (iout,*) "NaNs detected in some of the energy", & " components for conformation",ii+1 diff --git a/source/wham/src/energy_p_new.F b/source/wham/src/energy_p_new.F index e57397b..9b69cf7 100644 --- a/source/wham/src/energy_p_new.F +++ b/source/wham/src/energy_p_new.F @@ -2869,16 +2869,24 @@ C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors. C implicit real*8 (a-h,o-z) include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' include 'COMMON.SBRIDGE' include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.VAR' include 'COMMON.INTERACT' include 'COMMON.IOUNITS' + include 'COMMON.NAMES' dimension ggg(3) ehpb=0.0D0 +#ifdef DEBUG + do i=1,nres + write (iout,'(a4,2x,i4,3f10.5,5x,3f10.5)') restyp(itype(i)),i, + & (c(j,i),j=1,3),(c(j,i+nres),j=1,3) + enddo cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr cd write(iout,*)'link_start=',link_start,' link_end=',link_end +#endif 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 @@ -2893,8 +2901,10 @@ C iii and jjj point to the residues for which the distance is assigned. iii=ii jjj=jj endif -c write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj, -c & dhpb(i),dhpb1(i),forcon(i) +#ifdef DEBUG + write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj, + & dhpb(i),dhpb1(i),forcon(i) +#endif 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 @@ -2907,8 +2917,10 @@ c Restraints from contact prediction if (dhpb1(i).gt.0.0d0) then ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd -c write (iout,*) "beta nmr", -c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) +#ifdef DEBUG + write (iout,*) "beta nmr", + & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) +#endif else dd=dist(ii,jj) rdis=dd-dhpb(i) @@ -2916,7 +2928,9 @@ C Get the force constant corresponding to this distance. waga=forcon(i) C Calculate the contribution to energy. ehpb=ehpb+waga*rdis*rdis -c write (iout,*) "beta reg",dd,waga*rdis*rdis +#ifdef DEBUG + write (iout,*) "beta reg",dd,waga*rdis*rdis +#endif C C Evaluate gradient. C @@ -2940,15 +2954,19 @@ C target distance. if (dhpb1(i).gt.0.0d0) then ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd -c write (iout,*) "alph nmr", -c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) +#ifdef DEBUG + write (iout,*) "alph nmr", + & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) +#endif else rdis=dd-dhpb(i) C Get the force constant corresponding to this distance. waga=forcon(i) C Calculate the contribution to energy. ehpb=ehpb+waga*rdis*rdis -c write (iout,*) "alpha reg",dd,waga*rdis*rdis +#ifdef DEBUG + write (iout,*) "alpha reg",dd,waga*rdis*rdis +#endif C C Evaluate gradient. C @@ -3100,8 +3118,8 @@ c nbi=nbondterm(iti) if (nbi.eq.1) then diff=vbld(i+nres)-vbldsc0(1,iti) - write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff, - & AKSC(1,iti),AKSC(1,iti)*diff*diff +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) @@ -3130,8 +3148,8 @@ c usum=usum+uprod1 usumsqder=usumsqder+ud(j)*uprod2 enddo - write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti), - & AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi) +c write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti), +c & AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi) estr=estr+uprod/usum do j=1,3 gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)