From df0d15d1ab81e01e177d3d39354e72364b294e1c Mon Sep 17 00:00:00 2001 From: Cezary Czaplewski Date: Wed, 15 Feb 2017 09:22:39 +0100 Subject: [PATCH] cmake for unres4 wham some files changed from .f90 to .F90 necessary for dependencies --- CMakeLists.txt | 6 +- source/cluster/CMakeLists.txt | 217 ++ source/unres/CMakeLists.txt | 16 +- source/unres/Makefile | 8 +- source/unres/cinfo.f90 | 6 +- source/unres/compare.F90 | 4552 +++++++++++++++++++++++++++++++++++++++++ source/unres/compare.f90 | 4552 ----------------------------------------- source/unres/control.F90 | 2160 +++++++++++++++++++ source/unres/control.f90 | 2160 ------------------- source/wham/CMakeLists.txt | 291 +++ source/wham/Makefile | 8 +- source/wham/cinfo.f90 | 6 +- 12 files changed, 7247 insertions(+), 6735 deletions(-) create mode 100644 source/cluster/CMakeLists.txt create mode 100644 source/unres/compare.F90 delete mode 100644 source/unres/compare.f90 create mode 100644 source/unres/control.F90 delete mode 100644 source/unres/control.f90 create mode 100644 source/wham/CMakeLists.txt diff --git a/CMakeLists.txt b/CMakeLists.txt index c3fb048..5016506 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -165,6 +165,10 @@ message("Detected ${architektura}-bit architecture") #======================================= +# order is important +# the most independent ones should go first + add_subdirectory(source/xdrf) add_subdirectory(source/unres) - +add_subdirectory(source/wham) +#add_subdirectory(source/cluster) diff --git a/source/cluster/CMakeLists.txt b/source/cluster/CMakeLists.txt new file mode 100644 index 0000000..5feee37 --- /dev/null +++ b/source/cluster/CMakeLists.txt @@ -0,0 +1,217 @@ +# +# CMake project file for cluster analysis from WHAM for single-chain proteins +# + +enable_language (Fortran) + +#================================ +# Set source file lists +#================================ +set(UNRES_CLUSTER_WHAM_SRC0 +) + + +#================================================ +# Set compiler flags for different sourcefiles +#================================================ +if (Fortran_COMPILER_NAME STREQUAL "ifort") + set(FFLAGS0 "-mcmodel=medium -shared-intel -ip -w -I. -I${CMAKE_CURRENT_SOURCE_DIR}/include_unres " ) +elseif (Fortran_COMPILER_NAME STREQUAL "gfortran") + set(FFLAGS0 "-std=legacy -mcmodel=medium -I. -I${CMAKE_CURRENT_SOURCE_DIR}/include_unres " ) +elseif (Fortran_COMPILER_NAME STREQUAL "pgf90") + set(FFLAGS0 "-mcmodel=medium -Mlarge_arrays -I. -I${CMAKE_CURRENT_SOURCE_DIR}/include_unres" ) +else () + set(FFLAGS0 "-mcmodel=medium -I. -I${CMAKE_CURRENT_SOURCE_DIR}/include_unres " ) +endif (Fortran_COMPILER_NAME STREQUAL "ifort") + +#========================================= +# Add MPI compiler flags +#========================================= +if(UNRES_WITH_MPI) + set(FFLAGS0 "${FFLAGS0} -I${MPI_Fortran_INCLUDE_PATH}") +endif(UNRES_WITH_MPI) + +set_property(SOURCE ${UNRES_CLUSTER_WHAM_SRC0} PROPERTY COMPILE_FLAGS ${FFLAGS0} ) + +#========================================= +# Settings for GAB force field +#========================================= +if(UNRES_MD_FF STREQUAL "GAB" ) + # set preprocesor flags + set(CPPFLAGS "PROCOR -DSPLITELE -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DSCCORPDB" ) + +#========================================= +# Settings for E0LL2Y force field +#========================================= +elseif(UNRES_MD_FF STREQUAL "E0LL2Y") + # set preprocesor flags + set(CPPFLAGS "PROCOR -DSPLITELE -DSCCORPDB" ) +elseif(UNRES_MD_FF STREQUAL "4P") + set(CPPFLAGS "SPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DSCCORPDB" ) +endif(UNRES_MD_FF STREQUAL "GAB") + +#========================================= +# Additional flags +#========================================= +set(CPPFLAGS "${CPPFLAGS} -DUNRES -DISNAN -DCLUST" ) + +#========================================= +# Compiler specific flags +#========================================= +if (Fortran_COMPILER_NAME STREQUAL "ifort") + # Add ifort preprocessor flags + set(CPPFLAGS "${CPPFLAGS} -DPGI") +elseif (Fortran_COMPILER_NAME STREQUAL "f95") + # Add new gfortran flags + set(CPPFLAGS "${CPPFLAGS} -DG77") +elseif (Fortran_COMPILER_NAME STREQUAL "gfortran") + # Add old gfortran flags + set(CPPFLAGS "${CPPFLAGS} -DG77") +elseif (Fortran_COMPILER_NAME STREQUAL "pgf90") + set(CPPFLAGS "${CPPFLAGS} -DPGI") + FILE(COPY ${CMAKE_SOURCE_DIR}/source/isnan_pgi.f DESTINATION ${CMAKE_CURRENT_BINARY_DIR} ) + list(APPEND UNRES_CLUSTER_WHAM_SRC0 ${CMAKE_CURRENT_BINARY_DIR}/isnan_pgi.f) + set(CMAKE_EXE_LINKER_FLAGS "-Bdynamic") +endif (Fortran_COMPILER_NAME STREQUAL "ifort") + + +#========================================= +# System specific flags +#========================================= +if(${CMAKE_SYSTEM_NAME} MATCHES "Linux") + set(CPPFLAGS "${CPPFLAGS} -DLINUX") +endif(${CMAKE_SYSTEM_NAME} MATCHES "Linux") + +#========================================= +# Add MPI preprocessor flags +#========================================= +if (UNRES_WITH_MPI) + set(CPPFLAGS "${CPPFLAGS} -DMP -DMPI") +endif(UNRES_WITH_MPI) + + +#========================================= +# Apply preprocesor flags to *.F files +#========================================= +set_property(SOURCE ${UNRES_CLUSTER_WHAM_PP_SRC} PROPERTY COMPILE_DEFINITIONS ${CPPFLAGS} ) + + +#======================================== +# Setting binary name +#======================================== +set(UNRES_CLUSTER_WHAM_BIN "cluster_wham_${Fortran_COMPILER_NAME}_MPI_${UNRES_MD_FF}.exe") + +set_property(SOURCE proc_proc.c PROPERTY COMPILE_DEFINITIONS "LINUX -DPGI" ) + +#========================================= +# Set full unres CLUSTER sources +#========================================= +set(UNRES_CLUSTER_WHAM_SRCS ${UNRES_CLUSTER_WHAM_SRC0} proc_proc.c) + +#========================================= +# Build the binary +#========================================= +add_executable(UNRES_CLUSTER_WHAM_BIN ${UNRES_CLUSTER_WHAM_SRCS} ) +set_target_properties(UNRES_CLUSTER_WHAM_BIN PROPERTIES OUTPUT_NAME ${UNRES_CLUSTER_WHAM_BIN}) +set_property(TARGET UNRES_CLUSTER_WHAM_BIN PROPERTY RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/bin ) + +#========================================= +# Link libraries +#========================================= +# link MPI libraries +if(UNRES_WITH_MPI) + target_link_libraries( UNRES_CLUSTER_WHAM_BIN ${MPI_Fortran_LIBRARIES} ) +endif(UNRES_WITH_MPI) +# link libxdrf.a +target_link_libraries( UNRES_CLUSTER_WHAM_BIN xdrf ) + +#========================================= +# Install Path +#========================================= +install(TARGETS UNRES_CLUSTER_WHAM_BIN DESTINATION ${CMAKE_INSTALL_PREFIX}/cluster) + + +#========================================= +# TESTS +#========================================= + +# MESSAGE (STATUS "${MPI_Fortran_LIBRARIES}") + if ("${MPI_Fortran_LIBRARIES}" MATCHES "lam") + MESSAGE (STATUS "LAM MPI library detected") + set (boot_lam "-boot") + else() + set (boot_lam "") + endif() + + if (UNRES_SRUN) + set (np "-n") + set (mpiexec "srun") + elseif(UNRES_MPIRUN) + set (np "-np") + set (mpiexec "mpirun") + else() + set (np "-np") + set (mpiexec "mpiexec") + endif() + +FILE(WRITE ${CMAKE_CURRENT_BINARY_DIR}/scripts/cluster_wham_mpi_E0LL2Y.sh +"#!/bin/sh +export POT=GB +export INPUT=$1 +export INTIN=1L2Y_wham +export OUTPUT=1L2Y_clust +export PDB=CART +export COORD=CX +export PRINTCOOR=PRINT_PDB +#----------------------------------------------------------------------------- +CLUSTER_WHAM_BIN=${CMAKE_BINARY_DIR}/bin/${UNRES_CLUSTER_WHAM_BIN} +#----------------------------------------------------------------------------- +DD=${CMAKE_SOURCE_DIR}/PARAM +export BONDPAR=$DD/bond_AM1.parm +export THETPAR=$DD/theta_abinitio.parm +export ROTPAR=$DD/rotamers_AM1_aura.10022007.parm +export TORPAR=$DD/torsion_631Gdp.parm +export TORDPAR=$DD/torsion_double_631Gdp.parm +export ELEPAR=$DD/electr_631Gdp.parm +export SIDEPAR=$DD/scinter_$POT.parm +export FOURIER=$DD/fourier_opt.parm.1igd_hc_iter3_3 +export SCPPAR=$DD/scp.parm +export SCCORPAR=$DD/sccor_am1_pawel.dat +export THETPARPDB=$DD/thetaml.5parm +export ROTPARPDB=$DD/scgauss.parm +export PATTERN=$DD/patterns.cart +export CONTFUNC=GB +export SIDEP=$DD/contact.3.parm +export SCRATCHDIR=. +#----------------------------------------------------------------------------- +echo CTEST_FULL_OUTPUT +${mpiexec} ${boot_lam} ${np} $2 $CLUSTER_WHAM_BIN +./cluster_wham_check.sh $1 +") + +# +# File permissions workaround +# +FILE( COPY ${CMAKE_CURRENT_BINARY_DIR}/scripts/cluster_wham_mpi_E0LL2Y.sh + DESTINATION ${CMAKE_CURRENT_BINARY_DIR} + FILE_PERMISSIONS OWNER_READ OWNER_WRITE OWNER_EXECUTE GROUP_READ GROUP_EXECUTE WORLD_READ WORLD_EXECUTE +) + +FILE(COPY ${CMAKE_SOURCE_DIR}/ctest/cluster_wham_check.sh + DESTINATION ${CMAKE_CURRENT_BINARY_DIR} + FILE_PERMISSIONS OWNER_READ OWNER_WRITE OWNER_EXECUTE GROUP_READ GROUP_EXECUTE WORLD_READ WORLD_EXECUTE +) + +FILE(COPY ${CMAKE_SOURCE_DIR}/ctest/1L2Y_clust.inp + DESTINATION ${CMAKE_CURRENT_BINARY_DIR} ) + +FILE(COPY ${CMAKE_SOURCE_DIR}/ctest/1L2Y_wham.cx + DESTINATION ${CMAKE_CURRENT_BINARY_DIR} ) + +FILE(COPY ${CMAKE_SOURCE_DIR}/ctest/1L2Y.pdb + DESTINATION ${CMAKE_CURRENT_BINARY_DIR} ) + + +if(UNRES_MD_FF STREQUAL "E0LL2Y") + add_test(NAME CLUSTER_WHAM_remd COMMAND sh ${CMAKE_CURRENT_BINARY_DIR}/cluster_wham_mpi_E0LL2Y.sh 1L2Y_clust 2 ) +endif(UNRES_MD_FF STREQUAL "E0LL2Y") diff --git a/source/unres/CMakeLists.txt b/source/unres/CMakeLists.txt index 7c7359c..cc0b694 100644 --- a/source/unres/CMakeLists.txt +++ b/source/unres/CMakeLists.txt @@ -29,10 +29,10 @@ set(UNRES_MD_SRC0 io_base.f90 energy.f90 check_bond.f90 - control.f90 + control.F90 MPI.f90 regularize.f90 - compare.f90 + compare.F90 map.f90 muca_md.f90 MCM_MD.f90 @@ -203,9 +203,9 @@ set_property(SOURCE ${UNRES_MD_SRCS} PROPERTY COMPILE_DEFINITIONS ${CPPFLAGS} ) #========================================= # 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-MD PROPERTY RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/bin ) +add_executable(UNRES_BIN ${UNRES_MD_SRCS} ) +set_target_properties(UNRES_BIN PROPERTIES OUTPUT_NAME ${UNRES_BIN}) +set_property(TARGET UNRES_BIN PROPERTY RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/bin ) #========================================= @@ -214,16 +214,16 @@ set_property(TARGET UNRES_BIN-MD PROPERTY RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINAR # link MPI library (libmpich.a) if(UNRES_WITH_MPI) - target_link_libraries( UNRES_BIN-MD ${MPI_Fortran_LIBRARIES} ) + target_link_libraries( UNRES_BIN ${MPI_Fortran_LIBRARIES} ) endif(UNRES_WITH_MPI) # link libxdrf.a #message("UNRES_XDRFLIB=${UNRES_XDRFLIB}") -target_link_libraries( UNRES_BIN-MD xdrf ) +target_link_libraries( UNRES_BIN xdrf ) #========================================= # Install Path #========================================= -install(TARGETS UNRES_BIN-MD DESTINATION ${CMAKE_INSTALL_PREFIX}) +install(TARGETS UNRES_BIN DESTINATION ${CMAKE_INSTALL_PREFIX}) #========================================= # TESTS diff --git a/source/unres/Makefile b/source/unres/Makefile index db1bc7b..c1e9c7a 100644 --- a/source/unres/Makefile +++ b/source/unres/Makefile @@ -177,8 +177,8 @@ energy.o: energy.f90 check_bond.o: check_bond.f90 ${FC} ${FFLAGS} ${CPPFLAGS} check_bond.f90 -control.o: control.f90 - ${FC} ${FFLAGS} ${CPPFLAGS} control.f90 +control.o: control.F90 + ${FC} ${FFLAGS} ${CPPFLAGS} control.F90 io_config.o: io_config.f90 ${FC} ${FFLAGS2} ${CPPFLAGS} io_config.f90 @@ -192,8 +192,8 @@ minim.o: minim.f90 regularize.o: regularize.f90 ${FC} ${FFLAGS} ${CPPFLAGS} regularize.f90 -compare.o: compare.f90 - ${FC} ${FFLAGS} ${CPPFLAGS} compare.f90 +compare.o: compare.F90 + ${FC} ${FFLAGS} ${CPPFLAGS} compare.F90 map.o: map.f90 ${FC} ${FFLAGS} ${CPPFLAGS} map.f90 diff --git a/source/unres/cinfo.f90 b/source/unres/cinfo.f90 index 5361eb9..62433a6 100644 --- a/source/unres/cinfo.f90 +++ b/source/unres/cinfo.f90 @@ -1,11 +1,11 @@ ! DO NOT EDIT THIS FILE - IT HAS BEEN GENERATED BY COMPINFO.C -! 0 40376 53 +! 0 40376 54 subroutine cinfo ! include 'COMMON.IOUNITS' use io_units write(iout,*)'++++ Compile info ++++' - write(iout,*)'Version 0.40376 build 53' - write(iout,*)'compiled Wed Feb 15 06:17:07 2017' + write(iout,*)'Version 0.40376 build 54' + write(iout,*)'compiled Wed Feb 15 09:03:06 2017' write(iout,*)'compiled by czarek@piasek4' write(iout,*)'OS name: Linux ' write(iout,*)'OS release: 3.2.0-111-generic ' diff --git a/source/unres/compare.F90 b/source/unres/compare.F90 new file mode 100644 index 0000000..b65e57c --- /dev/null +++ b/source/unres/compare.F90 @@ -0,0 +1,4552 @@ + module compare +!----------------------------------------------------------------------------- + use io_units + use names + use geometry_data + use energy_data + use control_data +#if .not. defined WHAM_RUN && .not. defined CLUSTER + use compare_data + use io_base + use io_config + use geometry + use energy + use control, only: hpb_partition + use minim_data + use minimm, only: sc_move, minimize +#endif + implicit none +!----------------------------------------------------------------------------- +! +! +!----------------------------------------------------------------------------- + contains +#if .not. defined WHAM_RUN && .not. defined CLUSTER +!----------------------------------------------------------------------------- +! contact.f +!----------------------------------------------------------------------------- + subroutine contact(lprint,ncont,icont,co) + + use geometry, only:dist +! 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(kind=8) :: facont=1.569D0 ! facont = (2/(1-sqrt(1-1/4)))**(1/6) + integer :: ncont + integer,dimension(2,12*nres) :: icont!(2,12*nres) !(2,maxcont) (maxcont=12*maxres) + logical :: lprint +!el local variables + real(kind=8) :: co,rcomp + integer :: kkk,i,j,i1,i2,it1,it2,iti,itj + + ncont=0 + kkk=3 + do i=nnt+kkk,nct + iti=iabs(itype(i)) + do j=nnt,i-kkk + itj=iabs(itype(j)) + if (ipot.ne.4) then +! rcomp=sigmaii(iti,itj)+1.0D0 + rcomp=facont*sigmaii(iti,itj) + else +! rcomp=sigma(iti,itj)+1.0D0 + rcomp=facont*sigma(iti,itj) + endif +! rcomp=6.5D0 +! 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 subroutine contact +!----------------------------------------------------------------------------- + real(kind=8) 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 + integer,dimension(2,12*nres) :: icont,icont_ref !(2,12*nres) (2,maxcont) (maxcont=12*maxres) +!el local variables + integer :: i,j,nmatch + nmatch=0 +! print *,'ncont=',ncont,' ncont_ref=',ncont_ref +! write (iout,'(20i4)') (icont_ref(1,i),i=1,ncont_ref) +! write (iout,'(20i4)') (icont_ref(2,i),i=1,ncont_ref) +! write (iout,'(20i4)') (icont(1,i),i=1,ncont) +! 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 +! print *,' nmatch=',nmatch +! contact_fract=dfloat(nmatch)/dfloat(max0(ncont,ncont_ref)) + contact_fract=dfloat(nmatch)/dfloat(ncont_ref) + return + end function contact_fract +!----------------------------------------------------------------------------- + real(kind=8) 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 + integer,dimension(2,12*nres) :: icont,icont_ref !(2,12*nres) (2,maxcont) (maxcont=12*maxres) +!el local variables + integer :: i,j,nmatch + nmatch=0 +! print *,'ncont=',ncont,' ncont_ref=',ncont_ref +! write (iout,'(20i4)') (icont_ref(1,i),i=1,ncont_ref) +! write (iout,'(20i4)') (icont_ref(2,i),i=1,ncont_ref) +! write (iout,'(20i4)') (icont(1,i),i=1,ncont) +! 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 +! print *,' nmatch=',nmatch +! contact_fract=dfloat(nmatch)/dfloat(max0(ncont,ncont_ref)) + contact_fract_nn=dfloat(ncont-nmatch)/dfloat(ncont) + return + end function contact_fract_nn +!----------------------------------------------------------------------------- + subroutine hairpin(lprint,nharp,iharp) + + use geometry, only:dist +! 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 + integer,dimension(2,12*nres) :: icont !(2,maxcont) (maxcont=12*maxres) + integer :: nharp + integer,dimension(4,nres/3) :: iharp !(4,nres/3)(4,maxres/3) + logical :: lprint,not_done + real(kind=8) :: rcomp=6.0d0 +!el local variables + integer :: i,j,kkk,k,i1,i2,it1,it2,j1,ii1,jj1 +! allocate(icont(2,12*nres)) + + ncont=0 + kkk=0 +! 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 +! 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 +! 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 +! 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 +! write (iout,*)'nharp',nharp,' iharp',(iharp(k,nharp),k=1,4) + endif + endif + enddo +! do i=1,nharp +! write (iout,*)'i',i,' iharp',(iharp(k,i),k=1,4) +! 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) +! do k=jj1,j1,-1 +! write (iout,'(a,i3,$)') restyp(itype(k)),k +! enddo + enddo + endif + return + end subroutine hairpin +!----------------------------------------------------------------------------- +! elecont.f +!----------------------------------------------------------------------------- + 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 + real(kind=8),dimension(2,2) :: elpp_6,elpp_3,ael6_,ael3_ + real(kind=8) :: ael6_i,ael3_i + real(kind=8),dimension(2,2) :: app_,bpp_,rpp_ + integer :: ncont + integer,dimension(2,12*nres) :: icont !(2,12*nres)(2,maxcont) (maxcont=12*maxres) + real(kind=8),dimension(12*nres) :: econt !(maxcont) +!el local variables + integer :: i,j,k,iteli,itelj,i1,i2,it1,it2,ic1,ic2 + real(kind=8) :: elcutoff,elecutoff_14,rri,ees,evdw + real(kind=8) :: xi,yi,zi,dxi,dyi,dzi,aaa,bbb + real(kind=8) :: xmedi,ymedi,zmedi + real(kind=8) :: xj,yj,zj,dxj,dyj,dzj,rrmij,rmij,r3ij,r6ij + real(kind=8) :: vrmij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,& + evdwij,el1,el2,eesij,ene +! +! 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. +! +! 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/ + +!el allocate(econt(12*nres)) !(maxcont) + + 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 + if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) goto 1 + 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 + if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) goto 4 + 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 +! 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 +! write (iout,*) "i",i," j",j," ic1",ic1," ic2",ic2, +! & " 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 +! 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 +! write (iout,*) "ncont",ncont +! do k=1,ncont +! write (iout,*) icont(1,k),icont(2,k) +! 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 +! 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 +! write (iout,*) "ncont",ncont +! do k=1,ncont +! write (iout,*) icont(1,k),icont(2,k) +! 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 subroutine elecont +!----------------------------------------------------------------------------- + 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,i,j,i1,j1,nbeta,nstrand,ii1,jj1,ij,nhelix,& + iii1,jjj1 + integer,dimension(2,12*nres) :: icont !(2,maxcont) (maxcont=12*maxres) + integer,dimension(nres,4) :: isec !(maxres,4) + integer,dimension(nres) :: nsec !(maxres) + logical :: lprint,not_done !,freeres + real(kind=8) :: p1,p2 +!el external freeres + +!el allocate(icont(2,12*nres),isec(nres,4),nsec(nres)) + + if(.not.dccart) call chainbuild + if(.not.allocated(hfrag)) allocate(hfrag(2,nres/3)) !(2,maxres/3) +!d 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) + +! finding parallel beta +!d 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 +!d 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 +!d 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 + +! 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 +!d if (j1.eq.i1+3) write (iout,*) "found 1-4 ",i1,j1,p1,p2 +!o 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. +!d + enddo + j1=j1+1 + if (j1-ii1.gt.5) then + nhelix=nhelix+1 +!d + + 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 + + +! finding antiparallel beta +!d 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 +!d 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 +!d 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 subroutine secondary2 +#endif +!----------------------------------------------------------------------------- + logical function freeres(i,j,nsec,isec) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + integer,dimension(nres,4) :: isec !(maxres,4) + integer,dimension(nres) :: nsec !(maxres) + +!el local variables + integer :: i,j,k,l + + freeres=.false. +#ifndef WHAM_RUN + if (nsec(i).lt.0.or.nsec(j).lt.0) return +#endif + 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 function freeres +!----------------------------------------------------------------------------- +! readrtns_CSA.F +!----------------------------------------------------------------------------- + logical function seq_comp(itypea,itypeb,length) + +!el 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 function seq_comp +#ifndef WHAM_RUN +!----------------------------------------------------------------------------- +! rmsd.F +!----------------------------------------------------------------------------- + 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' + real(kind=8) :: przes(3),obr(3,3) + logical :: non_conv,lprn + real(kind=8) :: rms,frac,frac_nn,co +! call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup),nsup,przes, +! & obr,non_conv) +! rms=dsqrt(rms) + call rmsd(rms) +!elte(iout,*) "rms_nacc before contact" + 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 subroutine rms_nac_nnc +!----------------------------------------------------------------------------- + subroutine rmsd(drms) + + use regularize_, only:fitsq +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif +! include 'COMMON.CHAIN' +! include 'COMMON.IOUNITS' +! include 'COMMON.INTERACT' +! include 'COMMON.CONTROL' + logical :: non_conv + real(kind=8) :: przes(3),obrot(3,3) + real(kind=8),dimension(3,2*nres+2) :: ccopy,crefcopy !(3,maxres2+2) maxres2=2*maxres + +!el local variables + real(kind=8) :: drms,rminroz,roznica + integer :: i,j,iatom,kkk,iti,k + +!el allocate(ccopy(3,2*nres+2),crefcopy(3,2*nres+2)) !(3,maxres2+2) maxres2=2*maxres + + nperm=1 + do i=1,symetr + nperm=nperm*i + enddo + iatom=0 + rminroz=100d2 +! print *,"nz_start",nz_start," nz_end",nz_end +! if (symetr.le.1) then + do kkk=1,nperm +! 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,kkk)=cref(k,i,kkk) +! 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,kkk)=cref(k,nres+i,kkk) +! enddo +! endif +! enddo +! else +! do kkk=1,nperm + iatom=0 + 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,kkk) + 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,kkk) + enddo + endif + enddo +! enddo +! endif + +! ----- diagnostics +! do kkk=1,nperm +! 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) +! enddo +! ----- end diagnostics +! do kkk=1,nperm + 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 +! call mpi_abort(mpi_comm_world,ierror,ierrcode) + roznica=100.0d10 +#else + stop +#endif + endif +! write (iout,*) "roznica", roznica,kkk + if (roznica.le.rminroz) rminroz=roznica + enddo + drms=dsqrt(dabs(rminroz)) +! ---- diagnostics +! write (iout,*) "nperm,symetr", nperm,symetr +! ---- end diagnostics + return + end subroutine rmsd +!----------------------------------------------------------------------------- + subroutine rmsd_csa(drms) + + use regularize_, only:fitsq +! 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 + real(kind=8) :: przes(3),obrot(3,3) + real(kind=8),dimension(:,:),allocatable :: ccopy,crefcopy !(3,maxres2+2) maxres2=2*maxres + integer :: kkk,iatom,ierror,ierrcode + +!el local variables + integer ::i,j,k,iti + real(kind=8) :: drms,roznica + + allocate(ccopy(3,2*nres+2),crefcopy(3,2*nres+2)) !(3,maxres2+2) maxres2=2*maxres + + kkk=1 + 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 subroutine rmsd_csa +!----------------------------------------------------------------------------- +! test.F +!----------------------------------------------------------------------------- + subroutine test + +!el use minim + use geometry, only:pinorm + use random, only:ran_number,iran_num +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + include 'mpif.h' +! 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' + real(kind=8) :: time0,time1 + real(kind=8) :: energy(0:n_ene),ee + real(kind=8),dimension(6*nres) :: var,var1 !(maxvar) (maxvar=6*maxres) + integer :: j1,j2,jr,i,iretcode,nfun,nft_sc + logical :: debug,accepted + real(kind=8) :: etot,rms,da,temp,betbol,etot0,d,phiold,& + xxr,xxh + debug=.true. +!el allocate(var(6*nres),var1(6*nres)) !(maxvar) (maxvar=6*maxres) + + call geom_to_var(nvar,var1) + call chainbuild + call etotal(energy) + 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) +! phi(jr)=pinorm(phi(jr)+d) + call chainbuild + call etotal(energy) + 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) + 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. +! 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) +! minimize +! 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) +! -------- + else + phi(jr)=phiold + endif + enddo + +! minimize +! call sc_move(2,nres-1,1,10d0,nft_sc,etot) +! call geom_to_var(nvar,var) +! +! call chainbuild +! call write_pdb(998 ,'sc min',etot) +! +! call minimize(etot,var,iretcode,nfun) +! write(iout,*)'------------------------------------------------' +! write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun +! +! call var_to_geom(nvar,var) +! call chainbuild +! call write_pdb(999,'full min',etot) + + return + end subroutine test +!----------------------------------------------------------------------------- +!el#ifdef MPI + subroutine test_n16 + +!el use minim +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + include 'mpif.h' +! 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' + real(kind=8) :: time0,time1 + real(kind=8) :: energy(0:n_ene),ee + real(kind=8),dimension(:),allocatable :: var,var1 !(maxvar) (maxvar=6*maxres) + integer :: jdata(5) + logical :: debug +!el local variables + integer :: i,ij,ieval,iretcode,nfun + real(kind=8) :: etot + debug=.true. + allocate(var(6*nres),var1(6*nres)) !(maxvar) (maxvar=6*maxres) +! + call geom_to_var(nvar,var1) + call chainbuild + call etotal(energy) + etot=energy(0) + write(iout,*) nnt,nct,etot + call write_pdb(1,'first structure',etot) + call secondary2(.true.) + + do i=1,4 + jdata(i)=bfrag(i,2) + enddo + + DO ij=1,4 + ieval=0 + jdata(5)=ij + call var_to_geom(nvar,var1) + write(iout,*) 'N16 test',(jdata(i),i=1,5) + call beta_slide(jdata(1),jdata(2),jdata(3),jdata(4),jdata(5), & + ieval,ij) + call geom_to_var(nvar,var) + + if (minim) then +!el#ifdef MPI + time0=MPI_WTIME() +!el#endif + call minimize(etot,var,iretcode,nfun) + write(iout,*)'------------------------------------------------' + write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun,& + '+ DIST eval',ieval + +!el#ifdef MPI + time1=MPI_WTIME() +!el#endif + write (iout,'(a,f6.2,f8.2,a)')' Time for full min.',time1-time0,& + nfun/(time1-time0),' eval/s' + + call var_to_geom(nvar,var) + call chainbuild + call write_pdb(ij*100+99,'full min',etot) + endif + + + ENDDO + + return + end subroutine test_n16 +!el#endif +!----------------------------------------------------------------------------- + subroutine test_local + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' + real(kind=8) :: time0,time1 + real(kind=8) :: energy(0:n_ene),ee + real(kind=8),dimension(6*nres) :: varia !(maxvar) (maxvar=6*maxres) + integer :: nft_sc + real(kind=8) :: etot +! +! allocate(varia(6*nres)) !(maxvar) (maxvar=6*maxres) + call chainbuild +! call geom_to_var(nvar,varia) + call write_pdb(1,'first structure',0d0) + + call etotal(energy) + 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_local +!----------------------------------------------------------------------------- + subroutine test_sc + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.GEO' +! include 'COMMON.VAR' +! include 'COMMON.INTERACT' +! include 'COMMON.IOUNITS' + real(kind=8) :: time0,time1,etot + real(kind=8) :: energy(0:n_ene),ee + real(kind=8),dimension(6*nres) :: varia !(maxvar) (maxvar=6*maxres) + integer :: nft_sc +! + call chainbuild +! call geom_to_var(nvar,varia) + call write_pdb(1,'first structure',0d0) + + call etotal(energy) + 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 subroutine test_sc +!----------------------------------------------------------------------------- + subroutine bgrow(bstrand,nbstrand,in,ind,new) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CHAIN' + integer,dimension(nres/3,6) :: bstrand !(maxres/3,6) + +!el local variables + integer :: nbstrand,in,ind,new,ishift,i + + 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 subroutine bgrow +!----------------------------------------------------------------------------- + subroutine test11 + + use geometry, only:dist +!el use minim +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + include 'mpif.h' +! 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.DISTFIT' + integer :: if(20,nres),nif,ifa(20) + integer :: ibc(0:nres,0:nres),istrand(20) + integer :: ibd(nres),ifb(10,2),nifb,lifb(10),lifb0 + integer :: itmp(20,nres) + real(kind=8) :: time0,time1 + real(kind=8) :: energy(0:n_ene),ee + real(kind=8),dimension(6*nres) :: varia,vorg !(maxvar) (maxvar=6*maxres) +! + logical :: debug,ltest,usedbfrag(nres/3) + character(len=50) :: linia +! + integer :: betasheet(nres),ibetasheet(nres),nbetasheet + integer :: bstrand(nres/3,6),nbstrand + real(kind=8) :: etot + integer :: i,j,jk,k,isa,m,l,ig,iconf,is,ii,iused_nbfrag,& + in,ind,ifun,nfun,iretcode +!------------------------ + + debug=.true. +!------------------------ + nbstrand=0 + nbetasheet=0 + do i=1,nres + betasheet(i)=0 + ibetasheet(i)=0 + enddo + call geom_to_var(nvar,vorg) + call secondary2(debug) + + if (nbfrag.le.1) return + + do i=1,nbfrag + usedbfrag(i)=.false. + enddo + + + nbetasheet=nbetasheet+1 + nbstrand=2 + bstrand(1,1)=bfrag(1,1) + bstrand(1,2)=bfrag(2,1) + bstrand(1,3)=nbetasheet + bstrand(1,4)=1 + bstrand(1,5)=bfrag(1,1) + bstrand(1,6)=bfrag(2,1) + do i=bfrag(1,1),bfrag(2,1) + betasheet(i)=nbetasheet + ibetasheet(i)=1 + enddo +! + bstrand(2,1)=bfrag(3,1) + bstrand(2,2)=bfrag(4,1) + bstrand(2,3)=nbetasheet + bstrand(2,5)=bfrag(3,1) + bstrand(2,6)=bfrag(4,1) + + if (bfrag(3,1).le.bfrag(4,1)) then + bstrand(2,4)=2 + do i=bfrag(3,1),bfrag(4,1) + betasheet(i)=nbetasheet + ibetasheet(i)=2 + enddo + else + bstrand(2,4)=-2 + do i=bfrag(4,1),bfrag(3,1) + betasheet(i)=nbetasheet + ibetasheet(i)=2 + enddo + endif + + iused_nbfrag=1 + + do while (iused_nbfrag.ne.nbfrag) + + do j=2,nbfrag + + IF (.not.usedbfrag(j)) THEN + + write (*,*) j,(bfrag(i,j),i=1,4) + do jk=6,1,-1 + write (*,'(i4,a3,10i4)') jk,'B',(bstrand(i,jk),i=1,nbstrand) + enddo + write (*,*) '------------------' + + + if (bfrag(3,j).le.bfrag(4,j)) then + do i=bfrag(3,j),bfrag(4,j) + if(betasheet(i).eq.nbetasheet) then + in=ibetasheet(i) + do k=bfrag(3,j),bfrag(4,j) + betasheet(k)=nbetasheet + ibetasheet(k)=in + enddo + nbstrand=nbstrand+1 + usedbfrag(j)=.true. + iused_nbfrag=iused_nbfrag+1 + do k=bfrag(1,j),bfrag(2,j) + betasheet(k)=nbetasheet + ibetasheet(k)=nbstrand + enddo + if (bstrand(in,4).lt.0) then + bstrand(nbstrand,1)=bfrag(2,j) + bstrand(nbstrand,2)=bfrag(1,j) + bstrand(nbstrand,3)=nbetasheet + bstrand(nbstrand,4)=-nbstrand + bstrand(nbstrand,5)=bstrand(nbstrand,1) + bstrand(nbstrand,6)=bstrand(nbstrand,2) + if(bstrand(in,1).lt.bfrag(4,j)) then + call bgrow(bstrand,nbstrand,in,1,bfrag(4,j)) + else + bstrand(nbstrand,5)=bstrand(nbstrand,5)+& + (bstrand(in,5)-bfrag(4,j)) + endif + if(bstrand(in,2).gt.bfrag(3,j)) then + call bgrow(bstrand,nbstrand,in,2,bfrag(3,j)) + else + bstrand(nbstrand,6)=bstrand(nbstrand,6)-& + (-bstrand(in,6)+bfrag(3,j)) + endif + else + bstrand(nbstrand,1)=bfrag(1,j) + bstrand(nbstrand,2)=bfrag(2,j) + bstrand(nbstrand,3)=nbetasheet + bstrand(nbstrand,4)=nbstrand + bstrand(nbstrand,5)=bstrand(nbstrand,1) + bstrand(nbstrand,6)=bstrand(nbstrand,2) + if(bstrand(in,1).gt.bfrag(3,j)) then + call bgrow(bstrand,nbstrand,in,1,bfrag(3,j)) + else + bstrand(nbstrand,5)=bstrand(nbstrand,5)-& + (-bstrand(in,5)+bfrag(3,j)) + endif + if(bstrand(in,2).lt.bfrag(4,j)) then + call bgrow(bstrand,nbstrand,in,2,bfrag(4,j)) + else + bstrand(nbstrand,6)=bstrand(nbstrand,6)+& + (bstrand(in,6)-bfrag(4,j)) + endif + endif + goto 11 + endif + if(betasheet(bfrag(1,j)+i-bfrag(3,j)).eq.nbetasheet) then + in=ibetasheet(bfrag(1,j)+i-bfrag(3,j)) + do k=bfrag(1,j),bfrag(2,j) + betasheet(k)=nbetasheet + ibetasheet(k)=in + enddo + nbstrand=nbstrand+1 + usedbfrag(j)=.true. + iused_nbfrag=iused_nbfrag+1 + do k=bfrag(3,1),bfrag(4,1) + betasheet(k)=nbetasheet + ibetasheet(k)=nbstrand + enddo + if (bstrand(in,4).lt.0) then + bstrand(nbstrand,1)=bfrag(4,j) + bstrand(nbstrand,2)=bfrag(3,j) + bstrand(nbstrand,3)=nbetasheet + bstrand(nbstrand,4)=-nbstrand + bstrand(nbstrand,5)=bstrand(nbstrand,1) + bstrand(nbstrand,6)=bstrand(nbstrand,2) + if(bstrand(in,1).lt.bfrag(2,j)) then + call bgrow(bstrand,nbstrand,in,1,bfrag(2,j)) + else + bstrand(nbstrand,5)=bstrand(nbstrand,5)+& + (bstrand(in,5)-bfrag(2,j)) + endif + if(bstrand(in,2).gt.bfrag(1,j)) then + call bgrow(bstrand,nbstrand,in,2,bfrag(1,j)) + else + bstrand(nbstrand,6)=bstrand(nbstrand,6)-& + (-bstrand(in,6)+bfrag(1,j)) + endif + else + bstrand(nbstrand,1)=bfrag(3,j) + bstrand(nbstrand,2)=bfrag(4,j) + bstrand(nbstrand,3)=nbetasheet + bstrand(nbstrand,4)=nbstrand + bstrand(nbstrand,5)=bstrand(nbstrand,1) + bstrand(nbstrand,6)=bstrand(nbstrand,2) + if(bstrand(in,1).gt.bfrag(1,j)) then + call bgrow(bstrand,nbstrand,in,1,bfrag(1,j)) + else + bstrand(nbstrand,5)=bstrand(nbstrand,5)-& + (-bstrand(in,5)+bfrag(1,j)) + endif + if(bstrand(in,2).lt.bfrag(2,j)) then + call bgrow(bstrand,nbstrand,in,2,bfrag(2,j)) + else + bstrand(nbstrand,6)=bstrand(nbstrand,6)+& + (bstrand(in,6)-bfrag(2,j)) + endif + endif + goto 11 + endif + enddo + else + do i=bfrag(4,j),bfrag(3,j) + if(betasheet(i).eq.nbetasheet) then + in=ibetasheet(i) + do k=bfrag(4,j),bfrag(3,j) + betasheet(k)=nbetasheet + ibetasheet(k)=in + enddo + nbstrand=nbstrand+1 + usedbfrag(j)=.true. + iused_nbfrag=iused_nbfrag+1 + do k=bfrag(1,j),bfrag(2,j) + betasheet(k)=nbetasheet + ibetasheet(k)=nbstrand + enddo + if (bstrand(in,4).lt.0) then + bstrand(nbstrand,1)=bfrag(1,j) + bstrand(nbstrand,2)=bfrag(2,j) + bstrand(nbstrand,3)=nbetasheet + bstrand(nbstrand,4)=nbstrand + bstrand(nbstrand,5)=bstrand(nbstrand,1) + bstrand(nbstrand,6)=bstrand(nbstrand,2) + if(bstrand(in,1).lt.bfrag(3,j)) then + call bgrow(bstrand,nbstrand,in,1,bfrag(3,j)) + else + bstrand(nbstrand,5)=bstrand(nbstrand,5)-& + (bstrand(in,5)-bfrag(3,j)) + endif + if(bstrand(in,2).gt.bfrag(4,j)) then + call bgrow(bstrand,nbstrand,in,2,bfrag(4,j)) + else + bstrand(nbstrand,6)=bstrand(nbstrand,6)+& + (-bstrand(in,6)+bfrag(4,j)) + endif + else + bstrand(nbstrand,1)=bfrag(2,j) + bstrand(nbstrand,2)=bfrag(1,j) + bstrand(nbstrand,3)=nbetasheet + bstrand(nbstrand,4)=-nbstrand + bstrand(nbstrand,5)=bstrand(nbstrand,1) + bstrand(nbstrand,6)=bstrand(nbstrand,2) + if(bstrand(in,1).gt.bfrag(4,j)) then + call bgrow(bstrand,nbstrand,in,1,bfrag(4,j)) + else + bstrand(nbstrand,5)=bstrand(nbstrand,5)+& + (-bstrand(in,5)+bfrag(4,j)) + endif + if(bstrand(in,2).lt.bfrag(3,j)) then + call bgrow(bstrand,nbstrand,in,2,bfrag(3,j)) + else + bstrand(nbstrand,6)=bstrand(nbstrand,6)-& + (bstrand(in,6)-bfrag(3,j)) + endif + endif + goto 11 + endif + if(betasheet(bfrag(2,j)-i+bfrag(4,j)).eq.nbetasheet) then + in=ibetasheet(bfrag(2,j)-i+bfrag(4,j)) + do k=bfrag(1,j),bfrag(2,j) + betasheet(k)=nbetasheet + ibetasheet(k)=in + enddo + nbstrand=nbstrand+1 + usedbfrag(j)=.true. + iused_nbfrag=iused_nbfrag+1 + do k=bfrag(4,j),bfrag(3,j) + betasheet(k)=nbetasheet + ibetasheet(k)=nbstrand + enddo + if (bstrand(in,4).lt.0) then + bstrand(nbstrand,1)=bfrag(4,j) + bstrand(nbstrand,2)=bfrag(3,j) + bstrand(nbstrand,3)=nbetasheet + bstrand(nbstrand,4)=nbstrand + bstrand(nbstrand,5)=bstrand(nbstrand,1) + bstrand(nbstrand,6)=bstrand(nbstrand,2) + if(bstrand(in,1).lt.bfrag(2,j)) then + call bgrow(bstrand,nbstrand,in,1,bfrag(2,j)) + else + bstrand(nbstrand,5)=bstrand(nbstrand,5)-& + (bstrand(in,5)-bfrag(2,j)) + endif + if(bstrand(in,2).gt.bfrag(1,j)) then + call bgrow(bstrand,nbstrand,in,2,bfrag(1,j)) + else + bstrand(nbstrand,6)=bstrand(nbstrand,6)+& + (-bstrand(in,6)+bfrag(1,j)) + endif + else + bstrand(nbstrand,1)=bfrag(3,j) + bstrand(nbstrand,2)=bfrag(4,j) + bstrand(nbstrand,3)=nbetasheet + bstrand(nbstrand,4)=-nbstrand + bstrand(nbstrand,5)=bstrand(nbstrand,1) + bstrand(nbstrand,6)=bstrand(nbstrand,2) + if(bstrand(in,1).gt.bfrag(1,j)) then + call bgrow(bstrand,nbstrand,in,1,bfrag(1,j)) + else + bstrand(nbstrand,5)=bstrand(nbstrand,5)+& + (-bstrand(in,5)+bfrag(1,j)) + endif + if(bstrand(in,2).lt.bfrag(2,j)) then + call bgrow(bstrand,nbstrand,in,2,bfrag(2,j)) + else + bstrand(nbstrand,6)=bstrand(nbstrand,6)-& + (bstrand(in,6)-bfrag(2,j)) + endif + endif + goto 11 + endif + enddo + endif + + + + ENDIF + enddo + + j=2 + do while (usedbfrag(j)) + j=j+1 + enddo + + nbstrand=nbstrand+1 + nbetasheet=nbetasheet+1 + bstrand(nbstrand,1)=bfrag(1,j) + bstrand(nbstrand,2)=bfrag(2,j) + bstrand(nbstrand,3)=nbetasheet + bstrand(nbstrand,5)=bfrag(1,j) + bstrand(nbstrand,6)=bfrag(2,j) + + bstrand(nbstrand,4)=nbstrand + do i=bfrag(1,j),bfrag(2,j) + betasheet(i)=nbetasheet + ibetasheet(i)=nbstrand + enddo +! + nbstrand=nbstrand+1 + bstrand(nbstrand,1)=bfrag(3,j) + bstrand(nbstrand,2)=bfrag(4,j) + bstrand(nbstrand,3)=nbetasheet + bstrand(nbstrand,5)=bfrag(3,j) + bstrand(nbstrand,6)=bfrag(4,j) + + if (bfrag(3,j).le.bfrag(4,j)) then + bstrand(nbstrand,4)=nbstrand + do i=bfrag(3,j),bfrag(4,j) + betasheet(i)=nbetasheet + ibetasheet(i)=nbstrand + enddo + else + bstrand(nbstrand,4)=-nbstrand + do i=bfrag(4,j),bfrag(3,j) + betasheet(i)=nbetasheet + ibetasheet(i)=nbstrand + enddo + endif + + iused_nbfrag=iused_nbfrag+1 + usedbfrag(j)=.true. + + + 11 continue + do jk=6,1,-1 + write (*,'(i4,a3,10i4)') jk,'A',(bstrand(i,jk),i=1,nbstrand) + enddo + + + enddo + + do i=1,nres + if (betasheet(i).ne.0) write(*,*) i,betasheet(i),ibetasheet(i) + enddo + write(*,*) + do j=6,1,-1 + write (*,'(i4,a3,10i4)') j,':',(bstrand(i,j),i=1,nbstrand) + enddo + +!------------------------ + nifb=0 + do i=1,nbstrand + do j=i+1,nbstrand + if(iabs(bstrand(i,5)-bstrand(j,5)).le.5 .or. & + iabs(bstrand(i,6)-bstrand(j,6)).le.5 ) then + nifb=nifb+1 + ifb(nifb,1)=bstrand(i,4) + ifb(nifb,2)=bstrand(j,4) + endif + enddo + enddo + + write(*,*) + do i=1,nifb + write (*,'(a3,20i4)') "ifb",i,ifb(i,1),ifb(i,2) + enddo + + do i=1,nbstrand + ifa(i)=bstrand(i,4) + enddo + write (*,'(a3,20i4)') "ifa",(ifa(i),i=1,nbstrand) + + nif=iabs(bstrand(1,6)-bstrand(1,5))+1 + do j=2,nbstrand + if (iabs(bstrand(j,6)-bstrand(j,5))+1.gt.nif) & + nif=iabs(bstrand(j,6)-bstrand(j,5))+1 + enddo + + write(*,*) nif + do i=1,nif + do j=1,nbstrand + if(j,i)=bstrand(j,6)+(i-1)*sign(1,bstrand(j,5)-bstrand(j,6)) + if (if(j,i).gt.0) then + if(betasheet(if(j,i)).eq.0 .or. & + ibetasheet(if(j,i)).ne.iabs(bstrand(j,4))) if(j,i)=0 + else + if(j,i)=0 + endif + enddo + write(*,'(a3,10i4)') 'if ',(if(j,i),j=1,nbstrand) + enddo + +! read (inp,*) (ifa(i),i=1,4) +! do i=1,nres +! read (inp,*,err=20,end=20) (if(j,i),j=1,4) +! enddo +! 20 nif=i-1 + stop +!------------------------ + + isa=4 + is=2*isa-1 + iconf=0 +!ccccccccccccccccccccccccccccccccc + DO ig=1,is**isa-1 +!ccccccccccccccccccccccccccccccccc + + ii=ig + do j=1,is + istrand(is-j+1)=int(ii/is**(is-j)) + ii=ii-istrand(is-j+1)*is**(is-j) + enddo + ltest=.true. + do k=1,isa + istrand(k)=istrand(k)+1 + if(istrand(k).gt.isa) istrand(k)=istrand(k)-2*isa-1 + enddo + do k=1,isa + do l=1,isa + if(istrand(k).eq.istrand(l).and.k.ne.l.or. & + istrand(k).eq.-istrand(l).and.k.ne.l) ltest=.false. + enddo + enddo + + lifb0=1 + do m=1,nifb + lifb(m)=0 + do k=1,isa-1 + if( & + ifb(m,1).eq.istrand(k).and.ifb(m,2).eq.istrand(k+1).or. & + ifb(m,2).eq.istrand(k).and.ifb(m,1).eq.istrand(k+1).or. & + -ifb(m,1).eq.istrand(k).and.-ifb(m,2).eq.istrand(k+1).or. & + -ifb(m,2).eq.istrand(k).and.-ifb(m,1).eq.istrand(k+1)) & + lifb(m)=1 + enddo + lifb0=lifb0*lifb(m) + enddo + + if (mod(isa,2).eq.0) then + do k=isa/2+1,isa + if (istrand(k).eq.1) ltest=.false. + enddo + else + do k=(isa+1)/2+1,isa + if (istrand(k).eq.1) ltest=.false. + enddo + endif + + IF (ltest.and.lifb0.eq.1) THEN + iconf=iconf+1 + + call var_to_geom(nvar,vorg) + + write (*,'(i5,i10,10i3)') iconf,ig,(istrand(k),k=1,isa) + write (iout,'(i5,i10,10i3)') iconf,ig,(istrand(k),k=1,isa) + write (linia,'(10i3)') (istrand(k),k=1,isa) + + do i=1,nres + do j=1,nres + ibc(i,j)=0 + enddo + enddo + + + do i=1,4 + if ( sign(1,istrand(i)).eq.sign(1,ifa(iabs(istrand(i)))) ) then + do j=1,nif + itmp(iabs(istrand(i)),j)=if(iabs(ifa(iabs(istrand(i)))),j) + enddo + else + do j=1,nif + itmp(iabs(istrand(i)),j)=if(iabs(ifa(iabs(istrand(i)))),nif-j+1) + enddo + endif + enddo + + do i=1,nif + write(*,*) (itmp(j,i),j=1,4) + enddo + + do i=1,nif +! ifa(1),ifa(2),ifa(3),ifa(4) +! if(1,i),if(2,i),if(3,i),if(4,i) + do k=1,isa-1 + ltest=.false. + do m=1,nifb + if( & + ifb(m,1).eq.istrand(k).and.ifb(m,2).eq.istrand(k+1).or. & + ifb(m,2).eq.istrand(k).and.ifb(m,1).eq.istrand(k+1).or. & + -ifb(m,1).eq.istrand(k).and.-ifb(m,2).eq.istrand(k+1).or. & + -ifb(m,2).eq.istrand(k).and.-ifb(m,1).eq.istrand(k+1)) & + then + ltest=.true. + goto 110 + endif + enddo + 110 continue + if (ltest) then + ibc(itmp(iabs(istrand(k)),i),itmp(iabs(istrand(k+1)),i))=-1 + else + ibc(itmp(iabs(istrand(k)),i),itmp(iabs(istrand(k+1)),i))=-2 + endif +! + if (k.lt.3) & + ibc(itmp(iabs(istrand(k)),i),itmp(iabs(istrand(k+2)),i))=-3 + if (k.lt.2) & + ibc(itmp(iabs(istrand(k)),i),itmp(iabs(istrand(k+3)),i))=-4 + enddo + enddo +!------------------------ + +! +! freeze sec.elements +! + do i=1,nres + mask(i)=1 + mask_phi(i)=1 + mask_theta(i)=1 + mask_side(i)=1 + enddo + + do j=1,nbfrag + do i=bfrag(1,j),bfrag(2,j) + mask(i)=0 + mask_phi(i)=0 + mask_theta(i)=0 + enddo + if (bfrag(3,j).le.bfrag(4,j)) then + do i=bfrag(3,j),bfrag(4,j) + mask(i)=0 + mask_phi(i)=0 + mask_theta(i)=0 + enddo + else + do i=bfrag(4,j),bfrag(3,j) + mask(i)=0 + mask_phi(i)=0 + mask_theta(i)=0 + enddo + endif + enddo + do j=1,nhfrag + do i=hfrag(1,j),hfrag(2,j) + mask(i)=0 + mask_phi(i)=0 + mask_theta(i)=0 + enddo + enddo + mask_r=.true. + +!------------------------ +! generate constrains +! + nhpb0=nhpb + call chainbuild + ind=0 + do i=1,nres-3 + do j=i+3,nres + ind=ind+1 + if ( ibc(i,j).eq.-1 .or. ibc(j,i).eq.-1) then + d0(ind)=DIST(i,j) + w(ind)=10.0 + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=10.0 + dhpb(nhpb)=d0(ind) + else if ( ibc(i,j).eq.-2 .or. ibc(j,i).eq.-2) then + d0(ind)=5.0 + w(ind)=10.0 + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=10.0 + dhpb(nhpb)=d0(ind) + else if ( ibc(i,j).eq.-3 .or. ibc(j,i).eq.-3) then + d0(ind)=11.0 + w(ind)=10.0 + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=10.0 + dhpb(nhpb)=d0(ind) + else if ( ibc(i,j).eq.-4 .or. ibc(j,i).eq.-4) then + d0(ind)=16.0 + w(ind)=10.0 + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=10.0 + dhpb(nhpb)=d0(ind) + else if ( ibc(i,j).gt.0 ) then + d0(ind)=DIST(i,ibc(i,j)) + w(ind)=10.0 + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=10.0 + dhpb(nhpb)=d0(ind) + else if ( ibc(j,i).gt.0 ) then + d0(ind)=DIST(ibc(j,i),j) + w(ind)=10.0 + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=10.0 + dhpb(nhpb)=d0(ind) + else + w(ind)=0.0 + endif + ddd(ind)=d0(ind) + enddo + enddo + call hpb_partition +!d-------------------------- + + write(iout,'(i3,2i4,a3,2i4,f7.2)') (i,ibc(ihpb(i),jhpb(i)),& + ibc(jhpb(i),ihpb(i)),' --',& + ihpb(i),jhpb(i),dhpb(i),i=1,nhpb) + +!d nhpb=0 +!d goto 901 +! +! +!el#ifdef MPI + call contact_cp_min(varia,ifun,iconf,linia,debug) + if (minim) then +!el#ifdef MPI + time0=MPI_WTIME() +!el#endif + call minimize(etot,varia,iretcode,nfun) + write(iout,*)'------------------------------------------------' + write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun,& + '+ DIST eval',ifun + +!el#ifdef MPI + time1=MPI_WTIME() +!el#endif + write (iout,'(a,f6.2,f8.2,a)')' Time for full min.',time1-time0,& + nfun/(time1-time0),' eval/s' + + write (linia,'(a10,10i3)') 'full_min',(istrand(k),k=1,isa) + call var_to_geom(nvar,varia) + call chainbuild + call write_pdb(900+iconf,linia,etot) + endif +!el#endif + call etotal(energy) + etot=energy(0) + call enerprint(energy) +!d call intout +!d call briefout(0,etot) +!d call secondary2(.true.) + + 901 CONTINUE +!test return +!ccccccccccccccccccccccccccccccccccc + ENDIF + ENDDO +!ccccccccccccccccccccccccccccccccccc + + return + 10 write (iout,'(a)') 'Error reading test structure.' + return + end subroutine test11 +!----------------------------------------------------------------------------- + subroutine test3 + + use geometry, only:dist +!el use minim +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + include 'mpif.h' +! 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.DISTFIT' + integer :: if(3,nres),nif + integer :: ibc(nres,nres),istrand(20) + integer :: ibd(nres),ifb(10,2),nifb,lifb(10),lifb0 + real(kind=8) :: time0,time1 + real(kind=8) :: energy(0:n_ene),ee + real(kind=8),dimension(6*nres) :: varia !(maxvar) (maxvar=6*maxres) +! + logical :: debug,ltest + character(len=50) :: linia + integer :: ieval,i,j,ind,in_pdb,nfun,iretcode + real(kind=8) :: etot +! + do i=1,nres + read (inp,*,err=20,end=20) if(1,i),if(2,i),if(3,i) + enddo + 20 nif=i-1 + write (*,'(a4,3i5)') ('if =',if(1,i),if(2,i),if(3,i),& + i=1,nif) + + +!------------------------ + call secondary2(debug) +!------------------------ + do i=1,nres + do j=1,nres + ibc(i,j)=0 + enddo + enddo + +! +! freeze sec.elements and store indexes for beta constrains +! + do i=1,nres + mask(i)=1 + mask_phi(i)=1 + mask_theta(i)=1 + mask_side(i)=1 + enddo + + do j=1,nbfrag + do i=bfrag(1,j),bfrag(2,j) + mask(i)=0 + mask_phi(i)=0 + mask_theta(i)=0 + enddo + if (bfrag(3,j).le.bfrag(4,j)) then + do i=bfrag(3,j),bfrag(4,j) + mask(i)=0 + mask_phi(i)=0 + mask_theta(i)=0 + ibc(bfrag(1,j)+i-bfrag(3,j),i)=-1 + enddo + else + do i=bfrag(4,j),bfrag(3,j) + mask(i)=0 + mask_phi(i)=0 + mask_theta(i)=0 + ibc(bfrag(2,j)-i+bfrag(4,j),i)=-1 + enddo + endif + enddo + do j=1,nhfrag + do i=hfrag(1,j),hfrag(2,j) + mask(i)=0 + mask_phi(i)=0 + mask_theta(i)=0 + enddo + enddo + mask_r=.true. + + +! ---------------- test -------------- + do i=1,nif + if (ibc(if(1,i),if(2,i)).eq.-1) then + ibc(if(1,i),if(2,i))=if(3,i) + ibc(if(1,i),if(3,i))=if(2,i) + else if (ibc(if(2,i),if(1,i)).eq.-1) then + ibc(if(2,i),if(1,i))=0 + ibc(if(1,i),if(2,i))=if(3,i) + ibc(if(1,i),if(3,i))=if(2,i) + else + ibc(if(1,i),if(2,i))=if(3,i) + ibc(if(1,i),if(3,i))=if(2,i) + endif + enddo + + do i=1,nres + do j=1,nres + if (ibc(i,j).ne.0) write(*,'(3i5)') i,j,ibc(i,j) + enddo + enddo +!------------------------ + call chainbuild + ind=0 + do i=1,nres-3 + do j=i+3,nres + ind=ind+1 + if ( ibc(i,j).eq.-1 ) then + d0(ind)=DIST(i,j) + w(ind)=10.0 + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=10.0 + dhpb(nhpb)=d0(ind) + else if ( ibc(i,j).gt.0 ) then + d0(ind)=DIST(i,ibc(i,j)) + w(ind)=10.0 + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=10.0 + dhpb(nhpb)=d0(ind) + else if ( ibc(j,i).gt.0 ) then + d0(ind)=DIST(ibc(j,i),j) + w(ind)=10.0 + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=10.0 + dhpb(nhpb)=d0(ind) + else + w(ind)=0.0 + endif + enddo + enddo + call hpb_partition + +!d-------------------------- + write(*,'(i3,2i4,a3,2i4,f7.2)') (i,ibc(ihpb(i),jhpb(i)),& + ibc(jhpb(i),ihpb(i)),' --',& + ihpb(i),jhpb(i),dhpb(i),i=1,nhpb) + + + linia='dist' + debug=.true. + in_pdb=7 +! +!el#ifdef MPI + call contact_cp_min(varia,ieval,in_pdb,linia,debug) + if (minim) then +!el#ifdef MPI + time0=MPI_WTIME() +!el#endif + call minimize(etot,varia,iretcode,nfun) + write(iout,*)'------------------------------------------------' + write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun,& + '+ DIST eval',ieval + +!el#ifdef MPI + time1=MPI_WTIME() +!el#endif + write (iout,'(a,f6.2,f8.2,a)')' Time for full min.',time1-time0,& + nfun/(time1-time0),' eval/s' + + + call var_to_geom(nvar,varia) + call chainbuild + call write_pdb(999,'full min',etot) + endif +!el#endif + call etotal(energy) + etot=energy(0) + call enerprint(energy) + call intout + call briefout(0,etot) + call secondary2(.true.) + + return + 10 write (iout,'(a)') 'Error reading test structure.' + return + end subroutine test3 +!----------------------------------------------------------------------------- + subroutine test__ + +!el use minim +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + include 'mpif.h' +! 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.DISTFIT' + integer :: if(2,2),ind + integer :: iff(nres) + real(kind=8) :: time0,time1 + real(kind=8) :: energy(0:n_ene),ee + real(kind=8),dimension(nres) :: theta2,phi2,alph2,omeg2,& + theta1,phi1,alph1,omeg1 !(maxres) + real(kind=8),dimension(6*nres) :: varia,varia2 !(maxvar) (maxvar=6*maxres) +! + integer :: i,j,nn,ifun,iretcode,nfun + real(kind=8) :: etot + nn=0 + + read (inp,*,err=10,end=10) if(1,1),if(1,2),if(2,1),if(2,2) + write (iout,'(a4,4i5)') 'if =',if(1,1),if(1,2),if(2,1),if(2,2) + read (inp,*,err=10,end=10) (theta2(i),i=3,nres) + read (inp,*,err=10,end=10) (phi2(i),i=4,nres) + read (inp,*,err=10,end=10) (alph2(i),i=2,nres-1) + read (inp,*,err=10,end=10) (omeg2(i),i=2,nres-1) + do i=1,nres + theta2(i)=deg2rad*theta2(i) + phi2(i)=deg2rad*phi2(i) + alph2(i)=deg2rad*alph2(i) + omeg2(i)=deg2rad*omeg2(i) + enddo + do i=1,nres + theta1(i)=theta(i) + phi1(i)=phi(i) + alph1(i)=alph(i) + omeg1(i)=omeg(i) + enddo + + do i=1,nres + mask(i)=1 + enddo + + +!------------------------ + do i=1,nres + iff(i)=0 + enddo + do j=1,2 + do i=if(j,1),if(j,2) + iff(i)=1 + enddo + enddo + + call chainbuild + call geom_to_var(nvar,varia) + call write_pdb(1,'first structure',0d0) + + call secondary(.true.) + + call secondary2(.true.) + + do j=1,nbfrag + if ( (bfrag(3,j).lt.bfrag(4,j) .or. & + bfrag(4,j)-bfrag(2,j).gt.4) .and. & + bfrag(2,j)-bfrag(1,j).gt.3 ) then + nn=nn+1 + + if (bfrag(3,j).lt.bfrag(4,j)) then + write(iout,'(a6,i3,a1,i3,a1,i3,a1,i3)') & + "select",bfrag(1,j)-1,"-",bfrag(2,j)-1,& + ",",bfrag(3,j)-1,"-",bfrag(4,j)-1 + else + write(iout,'(a6,i3,a1,i3,a1,i3,a1,i3)') & + "select",bfrag(1,j)-1,"-",bfrag(2,j)-1,& + ",",bfrag(4,j)-1,"-",bfrag(3,j)-1 + endif + endif + enddo + + do i=1,nres + theta(i)=theta2(i) + phi(i)=phi2(i) + alph(i)=alph2(i) + omeg(i)=omeg2(i) + enddo + + call chainbuild + call geom_to_var(nvar,varia2) + call write_pdb(2,'second structure',0d0) + + + +!------------------------------------------------------- +!el#ifdef MPI + ifun=-1 + call contact_cp(varia,varia2,iff,ifun,7) + if (minim) then +!el#ifdef MPI + time0=MPI_WTIME() +!el#endif + call minimize(etot,varia,iretcode,nfun) + write(iout,*)'------------------------------------------------' + write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun,& + '+ DIST eval',ifun + +!el#ifdef MPI + time1=MPI_WTIME() +!el#endif + write (iout,'(a,f6.2,f8.2,a)')' Time for full min.',time1-time0,& + nfun/(time1-time0),' eval/s' + + + call var_to_geom(nvar,varia) + call chainbuild + call write_pdb(999,'full min',etot) + endif +!el#endif + call etotal(energy) + etot=energy(0) + call enerprint(energy) + call intout + call briefout(0,etot) + + return + 10 write (iout,'(a)') 'Error reading test structure.' + return + end subroutine test__ +!----------------------------------------------------------------------------- + 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,nres*nres/2),isec(nres,3) + logical :: lprint,not_done + real(kind=4) :: dcont(nres*nres/2),d + real(kind=4) :: rcomp = 7.0 + real(kind=4) :: rbeta = 5.2 + real(kind=4) :: ralfa = 5.2 + real(kind=4) :: r310 = 6.6 + real(kind=8),dimension(3) :: xpi,xpj + integer :: i,k,j,i1,j1,nbeta,nstrand,ii1,jj1,ij,iii1,jjj1,& + nhelix + call chainbuild +!d 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 +!d d = (c(1,i)-c(1,j))*(c(1,i)-c(1,j)) + +!d & (c(2,i)-c(2,j))*(c(2,i)-c(2,j)) + +!d & (c(3,i)-c(3,j))*(c(3,i)-c(3,j)) +!d 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 + +! finding parallel beta +!d 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 +!d 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 +!d 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 + +! finding antiparallel beta +!d 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 +!d 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 +!d 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 + + +! 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 +!d if (j1.eq.i1+3) write (iout,*) "found 1-4 ",i1,j1,dcont(i) +!d 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 +!d write (iout,*) i1,j1,not_done + enddo + j1=j1-1 + if (j1-ii1.gt.4) then + nhelix=nhelix+1 +!d 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 subroutine secondary +!----------------------------------------------------------------------------- + subroutine contact_cp2(var,var2,iff,ieval,in_pdb) + + use geometry, only:dist +!el use minim +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + include 'mpif.h' +! include 'COMMON.SBRIDGE' +! include 'COMMON.FFIELD' +! include 'COMMON.IOUNITS' +! include 'COMMON.DISTFIT' +! include 'COMMON.VAR' +! include 'COMMON.CHAIN' +! include 'COMMON.MINIM' + + character(len=50) :: linia + integer :: nf,ij(4) + real(kind=8),dimension(6*nres) :: var,var2 !(maxvar) (maxvar=6*maxres) + real(kind=8) :: time0,time1 + integer :: iff(nres),ieval + real(kind=8),dimension(nres) :: theta1,phi1,alph1,omeg1 !(maxres) + +!el local variables + integer :: in_pdb,i,j,ind,ipot0,maxmin0,maxfun0,nfun,iwsk,iretcode + real(kind=8) :: wstrain0,etot + integer :: maxres22 + maxres22=nres*(nres+1)/2 + + if(.not.allocated(DRDG)) allocate(DRDG(maxres22,maxres22)) !(MAXRES22,MAXRES) + call var_to_geom(nvar,var) + call chainbuild + nhpb0=nhpb + ind=0 + do i=1,nres-3 + do j=i+3,nres + ind=ind+1 + if ( iff(i).eq.1.and.iff(j).eq.1 ) then + d0(ind)=DIST(i,j) + w(ind)=10.0 + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=10.0 + dhpb(nhpb)=d0(ind) + else + w(ind)=0.0 + endif + enddo + enddo + call hpb_partition + + do i=1,nres + theta1(i)=theta(i) + phi1(i)=phi(i) + alph1(i)=alph(i) + omeg1(i)=omeg(i) + enddo + + call var_to_geom(nvar,var2) + + do i=1,nres + if ( iff(i).eq.1 ) then + theta(i)=theta1(i) + phi(i)=phi1(i) + alph(i)=alph1(i) + omeg(i)=omeg1(i) + endif + enddo + + call chainbuild +!d call write_pdb(3,'combined structure',0d0) +!d time0=MPI_WTIME() + + NX=NRES-3 + NY=((NRES-4)*(NRES-5))/2 + call distfit(.true.,200) + +!d time1=MPI_WTIME() +!d write (iout,'(a,f6.2,a)') ' Time for distfit ',time1-time0,' sec' + + ipot0=ipot + maxmin0=maxmin + maxfun0=maxfun + wstrain0=wstrain + + ipot=6 + maxmin=2000 + maxfun=5000 + call geom_to_var(nvar,var) +!d time0=MPI_WTIME() + call minimize(etot,var,iretcode,nfun) + write(iout,*)'SUMSL return code is',iretcode,' eval SOFT',nfun + +!d time1=MPI_WTIME() +!d write (iout,'(a,f6.2,f8.2,a)')' Time for soft min.',time1-time0, +!d & nfun/(time1-time0),' SOFT eval/s' + call var_to_geom(nvar,var) + call chainbuild + + + iwsk=0 + nf=0 + if (iff(1).eq.1) then + iwsk=1 + nf=nf+1 + ij(nf)=0 + endif + do i=2,nres + if ( iwsk.eq.0.and.iff(i-1).eq.0.and.iff(i).eq.1 ) then + iwsk=1 + nf=nf+1 + ij(nf)=i + endif + if ( iwsk.eq.1.and.iff(i-1).eq.1.and.iff(i).eq.0 ) then + iwsk=0 + nf=nf+1 + ij(nf)=i-1 + endif + enddo + if (iff(nres).eq.1) then + nf=nf+1 + ij(nf)=nres + endif + + +!d write(linia,'(a6,i3,a1,i3,a1,i3,a1,i3)') +!d & "select",ij(1),"-",ij(2), +!d & ",",ij(3),"-",ij(4) +!d call write_pdb(in_pdb,linia,etot) + + + ipot=ipot0 + maxmin=maxmin0 + maxfun=maxfun0 +!d time0=MPI_WTIME() + call minimize(etot,var,iretcode,nfun) +!d write(iout,*)'SUMSL DIST return code is',iretcode,' eval ',nfun + ieval=nfun + +!d time1=MPI_WTIME() +!d write (iout,'(a,f6.2,f8.2,a)')' Time for DIST min.',time1-time0, +!d & nfun/(time1-time0),' eval/s' +!d call var_to_geom(nvar,var) +!d call chainbuild +!d call write_pdb(6,'dist structure',etot) + + + nhpb= nhpb0 + link_start=1 + link_end=nhpb + wstrain=wstrain0 + + return + end subroutine contact_cp2 +!----------------------------------------------------------------------------- + subroutine contact_cp(var,var2,iff,ieval,in_pdb) + + use geometry, only:dist +!el use minim +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.SBRIDGE' +! include 'COMMON.FFIELD' +! include 'COMMON.IOUNITS' +! include 'COMMON.DISTFIT' +! include 'COMMON.VAR' +! include 'COMMON.CHAIN' +! include 'COMMON.MINIM' + + character(len=50) :: linia + integer :: nf,ij(4) + real(kind=8) :: energy(0:n_ene) + real(kind=8),dimension(6*nres) :: var,var2 !(maxvar) (maxvar=6*maxres) + real(kind=8) :: time0,time1 + integer :: iff(nres),ieval + real(kind=8),dimension(nres) :: theta1,phi1,alph1,omeg1 !(maxres) + logical :: debug + +!el local variables + integer :: in_pdb,i,j,ind,iwsk + + debug=.false. +! debug=.true. + if (ieval.eq.-1) debug=.true. + + +! +! store selected dist. constrains from 1st structure +! +#ifdef OSF +! Intercept NaNs in the coordinates +! write(iout,*) (var(i),i=1,nvar) + x_sum=0.D0 + do i=1,nvar + x_sum=x_sum+var(i) + enddo + if (x_sum.ne.x_sum) then + write(iout,*)" *** contact_cp : Found NaN in coordinates" + call flush(iout) + print *," *** contact_cp : Found NaN in coordinates" + return + endif +#endif + + + call var_to_geom(nvar,var) + call chainbuild + nhpb0=nhpb + ind=0 + do i=1,nres-3 + do j=i+3,nres + ind=ind+1 + if ( iff(i).eq.1.and.iff(j).eq.1 ) then + d0(ind)=DIST(i,j) + w(ind)=10.0 + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=10.0 + dhpb(nhpb)=d0(ind) + else + w(ind)=0.0 + endif + enddo + enddo + call hpb_partition + + do i=1,nres + theta1(i)=theta(i) + phi1(i)=phi(i) + alph1(i)=alph(i) + omeg1(i)=omeg(i) + enddo + +! +! freeze sec.elements from 2nd structure +! + do i=1,nres + mask_phi(i)=1 + mask_theta(i)=1 + mask_side(i)=1 + enddo + + call var_to_geom(nvar,var2) + call secondary2(debug) + do j=1,nbfrag + do i=bfrag(1,j),bfrag(2,j) + mask(i)=0 + mask_phi(i)=0 + mask_theta(i)=0 + enddo + if (bfrag(3,j).le.bfrag(4,j)) then + do i=bfrag(3,j),bfrag(4,j) + mask(i)=0 + mask_phi(i)=0 + mask_theta(i)=0 + enddo + else + do i=bfrag(4,j),bfrag(3,j) + mask(i)=0 + mask_phi(i)=0 + mask_theta(i)=0 + enddo + endif + enddo + do j=1,nhfrag + do i=hfrag(1,j),hfrag(2,j) + mask(i)=0 + mask_phi(i)=0 + mask_theta(i)=0 + enddo + enddo + mask_r=.true. + +! +! copy selected res from 1st to 2nd structure +! + + do i=1,nres + if ( iff(i).eq.1 ) then + theta(i)=theta1(i) + phi(i)=phi1(i) + alph(i)=alph1(i) + omeg(i)=omeg1(i) + endif + enddo + + if(debug) then +! +! prepare description in linia variable +! + iwsk=0 + nf=0 + if (iff(1).eq.1) then + iwsk=1 + nf=nf+1 + ij(nf)=1 + endif + do i=2,nres + if ( iwsk.eq.0.and.iff(i-1).eq.0.and.iff(i).eq.1 ) then + iwsk=1 + nf=nf+1 + ij(nf)=i + endif + if ( iwsk.eq.1.and.iff(i-1).eq.1.and.iff(i).eq.0 ) then + iwsk=0 + nf=nf+1 + ij(nf)=i-1 + endif + enddo + if (iff(nres).eq.1) then + nf=nf+1 + ij(nf)=nres + endif + + write(linia,'(a6,i3,a1,i3,a1,i3,a1,i3)') & + "SELECT",ij(1)-1,"-",ij(2)-1,& + ",",ij(3)-1,"-",ij(4)-1 + + endif +! +! run optimization +! + call contact_cp_min(var,ieval,in_pdb,linia,debug) + + return + end subroutine contact_cp +!----------------------------------------------------------------------------- + subroutine contact_cp_min(var,ieval,in_pdb,linia,debug) + +!el use minim +! +! input : theta,phi,alph,omeg,in_pdb,linia,debug +! output : var,ieval +! +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + include 'mpif.h' +! include 'COMMON.SBRIDGE' +! include 'COMMON.FFIELD' +! include 'COMMON.IOUNITS' +! include 'COMMON.DISTFIT' +! include 'COMMON.VAR' +! include 'COMMON.CHAIN' +! include 'COMMON.MINIM' + + character(len=50) :: linia + integer :: nf,ij(4) + real(kind=8) :: energy(0:n_ene) + real(kind=8),dimension(6*nres) :: var !(maxvar) (maxvar=6*maxres) + real(kind=8) :: time0,time1 + integer :: ieval,info(3) + logical :: debug,fail,reduce,change !check_var, + +!el local variables + integer :: in_pdb,i,ipot0,ipot01,maxmin0,maxfun0,maxmin01,maxfun01,& + iretcode,nfun + real(kind=8) :: wsc01,wscp01,welec01,wvdwpp01,wscloc01,wtor01,& + wtor_d01,wstrain0,etot + + write(iout,'(a20,i6,a20)') & + '------------------',in_pdb,'-------------------' +!el#ifdef MPI + if (debug) then + call chainbuild + call write_pdb(1000+in_pdb,'combined structure',0d0) +!el#ifdef MPI + time0=MPI_WTIME() +!el#endif + endif +!el#endif +! +! run optimization of distances +! +! uses d0(),w() and mask() for frozen 2D +! +!test--------------------------------------------- +!test NX=NRES-3 +!test NY=((NRES-4)*(NRES-5))/2 +!test call distfit(debug,5000) + + do i=1,nres + mask_side(i)=0 + enddo + + ipot01=ipot + maxmin01=maxmin + maxfun01=maxfun +! wstrain01=wstrain + wsc01=wsc + wscp01=wscp + welec01=welec + wvdwpp01=wvdwpp +! wang01=wang + wscloc01=wscloc + wtor01=wtor + wtor_d01=wtor_d + + ipot=6 + maxmin=2000 + maxfun=4000 +! wstrain=1.0 + wsc=0.0 + wscp=0.0 + welec=0.0 + wvdwpp=0.0 +! wang=0.0 + wscloc=0.0 + wtor=0.0 + wtor_d=0.0 + + call geom_to_var(nvar,var) +!de change=reduce(var) + if (check_var(var,info)) then + write(iout,*) 'cp_min error in input' + print *,'cp_min error in input' + return + endif + +!d call etotal(energy(0)) +!d call enerprint(energy(0)) +!d call check_eint +!el#ifdef MPI + time0=MPI_WTIME() +!dtest call minimize(etot,var,iretcode,nfun) +!dtest write(iout,*)'SUMSL return code is',iretcode,' eval SDIST',nfun + time1=MPI_WTIME() +!el#endif +!d call etotal(energy(0)) +!d call enerprint(energy(0)) +!d call check_eint + + do i=1,nres + mask_side(i)=1 + enddo + + ipot=ipot01 + maxmin=maxmin01 + maxfun=maxfun01 +! wstrain=wstrain01 + wsc=wsc01 + wscp=wscp01 + welec=welec01 + wvdwpp=wvdwpp01 +! wang=wang01 + wscloc=wscloc01 + wtor=wtor01 + wtor_d=wtor_d01 +!test-------------------------------------------------- + + if(debug) then +!el#ifdef MPI + time1=MPI_WTIME() +!el#endif + write (iout,'(a,f6.2,a)')' Time for distfit ',time1-time0,' sec' + call write_pdb(2000+in_pdb,'distfit structure',0d0) + endif + + ipot0=ipot + maxmin0=maxmin + maxfun0=maxfun + wstrain0=wstrain +! +! run soft pot. optimization +! with constrains: +! nhpb,ihpb(),jhpb(),forcon(),dhpb() and hpb_partition +! and frozen 2D: +! mask_phi(),mask_theta(),mask_side(),mask_r +! + ipot=6 + maxmin=2000 + maxfun=4000 +!el#ifdef MPI +!de change=reduce(var) +!de if (check_var(var,info)) write(iout,*) 'error before soft' +!el#ifdef MPI + time0=MPI_WTIME() +!el#endif + call minimize(etot,var,iretcode,nfun) + + write(iout,*)'SUMSL return code is',iretcode,' eval SOFT',nfun +!el#ifdef MPI + time1=MPI_WTIME() +!el#endif + write (iout,'(a,f6.2,f8.2,a)')' Time for soft min.',time1-time0,& + nfun/(time1-time0),' SOFT eval/s' + + if (debug) then + call var_to_geom(nvar,var) + call chainbuild + call write_pdb(3000+in_pdb,'soft structure',etot) + endif +!el#endif +! +! run full UNRES optimization with constrains and frozen 2D +! the same variables as soft pot. optimizatio +! + ipot=ipot0 + maxmin=maxmin0 + maxfun=maxfun0 +! +! check overlaps before calling full UNRES minim +! + call var_to_geom(nvar,var) + call chainbuild + call etotal(energy) +#ifdef OSF + write(iout,*) 'N7 ',energy(0) + if (energy(0).ne.energy(0)) then + write(iout,*) 'N7 error - gives NaN',energy(0) + endif +#endif + ieval=1 + if (energy(1).eq.1.0d20) then + write (iout,'(a,1pe14.5)')'#N7_OVERLAP evdw=1d20',energy(1) + call overlap_sc(fail) + if(.not.fail) then + call etotal(energy) + ieval=ieval+1 + write (iout,'(a,1pe14.5)')'#N7_OVERLAP evdw after',energy(1) + else + mask_r=.false. + nhpb= nhpb0 + link_start=1 + link_end=nhpb + wstrain=wstrain0 + return + endif + endif + call flush(iout) +! +!dte time0=MPI_WTIME() +!de change=reduce(var) +!de if (check_var(var,info)) then +!de write(iout,*) 'error before mask dist' +!de call var_to_geom(nvar,var) +!de call chainbuild +!de call write_pdb(10000+in_pdb,'before mask dist',etot) +!de endif +!dte call minimize(etot,var,iretcode,nfun) +!dte write(iout,*)'SUMSL MASK DIST return code is',iretcode, +!dte & ' eval ',nfun +!dte ieval=ieval+nfun +!dte +!dte time1=MPI_WTIME() +!dte write (iout,'(a,f6.2,f8.2,a)') +!dte & ' Time for mask dist min.',time1-time0, +!dte & nfun/(time1-time0),' eval/s' +!dte call flush(iout) +!el#ifdef MPI + if (debug) then + call var_to_geom(nvar,var) + call chainbuild + call write_pdb(4000+in_pdb,'mask dist',etot) + endif +! +! switch off freezing of 2D and +! run full UNRES optimization with constrains +! + mask_r=.false. +!el#ifdef MPI + time0=MPI_WTIME() +!el#endif +!de change=reduce(var) +!de if (check_var(var,info)) then +!de write(iout,*) 'error before dist' +!de call var_to_geom(nvar,var) +!de call chainbuild +!de call write_pdb(11000+in_pdb,'before dist',etot) +!de endif + + call minimize(etot,var,iretcode,nfun) + +!de change=reduce(var) +!de if (check_var(var,info)) then +!de write(iout,*) 'error after dist',ico +!de call var_to_geom(nvar,var) +!de call chainbuild +!de call write_pdb(12000+in_pdb+ico*1000,'after dist',etot) +!de endif + write(iout,*)'SUMSL DIST return code is',iretcode,' eval ',nfun + ieval=ieval+nfun + +!el#ifdef MPI + time1=MPI_WTIME() +!el#endif + write (iout,'(a,f6.2,f8.2,a)')' Time for dist min.',time1-time0,& + nfun/(time1-time0),' eval/s' + +!de call etotal(energy(0)) +!de write(iout,*) 'N7 after dist',energy(0) + call flush(iout) + + if (debug) then + call var_to_geom(nvar,var) + call chainbuild + call write_pdb(in_pdb,linia,etot) + endif +!el#endif +! +! reset constrains +! + nhpb= nhpb0 + link_start=1 + link_end=nhpb + wstrain=wstrain0 + + return + end subroutine contact_cp_min +!----------------------------------------------------------------------------- + subroutine softreg + + use geometry, only:dist +!el use minim +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + include 'mpif.h' +! 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' +! +! include 'COMMON.DISTFIT' + integer :: iff(nres) + real(kind=8) :: time0,time1 + real(kind=8) :: energy(0:n_ene),ee + real(kind=8),dimension(6*nres) :: var !(maxvar) (maxvar=6*maxres) +! + logical :: debug,ltest,fail + character(len=50) :: linia + integer :: ieval,i,j,in_pdb,ipot0,maxmin0,maxfun0,ico,nhpb_c,& + iretcode,nfun + real(kind=8) :: wstrain0,wang0,etot +! + linia='test' + debug=.true. + in_pdb=0 + +!------------------------ +! +! freeze sec.elements +! + 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 +! +! store dist. constrains +! + 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 +! +! run soft pot. optimization +! + ipot=6 + wang=3.0 + maxmin=2000 + maxfun=4000 + call geom_to_var(nvar,var) +!el#ifdef MPI + time0=MPI_WTIME() +!el#endif + call minimize(etot,var,iretcode,nfun) + + write(iout,*)'SUMSL return code is',iretcode,' eval SOFT',nfun +!el#ifdef MPI + time1=MPI_WTIME() +!el#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 +! +! run full UNRES optimization with constrains and frozen 2D +! the same variables as soft pot. optimizatio +! + ipot=ipot0 + wang=wang0 + maxmin=maxmin0 + maxfun=maxfun0 +!el#ifdef MPI + time0=MPI_WTIME() +!el#endif + call minimize(etot,var,iretcode,nfun) + write(iout,*)'SUMSL MASK DIST return code is',iretcode,& + ' eval ',nfun + ieval=nfun + +!el#ifdef MPI + time1=MPI_WTIME() +!el#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 +! +! switch off constrains and +! run full UNRES optimization with frozen 2D +! + +! +! reset constrains +! + nhpb_c=nhpb + nhpb=nhpb0 + link_start=1 + link_end=nhpb + wstrain=wstrain0 + +!el#ifdef MPI + time0=MPI_WTIME() +!el#endif + call minimize(etot,var,iretcode,nfun) + write(iout,*)'SUMSL MASK return code is',iretcode,' eval ',nfun + ieval=ieval+nfun + +!el#ifdef MPI + time1=MPI_WTIME() +!el#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. + + +! +! run full UNRES optimization with constrains and NO frozen 2D +! + + nhpb=nhpb_c + link_start=1 + link_end=nhpb + maxfun=maxfun0/5 + + do ico=1,5 + + wstrain=wstrain0/ico + +!el#ifdef MPI + time0=MPI_WTIME() +!el#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 + +!el#ifdef MPI + time1=MPI_WTIME() +!el#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 +! + nhpb=nhpb0 + link_start=1 + link_end=nhpb + wstrain=wstrain0 + maxfun=maxfun0 + + +! + if (minim) then +!el#ifdef MPI + time0=MPI_WTIME() +!el#endif + call minimize(etot,var,iretcode,nfun) + write(iout,*)'------------------------------------------------' + write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun,& + '+ DIST eval',ieval + +!el#ifdef MPI + time1=MPI_WTIME() +!el#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 +!el#endif + return + end subroutine softreg +!----------------------------------------------------------------------------- + subroutine beta_slide(i1,i2,i3,i4,i5,ieval,ij) + + use geometry, only:dist +!el use minim +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + include 'mpif.h' +! 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' + real(kind=8) :: time0,time1 + real(kind=8) :: energy(0:n_ene),ee + real(kind=8),dimension(6*nres) :: var !(maxvar) (maxvar=6*maxres) + integer :: jdata(5),isec(nres) +! +!el local variables + integer :: i1,i2,i3,i4,i5,ieval,ij + integer :: i,j,nft_sc,ishift,iretcode,nfun,maxfun0,ico + real(kind=8) :: etot,wscloc0,wstrain0 + + jdata(1)=i1 + jdata(2)=i2 + jdata(3)=i3 + jdata(4)=i4 + jdata(5)=i5 + + call secondary2(.false.) + + do i=1,nres + isec(i)=0 + enddo + do j=1,nbfrag + do i=bfrag(1,j),bfrag(2,j) + isec(i)=1 + enddo + do i=bfrag(4,j),bfrag(3,j),sign(1,bfrag(3,j)-bfrag(4,j)) + isec(i)=1 + enddo + enddo + do j=1,nhfrag + do i=hfrag(1,j),hfrag(2,j) + isec(i)=2 + enddo + enddo + +! +! cut strands at the ends +! + if (jdata(2)-jdata(1).gt.3) then + jdata(1)=jdata(1)+1 + jdata(2)=jdata(2)-1 + if (jdata(3).lt.jdata(4)) then + jdata(3)=jdata(3)+1 + jdata(4)=jdata(4)-1 + else + jdata(3)=jdata(3)-1 + jdata(4)=jdata(4)+1 + endif + endif + +!v call chainbuild +!v call etotal(energy(0)) +!v etot=energy(0) +!v write(iout,*) nnt,nct,etot +!v call write_pdb(ij*100,'first structure',etot) +!v write(iout,*) 'N16 test',(jdata(i),i=1,5) + +!------------------------ +! generate constrains +! + ishift=jdata(5)-2 + if(ishift.eq.0) ishift=-2 + nhpb0=nhpb + call chainbuild + do i=jdata(1),jdata(2) + isec(i)=-1 + if(jdata(4).gt.jdata(3))then + do j=jdata(3)+i-jdata(1)-2,jdata(3)+i-jdata(1)+2 + isec(j)=-1 +!d print *,i,j,j+ishift + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=1000.0 + dhpb(nhpb)=DIST(i,j+ishift) + enddo + else + do j=jdata(3)-i+jdata(1)+2,jdata(3)-i+jdata(1)-2,-1 + isec(j)=-1 +!d print *,i,j,j+ishift + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=1000.0 + dhpb(nhpb)=DIST(i,j+ishift) + enddo + endif + enddo + + do i=nnt,nct-2 + do j=i+2,nct + if(isec(i).gt.0.or.isec(j).gt.0) then +!d print *,i,j + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=0.1 + dhpb(nhpb)=DIST(i,j) + endif + enddo + enddo + + call hpb_partition + + call geom_to_var(nvar,var) + maxfun0=maxfun + wstrain0=wstrain + maxfun=4000/5 + + do ico=1,5 + + wstrain=wstrain0/ico + +!v time0=MPI_WTIME() + call minimize(etot,var,iretcode,nfun) + write(iout,'(a10,f6.3,a14,i3,a6,i5)') & + ' SUMSL DIST',wstrain,' return code is',iretcode,& + ' eval ',nfun + ieval=ieval+nfun +!v time1=MPI_WTIME() +!v write (iout,'(a,f6.2,f8.2,a)') +!v & ' Time for dist min.',time1-time0, +!v & nfun/(time1-time0),' eval/s' +!v call var_to_geom(nvar,var) +!v call chainbuild +!v call write_pdb(ij*100+ico,'dist cons',etot) + + enddo +! + nhpb=nhpb0 + call hpb_partition + wstrain=wstrain0 + maxfun=maxfun0 +! +!d print *,etot + wscloc0=wscloc + wscloc=10.0 + call sc_move(nnt,nct,100,100d0,nft_sc,etot) + wscloc=wscloc0 +!v call chainbuild +!v call etotal(energy(0)) +!v etot=energy(0) +!v call write_pdb(ij*100+10,'sc_move',etot) +!d call intout +!d print *,nft_sc,etot + + return + end subroutine beta_slide +!----------------------------------------------------------------------------- + subroutine beta_zip(i1,i2,ieval,ij) + +!el use minim +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + include 'mpif.h' +! 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' + real(kind=8) :: time0,time1 + real(kind=8) :: energy(0:n_ene),ee + real(kind=8),dimension(6*nres) :: var !(maxvar) (maxvar=6*maxres) + character(len=10) :: test +!el local variables + integer :: i1,i2,ieval,ij,ico,iretcode,nfun,maxfun0 + real(kind=8) :: etot,wstrain0 +!v call chainbuild +!v call etotal(energy(0)) +!v etot=energy(0) +!v write(test,'(2i5)') i1,i2 +!v call write_pdb(ij*100,test,etot) +!v write(iout,*) 'N17 test',i1,i2,etot,ij + +! +! generate constrains +! + nhpb0=nhpb + nhpb=nhpb+1 + ihpb(nhpb)=i1 + jhpb(nhpb)=i2 + forcon(nhpb)=1000.0 + dhpb(nhpb)=4.0 + + call hpb_partition + + call geom_to_var(nvar,var) + maxfun0=maxfun + wstrain0=wstrain + maxfun=1000/5 + + do ico=1,5 + wstrain=wstrain0/ico +!v time0=MPI_WTIME() + call minimize(etot,var,iretcode,nfun) + write(iout,'(a10,f6.3,a14,i3,a6,i5)') & + ' SUMSL DIST',wstrain,' return code is',iretcode,& + ' eval ',nfun + ieval=ieval+nfun +!v time1=MPI_WTIME() +!v write (iout,'(a,f6.2,f8.2,a)') +!v & ' Time for dist min.',time1-time0, +!v & nfun/(time1-time0),' eval/s' +! do not comment the next line + call var_to_geom(nvar,var) +!v call chainbuild +!v call write_pdb(ij*100+ico,'dist cons',etot) + enddo + + nhpb=nhpb0 + call hpb_partition + wstrain=wstrain0 + maxfun=maxfun0 + +!v call etotal(energy(0)) +!v etot=energy(0) +!v write(iout,*) 'N17 test end',i1,i2,etot,ij + + return + end subroutine beta_zip +!----------------------------------------------------------------------------- +! thread.F +!----------------------------------------------------------------------------- + subroutine thread_seq + + use geometry, only:dist + use random, only:iran_num + use control, only:tcpu + use regularize_, only:regularize + use mcm_data, only: nsave_part,nacc_tot +! Thread the sequence through a database of known structures +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + use MPI_data !include 'COMMON.INFO' + use MPI_ +#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 + integer :: ThreadId,ThreadType,Kwita +#endif + real(kind=8),dimension(6*nres) :: varia !(maxvar) (maxvar=6*maxres) + real(kind=8) :: przes(3),obr(3,3) + real(kind=8) :: time_for_thread + logical :: found_pattern,non_conv + character(len=32) :: head_pdb + real(kind=8) :: energia(0:n_ene) + integer :: i,j,ithread,itrial,ii,jj,nres_t,ist,ipattern,iretcode,& + link_end0,iproc + real(kind=8) :: dcj,rms,frac,frac_nn,co,etot,curr_tim,curr_tim1 + + n_ene_comp=nprint_ene +! +! Body +! +#ifdef MPI + if (me.eq.king) then + do i=1,nctasks + nsave_part(i)=0 + enddo + endif + nacc_tot=0 + + Kwita=0 +#endif + 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 +!d 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 +! Find long enough chain in the database + ii=iran_num(1,nseq) + nres_t=nres_base(1,ii) +! 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 +! If this point is reached, the pattern has not yet been examined. + 10 continue +! 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 +! 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) +! cref(j,i)=c(j,i) + enddo +!d write (iout,'(a,i4,3f10.5)') restyp(itype(i)),i,(c(j,i),j=1,3) + enddo +!d call fitsq(rms,c(1,nnt),cref(1,nnt),nct-nnt+1,przes,obr, +!d non_conv) +!d write (iout,'(a,f10.5)') +!d & 'Initial RMS deviation from reference structure:',rms + if (itype(nres).eq.ntyp1) 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.ntyp1) 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.) +!d print *,'Exit INT_FROM_CART.' +!d print *,'nhpb=',nhpb + do i=nss+1,nhpb + ii=ihpb(i) + jj=jhpb(i) + dhpb(i)=dist(ii,jj) +! write (iout,'(2i5,2f10.5)') ihpb(i),jhpb(i),dhpb(i),forcon(i) + enddo +! stop 'End generate' +! Generate SC conformations. + call sc_conf +! call intout +#ifdef MPI +!d print *,'Processor:',me,': exit GEN_SIDE.' +#else +!d print *,'Exit GEN_SIDE.' +#endif +! Calculate initial energy. + call chainbuild + call etotal(energia) + 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 +! 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) +! 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) +! call enerprint(energia(0)) + link_end=link_end0 +!d call chainbuild +!d call fitsq(rms,c(1,nnt),cref(1,nnt),nct-nnt+1,przes,obr,non_conv) +!d write (iout,'(a,f10.5)') +!d & '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) +! write (istat,'(i4,2x,a8,i4,11(1pe14.5),2(0pf8.3),f8.5)') +! & ithread,str_nam(ipattern),ist+1,(ener(k,ithread),k=1,11), +! & (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 +! 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 subroutine thread_seq +!----------------------------------------------------------------------------- + subroutine sc_conf + +! Sample (hopefully) optimal SC orientations given backcone conformation. +!el use comm_srutu + use random, only:iran_num +! 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' + real(kind=8),dimension(6*nres) :: varia !(maxvar) (maxvar=6*maxres) +!el integer :: icall +!el common /srutu/ icall + real(kind=8) :: energia(0:n_ene) + logical :: glycine,fail + integer :: i,maxsample,link_end0,ind_sc,isample + real(kind=8) :: alph0,omeg0,e1,e0 + + maxsample=10 + link_end0=link_end + link_end=min0(link_end,nss) + do i=nnt,nct + if (itype(i).ne.10) then +!d 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) + e0 = energia(0) + do isample=1,maxsample +! 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) +!d write (iout,'(a,i5,a,i4,2(a,f8.3),2(a,1pe14.5))') +!d & 'Step:',isample,' SC',ind_sc,' alpha',alph(ind_sc)*rad2deg, +!d & ' omega',omeg(ind_sc)*rad2deg,' old energy',e0,' new energy',e1 + e1=energia(0) + if (e0.le.e1) then + alph(ind_sc)=alph0 + omeg(ind_sc)=omeg0 + else + e0=e1 + endif + enddo + link_end=link_end0 + return + end subroutine sc_conf +!----------------------------------------------------------------------------- +! minim_jlee.F +!----------------------------------------------------------------------------- + logical function check_var(var,info) + + use MPI_data + use geometry_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.VAR' +! include 'COMMON.IOUNITS' +! include 'COMMON.GEO' +! include 'COMMON.SETUP' + real(kind=8),dimension(6*nres) :: var !(maxvar) (maxvar=6*maxres) + integer,dimension(3) :: info + integer :: i,j +! AL ------- + check_var=.false. + do i=nphi+ntheta+1,nphi+ntheta+nside +! Check the side chain "valence" angles alpha + if (var(i).lt.1.0d-7) then + write (iout,*) 'CHUJ NASTAPIL ABSOLUTNY!!!!!!!!!!!!' + write (iout,*) 'Processor',me,'received bad variables!!!!' + write (iout,*) 'Variables' + write (iout,'(8f10.4)') (rad2deg*var(j),j=1,nvar) + write (iout,*) 'Continuing calculations at this point',& + ' could destroy the results obtained so far... ABORTING!!!!!!' + write (iout,'(a19,i5,f10.4,a4,2i4,a3,i3)') & + 'valence angle alpha',i-nphi-ntheta,var(i),& + 'n it',info(1),info(2),'mv ',info(3) + write (*,*) 'CHUJ NASTAPIL ABSOLUTNY!!!!!!!!!!!!' + write (*,*) 'Processor',me,'received bad variables!!!!' + write (*,*) 'Variables' + write (*,'(8f10.4)') (rad2deg*var(j),j=1,nvar) + write (*,*) 'Continuing calculations at this point',& + ' could destroy the results obtained so far... ABORTING!!!!!!' + write (*,'(a19,i5,f10.4,a4,2i4,a3,i3)') & + 'valence angle alpha',i-nphi-ntheta,var(i),& + 'n it',info(1),info(2),'mv ',info(3) + check_var=.true. + return + endif + enddo +! Check the backbone "valence" angles theta + do i=nphi+1,nphi+ntheta + if (var(i).lt.1.0d-7) then + write (iout,*) 'CHUJ NASTAPIL ABSOLUTNY!!!!!!!!!!!!' + write (iout,*) 'Processor',me,'received bad variables!!!!' + write (iout,*) 'Variables' + write (iout,'(8f10.4)') (rad2deg*var(j),j=1,nvar) + write (iout,*) 'Continuing calculations at this point',& + ' could destroy the results obtained so far... ABORTING!!!!!!' + write (iout,'(a19,i5,f10.4,a4,2i4,a3,i3)') & + 'valence angle theta',i-nphi,var(i),& + 'n it',info(1),info(2),'mv ',info(3) + write (*,*) 'CHUJ NASTAPIL ABSOLUTNY!!!!!!!!!!!!' + write (*,*) 'Processor',me,'received bad variables!!!!' + write (*,*) 'Variables' + write (*,'(8f10.4)') (rad2deg*var(j),j=1,nvar) + write (*,*) 'Continuing calculations at this point',& + ' could destroy the results obtained so far... ABORTING!!!!!!' + write (*,'(a19,i5,f10.4,a4,2i4,a3,i3)') & + 'valence angle theta',i-nphi,var(i),& + 'n it',info(1),info(2),'mv ',info(3) + check_var=.true. + return + endif + enddo + return + end function check_var +!----------------------------------------------------------------------------- +! distfit.f +!----------------------------------------------------------------------------- + subroutine distfit(debug,maxit) + + use geometry_data, only: phi + use compare_data + use md_calc +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CHAIN' +! include 'COMMON.VAR' +! include 'COMMON.IOUNITS' +! include 'COMMON.DISTFIT' + integer :: i,maxit,MAXMAR,IT,IMAR + real(kind=8),DIMENSION(nres) :: X,DIAGH,phiold !(maxres) + logical :: debug,sing + real(kind=8) :: TOL,RL,F0,AIN,F1 + +!input------------------------------------ +! NX=NRES-3 +! NY=((NRES-4)*(NRES-5))/2 +!input------------------------------------ +!test MAXIT=20 + TOL=0.5 + MAXMAR=10 + RL=100.0 + + CALL TRANSFER(NRES,phi,phiold) + + F0=RDIF() + +!d WRITE (IOUT,*) 'DISTFIT: F0=',F0 + + + DO IT=1,MAXIT + CALL RDERIV + CALL HEVAL + + DO I=1,NX + DIAGH(I)=H(I,I) + ENDDO + RL=RL*0.1 + + DO IMAR=1,MAXMAR + DO I=1,NX + H(I,I)=DIAGH(I)+RL + ENDDO + CALL TRANSFER(NX,XX,X) + CALL BANACH(NX,NRES,H,X,sing) + AIN=0.0 + DO I=1,NX + AIN=AIN+DABS(X(I)) + ENDDO + IF (AIN.LT.0.1*TOL .AND. RL.LT.1.0E-4) THEN + if (debug) then + WRITE (IOUT,*) 'DISTFIT: CONVERGENCE HAS BEEN ACHIEVED' + WRITE (IOUT,*) 'IT=',it,'F=',F0 + endif + RETURN + ENDIF + DO I=4,NRES + phi(I)=phiold(I)+mask(i)*X(I-3) +! print *,X(I-3) + ENDDO + + F1=RDIF() +!d WRITE (IOUT,*) 'IMAR=',IMAR,' RL=',RL,' F1=',F1 + IF (F1.LT.F0) THEN + CALL TRANSFER(NRES,phi,phiold) + F0=F1 + GOTO 1 + ELSE IF (DABS(F1-F0).LT.1.0E-5) THEN + if (debug) then + WRITE (IOUT,*) 'DISTFIT: CANNOT IMPROVE DISTANCE FIT' + WRITE (IOUT,*) 'IT=',it,'F=',F1 + endif + RETURN + ENDIF + RL=RL*10.0 + ENDDO + WRITE (IOUT,*) 'DISTFIT: MARQUARDT PROCEDURE HAS FAILED' + WRITE (IOUT,*) 'IT=',it,'F=',F0 + CALL TRANSFER(NRES,phiold,phi) + RETURN + 1 continue +!d write (iout,*) "it",it," imar",imar," f0",f0 + enddo + WRITE (IOUT,*) 'DISTFIT: FINAL F=',F0,'after MAXIT=',maxit + return + end subroutine distfit +!----------------------------------------------------------------------------- + real(kind=8) function RDIF() + + use compare_data + use geometry, only: dist +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CHAIN' +! include 'COMMON.DISTFIT' + integer :: i,j,ind + real(kind=8) :: suma,DIJ +! print *,'in rdif' + + suma=0.0 + ind=0 + call chainbuild + do i=1,nres-3 + do j=i+3,nres + ind=ind+1 + if (w(ind).ne.0.0) then + DIJ=DIST(i,j) + suma=suma+w(ind)*(DIJ-d0(ind))*(DIJ-d0(ind)) + DDD(ind)=DIJ +! print '(2i3,i4,4f12.2)',i,j,ind,dij,d0(ind),w(ind),suma + endif + enddo + enddo + + RDIF=suma + return + end function RDIF +!----------------------------------------------------------------------------- + subroutine RDERIV + + use compare_data + use geometry_data + use geometry, only:dist +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CHAIN' +! include 'COMMON.DISTFIT' +! include 'COMMON.GEO' + integer :: i,j,k,l,I1,I2,IND + real(kind=8),DIMENSION(3) :: E12,R13,R24,PRODU + + DO I=1,NY + DO J=1,NX + DRDG(I,J)=0.0 + ENDDO + ENDDO + DO I=1,NX + I1=I+1 + I2=I+2 + CALL VEC(I1,I2,E12) + DO J=1,I + DO K=1,3 + R13(K)=C(K,J)-C(K,I1) + ENDDO + DO K=I2+1,NRES + DO L=1,3 + R24(L)=C(L,K)-C(L,I2) + ENDDO + IND=((J-1)*(2*NRES-J-6))/2+K-3 + PRODU(1)=R13(2)*R24(3)-R13(3)*R24(2) + PRODU(2)=R13(3)*R24(1)-R13(1)*R24(3) + PRODU(3)=R13(1)*R24(2)-R13(2)*R24(1) + DRDG(IND,I)=SCALAR(E12,PRODU)/DIST(J,K) + ENDDO + ENDDO + ENDDO + return + end subroutine RDERIV +!----------------------------------------------------------------------------- + subroutine HEVAL + + use compare_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CHAIN' +! include 'COMMON.DISTFIT' + integer :: i,k,j + real(kind=8) :: XI,HII,BKI,BKIWK,HIJ + + DO I=1,NX + XI=0.0 + HII=0.0 + DO K=1,NY + BKI=DRDG(K,I) + BKIWK=w(K)*BKI + XI=XI+BKIWK*(D0(K)-DDD(K)) + HII=HII+BKI*BKIWK + ENDDO + H(I,I)=HII + XX(I)=XI + DO J=I+1,NX + HIJ=0.0 + DO K=1,NY + HIJ=HIJ+DRDG(K,I)*DRDG(K,J)*w(K) + ENDDO + H(I,J)=HIJ + H(J,I)=HIJ + ENDDO + ENDDO + return + end subroutine HEVAL +!----------------------------------------------------------------------------- + subroutine VEC(I,J,U) +! + use geometry_data, only: C +! Find the unit vector from atom (I) to atom (J). Store in U. +! +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.CHAIN' + integer :: I,J,K + real(kind=8),DIMENSION(3) :: U + real(kind=8) :: ANORM,UK + + ANORM=0.0 + DO K=1,3 + UK=C(K,J)-C(K,I) + ANORM=ANORM+UK*UK + U(K)=UK + ENDDO + ANORM=SQRT(ANORM) + DO K=1,3 + U(K)=U(K)/ANORM + ENDDO + return + end subroutine VEC +!----------------------------------------------------------------------------- + subroutine TRANSFER(N,X1,X2) + +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' + integer :: N,I + real(kind=8),DIMENSION(N) :: X1,X2 + DO 1 I=1,N + 1 X2(I)=X1(I) + return + end subroutine TRANSFER +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + subroutine alloc_compare_arrays + + maxres22=nres*(nres+1)/2 +! common.dbase +! common /struct/ in io_common: read_threadbase +! allocate(cart_base !(3,maxres_base,maxseq) +! allocate(nres_base !(3,maxseq) +! allocate(str_nam !(maxseq) +! common.distfit +! COMMON /c_frag/ in io_conf: readpdb + if(.not.allocated(bfrag)) allocate(bfrag(4,nres/3)) !(4,maxres/3) + if(.not.allocated(hfrag)) allocate(hfrag(2,nres/3)) !(2,maxres/3) +! COMMON /WAGI/ + allocate(w(maxres22),d0(maxres22)) !(maxres22) +! COMMON /POCHODNE/ +!el allocate(DRDG(maxres22,maxres22)) !(MAXRES22,MAXRES) + allocate(DDD(maxres22)) !(maxres22) + allocate(H(nres,nres)) !(MAXRES,MAXRES) + allocate(XX(nres)) !(MAXRES) +! COMMON /frozen/ + allocate(mask(nres)) !(maxres) +! common.thread +! common /thread/ + allocate(iexam(2,maxthread),ipatt(2,maxthread)) !(2,maxthread) +! common /thread1/ + allocate(ener0(n_ene+2,maxthread),ener(n_ene+2,maxthread)) !(n_ene+2,maxthread) + + return + end subroutine alloc_compare_arrays +!----------------------------------------------------------------------------- +#endif +!----------------------------------------------------------------------------- + end module compare diff --git a/source/unres/compare.f90 b/source/unres/compare.f90 deleted file mode 100644 index b65e57c..0000000 --- a/source/unres/compare.f90 +++ /dev/null @@ -1,4552 +0,0 @@ - module compare -!----------------------------------------------------------------------------- - use io_units - use names - use geometry_data - use energy_data - use control_data -#if .not. defined WHAM_RUN && .not. defined CLUSTER - use compare_data - use io_base - use io_config - use geometry - use energy - use control, only: hpb_partition - use minim_data - use minimm, only: sc_move, minimize -#endif - implicit none -!----------------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------------- - contains -#if .not. defined WHAM_RUN && .not. defined CLUSTER -!----------------------------------------------------------------------------- -! contact.f -!----------------------------------------------------------------------------- - subroutine contact(lprint,ncont,icont,co) - - use geometry, only:dist -! 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(kind=8) :: facont=1.569D0 ! facont = (2/(1-sqrt(1-1/4)))**(1/6) - integer :: ncont - integer,dimension(2,12*nres) :: icont!(2,12*nres) !(2,maxcont) (maxcont=12*maxres) - logical :: lprint -!el local variables - real(kind=8) :: co,rcomp - integer :: kkk,i,j,i1,i2,it1,it2,iti,itj - - ncont=0 - kkk=3 - do i=nnt+kkk,nct - iti=iabs(itype(i)) - do j=nnt,i-kkk - itj=iabs(itype(j)) - if (ipot.ne.4) then -! rcomp=sigmaii(iti,itj)+1.0D0 - rcomp=facont*sigmaii(iti,itj) - else -! rcomp=sigma(iti,itj)+1.0D0 - rcomp=facont*sigma(iti,itj) - endif -! rcomp=6.5D0 -! 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 subroutine contact -!----------------------------------------------------------------------------- - real(kind=8) 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 - integer,dimension(2,12*nres) :: icont,icont_ref !(2,12*nres) (2,maxcont) (maxcont=12*maxres) -!el local variables - integer :: i,j,nmatch - nmatch=0 -! print *,'ncont=',ncont,' ncont_ref=',ncont_ref -! write (iout,'(20i4)') (icont_ref(1,i),i=1,ncont_ref) -! write (iout,'(20i4)') (icont_ref(2,i),i=1,ncont_ref) -! write (iout,'(20i4)') (icont(1,i),i=1,ncont) -! 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 -! print *,' nmatch=',nmatch -! contact_fract=dfloat(nmatch)/dfloat(max0(ncont,ncont_ref)) - contact_fract=dfloat(nmatch)/dfloat(ncont_ref) - return - end function contact_fract -!----------------------------------------------------------------------------- - real(kind=8) 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 - integer,dimension(2,12*nres) :: icont,icont_ref !(2,12*nres) (2,maxcont) (maxcont=12*maxres) -!el local variables - integer :: i,j,nmatch - nmatch=0 -! print *,'ncont=',ncont,' ncont_ref=',ncont_ref -! write (iout,'(20i4)') (icont_ref(1,i),i=1,ncont_ref) -! write (iout,'(20i4)') (icont_ref(2,i),i=1,ncont_ref) -! write (iout,'(20i4)') (icont(1,i),i=1,ncont) -! 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 -! print *,' nmatch=',nmatch -! contact_fract=dfloat(nmatch)/dfloat(max0(ncont,ncont_ref)) - contact_fract_nn=dfloat(ncont-nmatch)/dfloat(ncont) - return - end function contact_fract_nn -!----------------------------------------------------------------------------- - subroutine hairpin(lprint,nharp,iharp) - - use geometry, only:dist -! 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 - integer,dimension(2,12*nres) :: icont !(2,maxcont) (maxcont=12*maxres) - integer :: nharp - integer,dimension(4,nres/3) :: iharp !(4,nres/3)(4,maxres/3) - logical :: lprint,not_done - real(kind=8) :: rcomp=6.0d0 -!el local variables - integer :: i,j,kkk,k,i1,i2,it1,it2,j1,ii1,jj1 -! allocate(icont(2,12*nres)) - - ncont=0 - kkk=0 -! 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 -! 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 -! 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 -! 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 -! write (iout,*)'nharp',nharp,' iharp',(iharp(k,nharp),k=1,4) - endif - endif - enddo -! do i=1,nharp -! write (iout,*)'i',i,' iharp',(iharp(k,i),k=1,4) -! 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) -! do k=jj1,j1,-1 -! write (iout,'(a,i3,$)') restyp(itype(k)),k -! enddo - enddo - endif - return - end subroutine hairpin -!----------------------------------------------------------------------------- -! elecont.f -!----------------------------------------------------------------------------- - 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 - real(kind=8),dimension(2,2) :: elpp_6,elpp_3,ael6_,ael3_ - real(kind=8) :: ael6_i,ael3_i - real(kind=8),dimension(2,2) :: app_,bpp_,rpp_ - integer :: ncont - integer,dimension(2,12*nres) :: icont !(2,12*nres)(2,maxcont) (maxcont=12*maxres) - real(kind=8),dimension(12*nres) :: econt !(maxcont) -!el local variables - integer :: i,j,k,iteli,itelj,i1,i2,it1,it2,ic1,ic2 - real(kind=8) :: elcutoff,elecutoff_14,rri,ees,evdw - real(kind=8) :: xi,yi,zi,dxi,dyi,dzi,aaa,bbb - real(kind=8) :: xmedi,ymedi,zmedi - real(kind=8) :: xj,yj,zj,dxj,dyj,dzj,rrmij,rmij,r3ij,r6ij - real(kind=8) :: vrmij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,& - evdwij,el1,el2,eesij,ene -! -! 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. -! -! 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/ - -!el allocate(econt(12*nres)) !(maxcont) - - 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 - if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) goto 1 - 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 - if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) goto 4 - 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 -! 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 -! write (iout,*) "i",i," j",j," ic1",ic1," ic2",ic2, -! & " 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 -! 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 -! write (iout,*) "ncont",ncont -! do k=1,ncont -! write (iout,*) icont(1,k),icont(2,k) -! 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 -! 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 -! write (iout,*) "ncont",ncont -! do k=1,ncont -! write (iout,*) icont(1,k),icont(2,k) -! 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 subroutine elecont -!----------------------------------------------------------------------------- - 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,i,j,i1,j1,nbeta,nstrand,ii1,jj1,ij,nhelix,& - iii1,jjj1 - integer,dimension(2,12*nres) :: icont !(2,maxcont) (maxcont=12*maxres) - integer,dimension(nres,4) :: isec !(maxres,4) - integer,dimension(nres) :: nsec !(maxres) - logical :: lprint,not_done !,freeres - real(kind=8) :: p1,p2 -!el external freeres - -!el allocate(icont(2,12*nres),isec(nres,4),nsec(nres)) - - if(.not.dccart) call chainbuild - if(.not.allocated(hfrag)) allocate(hfrag(2,nres/3)) !(2,maxres/3) -!d 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) - -! finding parallel beta -!d 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 -!d 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 -!d 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 - -! 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 -!d if (j1.eq.i1+3) write (iout,*) "found 1-4 ",i1,j1,p1,p2 -!o 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. -!d - enddo - j1=j1+1 - if (j1-ii1.gt.5) then - nhelix=nhelix+1 -!d - - 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 - - -! finding antiparallel beta -!d 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 -!d 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 -!d 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 subroutine secondary2 -#endif -!----------------------------------------------------------------------------- - logical function freeres(i,j,nsec,isec) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - integer,dimension(nres,4) :: isec !(maxres,4) - integer,dimension(nres) :: nsec !(maxres) - -!el local variables - integer :: i,j,k,l - - freeres=.false. -#ifndef WHAM_RUN - if (nsec(i).lt.0.or.nsec(j).lt.0) return -#endif - 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 function freeres -!----------------------------------------------------------------------------- -! readrtns_CSA.F -!----------------------------------------------------------------------------- - logical function seq_comp(itypea,itypeb,length) - -!el 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 function seq_comp -#ifndef WHAM_RUN -!----------------------------------------------------------------------------- -! rmsd.F -!----------------------------------------------------------------------------- - 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' - real(kind=8) :: przes(3),obr(3,3) - logical :: non_conv,lprn - real(kind=8) :: rms,frac,frac_nn,co -! call fitsq(rms,c(1,nstart_seq),cref(1,nstart_sup),nsup,przes, -! & obr,non_conv) -! rms=dsqrt(rms) - call rmsd(rms) -!elte(iout,*) "rms_nacc before contact" - 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 subroutine rms_nac_nnc -!----------------------------------------------------------------------------- - subroutine rmsd(drms) - - use regularize_, only:fitsq -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif -! include 'COMMON.CHAIN' -! include 'COMMON.IOUNITS' -! include 'COMMON.INTERACT' -! include 'COMMON.CONTROL' - logical :: non_conv - real(kind=8) :: przes(3),obrot(3,3) - real(kind=8),dimension(3,2*nres+2) :: ccopy,crefcopy !(3,maxres2+2) maxres2=2*maxres - -!el local variables - real(kind=8) :: drms,rminroz,roznica - integer :: i,j,iatom,kkk,iti,k - -!el allocate(ccopy(3,2*nres+2),crefcopy(3,2*nres+2)) !(3,maxres2+2) maxres2=2*maxres - - nperm=1 - do i=1,symetr - nperm=nperm*i - enddo - iatom=0 - rminroz=100d2 -! print *,"nz_start",nz_start," nz_end",nz_end -! if (symetr.le.1) then - do kkk=1,nperm -! 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,kkk)=cref(k,i,kkk) -! 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,kkk)=cref(k,nres+i,kkk) -! enddo -! endif -! enddo -! else -! do kkk=1,nperm - iatom=0 - 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,kkk) - 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,kkk) - enddo - endif - enddo -! enddo -! endif - -! ----- diagnostics -! do kkk=1,nperm -! 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) -! enddo -! ----- end diagnostics -! do kkk=1,nperm - 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 -! call mpi_abort(mpi_comm_world,ierror,ierrcode) - roznica=100.0d10 -#else - stop -#endif - endif -! write (iout,*) "roznica", roznica,kkk - if (roznica.le.rminroz) rminroz=roznica - enddo - drms=dsqrt(dabs(rminroz)) -! ---- diagnostics -! write (iout,*) "nperm,symetr", nperm,symetr -! ---- end diagnostics - return - end subroutine rmsd -!----------------------------------------------------------------------------- - subroutine rmsd_csa(drms) - - use regularize_, only:fitsq -! 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 - real(kind=8) :: przes(3),obrot(3,3) - real(kind=8),dimension(:,:),allocatable :: ccopy,crefcopy !(3,maxres2+2) maxres2=2*maxres - integer :: kkk,iatom,ierror,ierrcode - -!el local variables - integer ::i,j,k,iti - real(kind=8) :: drms,roznica - - allocate(ccopy(3,2*nres+2),crefcopy(3,2*nres+2)) !(3,maxres2+2) maxres2=2*maxres - - kkk=1 - 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 subroutine rmsd_csa -!----------------------------------------------------------------------------- -! test.F -!----------------------------------------------------------------------------- - subroutine test - -!el use minim - use geometry, only:pinorm - use random, only:ran_number,iran_num -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - include 'mpif.h' -! 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' - real(kind=8) :: time0,time1 - real(kind=8) :: energy(0:n_ene),ee - real(kind=8),dimension(6*nres) :: var,var1 !(maxvar) (maxvar=6*maxres) - integer :: j1,j2,jr,i,iretcode,nfun,nft_sc - logical :: debug,accepted - real(kind=8) :: etot,rms,da,temp,betbol,etot0,d,phiold,& - xxr,xxh - debug=.true. -!el allocate(var(6*nres),var1(6*nres)) !(maxvar) (maxvar=6*maxres) - - call geom_to_var(nvar,var1) - call chainbuild - call etotal(energy) - 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) -! phi(jr)=pinorm(phi(jr)+d) - call chainbuild - call etotal(energy) - 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) - 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. -! 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) -! minimize -! 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) -! -------- - else - phi(jr)=phiold - endif - enddo - -! minimize -! call sc_move(2,nres-1,1,10d0,nft_sc,etot) -! call geom_to_var(nvar,var) -! -! call chainbuild -! call write_pdb(998 ,'sc min',etot) -! -! call minimize(etot,var,iretcode,nfun) -! write(iout,*)'------------------------------------------------' -! write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun -! -! call var_to_geom(nvar,var) -! call chainbuild -! call write_pdb(999,'full min',etot) - - return - end subroutine test -!----------------------------------------------------------------------------- -!el#ifdef MPI - subroutine test_n16 - -!el use minim -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - include 'mpif.h' -! 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' - real(kind=8) :: time0,time1 - real(kind=8) :: energy(0:n_ene),ee - real(kind=8),dimension(:),allocatable :: var,var1 !(maxvar) (maxvar=6*maxres) - integer :: jdata(5) - logical :: debug -!el local variables - integer :: i,ij,ieval,iretcode,nfun - real(kind=8) :: etot - debug=.true. - allocate(var(6*nres),var1(6*nres)) !(maxvar) (maxvar=6*maxres) -! - call geom_to_var(nvar,var1) - call chainbuild - call etotal(energy) - etot=energy(0) - write(iout,*) nnt,nct,etot - call write_pdb(1,'first structure',etot) - call secondary2(.true.) - - do i=1,4 - jdata(i)=bfrag(i,2) - enddo - - DO ij=1,4 - ieval=0 - jdata(5)=ij - call var_to_geom(nvar,var1) - write(iout,*) 'N16 test',(jdata(i),i=1,5) - call beta_slide(jdata(1),jdata(2),jdata(3),jdata(4),jdata(5), & - ieval,ij) - call geom_to_var(nvar,var) - - if (minim) then -!el#ifdef MPI - time0=MPI_WTIME() -!el#endif - call minimize(etot,var,iretcode,nfun) - write(iout,*)'------------------------------------------------' - write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun,& - '+ DIST eval',ieval - -!el#ifdef MPI - time1=MPI_WTIME() -!el#endif - write (iout,'(a,f6.2,f8.2,a)')' Time for full min.',time1-time0,& - nfun/(time1-time0),' eval/s' - - call var_to_geom(nvar,var) - call chainbuild - call write_pdb(ij*100+99,'full min',etot) - endif - - - ENDDO - - return - end subroutine test_n16 -!el#endif -!----------------------------------------------------------------------------- - subroutine test_local - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' - real(kind=8) :: time0,time1 - real(kind=8) :: energy(0:n_ene),ee - real(kind=8),dimension(6*nres) :: varia !(maxvar) (maxvar=6*maxres) - integer :: nft_sc - real(kind=8) :: etot -! -! allocate(varia(6*nres)) !(maxvar) (maxvar=6*maxres) - call chainbuild -! call geom_to_var(nvar,varia) - call write_pdb(1,'first structure',0d0) - - call etotal(energy) - 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_local -!----------------------------------------------------------------------------- - subroutine test_sc - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' - real(kind=8) :: time0,time1,etot - real(kind=8) :: energy(0:n_ene),ee - real(kind=8),dimension(6*nres) :: varia !(maxvar) (maxvar=6*maxres) - integer :: nft_sc -! - call chainbuild -! call geom_to_var(nvar,varia) - call write_pdb(1,'first structure',0d0) - - call etotal(energy) - 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 subroutine test_sc -!----------------------------------------------------------------------------- - subroutine bgrow(bstrand,nbstrand,in,ind,new) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CHAIN' - integer,dimension(nres/3,6) :: bstrand !(maxres/3,6) - -!el local variables - integer :: nbstrand,in,ind,new,ishift,i - - 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 subroutine bgrow -!----------------------------------------------------------------------------- - subroutine test11 - - use geometry, only:dist -!el use minim -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - include 'mpif.h' -! 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.DISTFIT' - integer :: if(20,nres),nif,ifa(20) - integer :: ibc(0:nres,0:nres),istrand(20) - integer :: ibd(nres),ifb(10,2),nifb,lifb(10),lifb0 - integer :: itmp(20,nres) - real(kind=8) :: time0,time1 - real(kind=8) :: energy(0:n_ene),ee - real(kind=8),dimension(6*nres) :: varia,vorg !(maxvar) (maxvar=6*maxres) -! - logical :: debug,ltest,usedbfrag(nres/3) - character(len=50) :: linia -! - integer :: betasheet(nres),ibetasheet(nres),nbetasheet - integer :: bstrand(nres/3,6),nbstrand - real(kind=8) :: etot - integer :: i,j,jk,k,isa,m,l,ig,iconf,is,ii,iused_nbfrag,& - in,ind,ifun,nfun,iretcode -!------------------------ - - debug=.true. -!------------------------ - nbstrand=0 - nbetasheet=0 - do i=1,nres - betasheet(i)=0 - ibetasheet(i)=0 - enddo - call geom_to_var(nvar,vorg) - call secondary2(debug) - - if (nbfrag.le.1) return - - do i=1,nbfrag - usedbfrag(i)=.false. - enddo - - - nbetasheet=nbetasheet+1 - nbstrand=2 - bstrand(1,1)=bfrag(1,1) - bstrand(1,2)=bfrag(2,1) - bstrand(1,3)=nbetasheet - bstrand(1,4)=1 - bstrand(1,5)=bfrag(1,1) - bstrand(1,6)=bfrag(2,1) - do i=bfrag(1,1),bfrag(2,1) - betasheet(i)=nbetasheet - ibetasheet(i)=1 - enddo -! - bstrand(2,1)=bfrag(3,1) - bstrand(2,2)=bfrag(4,1) - bstrand(2,3)=nbetasheet - bstrand(2,5)=bfrag(3,1) - bstrand(2,6)=bfrag(4,1) - - if (bfrag(3,1).le.bfrag(4,1)) then - bstrand(2,4)=2 - do i=bfrag(3,1),bfrag(4,1) - betasheet(i)=nbetasheet - ibetasheet(i)=2 - enddo - else - bstrand(2,4)=-2 - do i=bfrag(4,1),bfrag(3,1) - betasheet(i)=nbetasheet - ibetasheet(i)=2 - enddo - endif - - iused_nbfrag=1 - - do while (iused_nbfrag.ne.nbfrag) - - do j=2,nbfrag - - IF (.not.usedbfrag(j)) THEN - - write (*,*) j,(bfrag(i,j),i=1,4) - do jk=6,1,-1 - write (*,'(i4,a3,10i4)') jk,'B',(bstrand(i,jk),i=1,nbstrand) - enddo - write (*,*) '------------------' - - - if (bfrag(3,j).le.bfrag(4,j)) then - do i=bfrag(3,j),bfrag(4,j) - if(betasheet(i).eq.nbetasheet) then - in=ibetasheet(i) - do k=bfrag(3,j),bfrag(4,j) - betasheet(k)=nbetasheet - ibetasheet(k)=in - enddo - nbstrand=nbstrand+1 - usedbfrag(j)=.true. - iused_nbfrag=iused_nbfrag+1 - do k=bfrag(1,j),bfrag(2,j) - betasheet(k)=nbetasheet - ibetasheet(k)=nbstrand - enddo - if (bstrand(in,4).lt.0) then - bstrand(nbstrand,1)=bfrag(2,j) - bstrand(nbstrand,2)=bfrag(1,j) - bstrand(nbstrand,3)=nbetasheet - bstrand(nbstrand,4)=-nbstrand - bstrand(nbstrand,5)=bstrand(nbstrand,1) - bstrand(nbstrand,6)=bstrand(nbstrand,2) - if(bstrand(in,1).lt.bfrag(4,j)) then - call bgrow(bstrand,nbstrand,in,1,bfrag(4,j)) - else - bstrand(nbstrand,5)=bstrand(nbstrand,5)+& - (bstrand(in,5)-bfrag(4,j)) - endif - if(bstrand(in,2).gt.bfrag(3,j)) then - call bgrow(bstrand,nbstrand,in,2,bfrag(3,j)) - else - bstrand(nbstrand,6)=bstrand(nbstrand,6)-& - (-bstrand(in,6)+bfrag(3,j)) - endif - else - bstrand(nbstrand,1)=bfrag(1,j) - bstrand(nbstrand,2)=bfrag(2,j) - bstrand(nbstrand,3)=nbetasheet - bstrand(nbstrand,4)=nbstrand - bstrand(nbstrand,5)=bstrand(nbstrand,1) - bstrand(nbstrand,6)=bstrand(nbstrand,2) - if(bstrand(in,1).gt.bfrag(3,j)) then - call bgrow(bstrand,nbstrand,in,1,bfrag(3,j)) - else - bstrand(nbstrand,5)=bstrand(nbstrand,5)-& - (-bstrand(in,5)+bfrag(3,j)) - endif - if(bstrand(in,2).lt.bfrag(4,j)) then - call bgrow(bstrand,nbstrand,in,2,bfrag(4,j)) - else - bstrand(nbstrand,6)=bstrand(nbstrand,6)+& - (bstrand(in,6)-bfrag(4,j)) - endif - endif - goto 11 - endif - if(betasheet(bfrag(1,j)+i-bfrag(3,j)).eq.nbetasheet) then - in=ibetasheet(bfrag(1,j)+i-bfrag(3,j)) - do k=bfrag(1,j),bfrag(2,j) - betasheet(k)=nbetasheet - ibetasheet(k)=in - enddo - nbstrand=nbstrand+1 - usedbfrag(j)=.true. - iused_nbfrag=iused_nbfrag+1 - do k=bfrag(3,1),bfrag(4,1) - betasheet(k)=nbetasheet - ibetasheet(k)=nbstrand - enddo - if (bstrand(in,4).lt.0) then - bstrand(nbstrand,1)=bfrag(4,j) - bstrand(nbstrand,2)=bfrag(3,j) - bstrand(nbstrand,3)=nbetasheet - bstrand(nbstrand,4)=-nbstrand - bstrand(nbstrand,5)=bstrand(nbstrand,1) - bstrand(nbstrand,6)=bstrand(nbstrand,2) - if(bstrand(in,1).lt.bfrag(2,j)) then - call bgrow(bstrand,nbstrand,in,1,bfrag(2,j)) - else - bstrand(nbstrand,5)=bstrand(nbstrand,5)+& - (bstrand(in,5)-bfrag(2,j)) - endif - if(bstrand(in,2).gt.bfrag(1,j)) then - call bgrow(bstrand,nbstrand,in,2,bfrag(1,j)) - else - bstrand(nbstrand,6)=bstrand(nbstrand,6)-& - (-bstrand(in,6)+bfrag(1,j)) - endif - else - bstrand(nbstrand,1)=bfrag(3,j) - bstrand(nbstrand,2)=bfrag(4,j) - bstrand(nbstrand,3)=nbetasheet - bstrand(nbstrand,4)=nbstrand - bstrand(nbstrand,5)=bstrand(nbstrand,1) - bstrand(nbstrand,6)=bstrand(nbstrand,2) - if(bstrand(in,1).gt.bfrag(1,j)) then - call bgrow(bstrand,nbstrand,in,1,bfrag(1,j)) - else - bstrand(nbstrand,5)=bstrand(nbstrand,5)-& - (-bstrand(in,5)+bfrag(1,j)) - endif - if(bstrand(in,2).lt.bfrag(2,j)) then - call bgrow(bstrand,nbstrand,in,2,bfrag(2,j)) - else - bstrand(nbstrand,6)=bstrand(nbstrand,6)+& - (bstrand(in,6)-bfrag(2,j)) - endif - endif - goto 11 - endif - enddo - else - do i=bfrag(4,j),bfrag(3,j) - if(betasheet(i).eq.nbetasheet) then - in=ibetasheet(i) - do k=bfrag(4,j),bfrag(3,j) - betasheet(k)=nbetasheet - ibetasheet(k)=in - enddo - nbstrand=nbstrand+1 - usedbfrag(j)=.true. - iused_nbfrag=iused_nbfrag+1 - do k=bfrag(1,j),bfrag(2,j) - betasheet(k)=nbetasheet - ibetasheet(k)=nbstrand - enddo - if (bstrand(in,4).lt.0) then - bstrand(nbstrand,1)=bfrag(1,j) - bstrand(nbstrand,2)=bfrag(2,j) - bstrand(nbstrand,3)=nbetasheet - bstrand(nbstrand,4)=nbstrand - bstrand(nbstrand,5)=bstrand(nbstrand,1) - bstrand(nbstrand,6)=bstrand(nbstrand,2) - if(bstrand(in,1).lt.bfrag(3,j)) then - call bgrow(bstrand,nbstrand,in,1,bfrag(3,j)) - else - bstrand(nbstrand,5)=bstrand(nbstrand,5)-& - (bstrand(in,5)-bfrag(3,j)) - endif - if(bstrand(in,2).gt.bfrag(4,j)) then - call bgrow(bstrand,nbstrand,in,2,bfrag(4,j)) - else - bstrand(nbstrand,6)=bstrand(nbstrand,6)+& - (-bstrand(in,6)+bfrag(4,j)) - endif - else - bstrand(nbstrand,1)=bfrag(2,j) - bstrand(nbstrand,2)=bfrag(1,j) - bstrand(nbstrand,3)=nbetasheet - bstrand(nbstrand,4)=-nbstrand - bstrand(nbstrand,5)=bstrand(nbstrand,1) - bstrand(nbstrand,6)=bstrand(nbstrand,2) - if(bstrand(in,1).gt.bfrag(4,j)) then - call bgrow(bstrand,nbstrand,in,1,bfrag(4,j)) - else - bstrand(nbstrand,5)=bstrand(nbstrand,5)+& - (-bstrand(in,5)+bfrag(4,j)) - endif - if(bstrand(in,2).lt.bfrag(3,j)) then - call bgrow(bstrand,nbstrand,in,2,bfrag(3,j)) - else - bstrand(nbstrand,6)=bstrand(nbstrand,6)-& - (bstrand(in,6)-bfrag(3,j)) - endif - endif - goto 11 - endif - if(betasheet(bfrag(2,j)-i+bfrag(4,j)).eq.nbetasheet) then - in=ibetasheet(bfrag(2,j)-i+bfrag(4,j)) - do k=bfrag(1,j),bfrag(2,j) - betasheet(k)=nbetasheet - ibetasheet(k)=in - enddo - nbstrand=nbstrand+1 - usedbfrag(j)=.true. - iused_nbfrag=iused_nbfrag+1 - do k=bfrag(4,j),bfrag(3,j) - betasheet(k)=nbetasheet - ibetasheet(k)=nbstrand - enddo - if (bstrand(in,4).lt.0) then - bstrand(nbstrand,1)=bfrag(4,j) - bstrand(nbstrand,2)=bfrag(3,j) - bstrand(nbstrand,3)=nbetasheet - bstrand(nbstrand,4)=nbstrand - bstrand(nbstrand,5)=bstrand(nbstrand,1) - bstrand(nbstrand,6)=bstrand(nbstrand,2) - if(bstrand(in,1).lt.bfrag(2,j)) then - call bgrow(bstrand,nbstrand,in,1,bfrag(2,j)) - else - bstrand(nbstrand,5)=bstrand(nbstrand,5)-& - (bstrand(in,5)-bfrag(2,j)) - endif - if(bstrand(in,2).gt.bfrag(1,j)) then - call bgrow(bstrand,nbstrand,in,2,bfrag(1,j)) - else - bstrand(nbstrand,6)=bstrand(nbstrand,6)+& - (-bstrand(in,6)+bfrag(1,j)) - endif - else - bstrand(nbstrand,1)=bfrag(3,j) - bstrand(nbstrand,2)=bfrag(4,j) - bstrand(nbstrand,3)=nbetasheet - bstrand(nbstrand,4)=-nbstrand - bstrand(nbstrand,5)=bstrand(nbstrand,1) - bstrand(nbstrand,6)=bstrand(nbstrand,2) - if(bstrand(in,1).gt.bfrag(1,j)) then - call bgrow(bstrand,nbstrand,in,1,bfrag(1,j)) - else - bstrand(nbstrand,5)=bstrand(nbstrand,5)+& - (-bstrand(in,5)+bfrag(1,j)) - endif - if(bstrand(in,2).lt.bfrag(2,j)) then - call bgrow(bstrand,nbstrand,in,2,bfrag(2,j)) - else - bstrand(nbstrand,6)=bstrand(nbstrand,6)-& - (bstrand(in,6)-bfrag(2,j)) - endif - endif - goto 11 - endif - enddo - endif - - - - ENDIF - enddo - - j=2 - do while (usedbfrag(j)) - j=j+1 - enddo - - nbstrand=nbstrand+1 - nbetasheet=nbetasheet+1 - bstrand(nbstrand,1)=bfrag(1,j) - bstrand(nbstrand,2)=bfrag(2,j) - bstrand(nbstrand,3)=nbetasheet - bstrand(nbstrand,5)=bfrag(1,j) - bstrand(nbstrand,6)=bfrag(2,j) - - bstrand(nbstrand,4)=nbstrand - do i=bfrag(1,j),bfrag(2,j) - betasheet(i)=nbetasheet - ibetasheet(i)=nbstrand - enddo -! - nbstrand=nbstrand+1 - bstrand(nbstrand,1)=bfrag(3,j) - bstrand(nbstrand,2)=bfrag(4,j) - bstrand(nbstrand,3)=nbetasheet - bstrand(nbstrand,5)=bfrag(3,j) - bstrand(nbstrand,6)=bfrag(4,j) - - if (bfrag(3,j).le.bfrag(4,j)) then - bstrand(nbstrand,4)=nbstrand - do i=bfrag(3,j),bfrag(4,j) - betasheet(i)=nbetasheet - ibetasheet(i)=nbstrand - enddo - else - bstrand(nbstrand,4)=-nbstrand - do i=bfrag(4,j),bfrag(3,j) - betasheet(i)=nbetasheet - ibetasheet(i)=nbstrand - enddo - endif - - iused_nbfrag=iused_nbfrag+1 - usedbfrag(j)=.true. - - - 11 continue - do jk=6,1,-1 - write (*,'(i4,a3,10i4)') jk,'A',(bstrand(i,jk),i=1,nbstrand) - enddo - - - enddo - - do i=1,nres - if (betasheet(i).ne.0) write(*,*) i,betasheet(i),ibetasheet(i) - enddo - write(*,*) - do j=6,1,-1 - write (*,'(i4,a3,10i4)') j,':',(bstrand(i,j),i=1,nbstrand) - enddo - -!------------------------ - nifb=0 - do i=1,nbstrand - do j=i+1,nbstrand - if(iabs(bstrand(i,5)-bstrand(j,5)).le.5 .or. & - iabs(bstrand(i,6)-bstrand(j,6)).le.5 ) then - nifb=nifb+1 - ifb(nifb,1)=bstrand(i,4) - ifb(nifb,2)=bstrand(j,4) - endif - enddo - enddo - - write(*,*) - do i=1,nifb - write (*,'(a3,20i4)') "ifb",i,ifb(i,1),ifb(i,2) - enddo - - do i=1,nbstrand - ifa(i)=bstrand(i,4) - enddo - write (*,'(a3,20i4)') "ifa",(ifa(i),i=1,nbstrand) - - nif=iabs(bstrand(1,6)-bstrand(1,5))+1 - do j=2,nbstrand - if (iabs(bstrand(j,6)-bstrand(j,5))+1.gt.nif) & - nif=iabs(bstrand(j,6)-bstrand(j,5))+1 - enddo - - write(*,*) nif - do i=1,nif - do j=1,nbstrand - if(j,i)=bstrand(j,6)+(i-1)*sign(1,bstrand(j,5)-bstrand(j,6)) - if (if(j,i).gt.0) then - if(betasheet(if(j,i)).eq.0 .or. & - ibetasheet(if(j,i)).ne.iabs(bstrand(j,4))) if(j,i)=0 - else - if(j,i)=0 - endif - enddo - write(*,'(a3,10i4)') 'if ',(if(j,i),j=1,nbstrand) - enddo - -! read (inp,*) (ifa(i),i=1,4) -! do i=1,nres -! read (inp,*,err=20,end=20) (if(j,i),j=1,4) -! enddo -! 20 nif=i-1 - stop -!------------------------ - - isa=4 - is=2*isa-1 - iconf=0 -!ccccccccccccccccccccccccccccccccc - DO ig=1,is**isa-1 -!ccccccccccccccccccccccccccccccccc - - ii=ig - do j=1,is - istrand(is-j+1)=int(ii/is**(is-j)) - ii=ii-istrand(is-j+1)*is**(is-j) - enddo - ltest=.true. - do k=1,isa - istrand(k)=istrand(k)+1 - if(istrand(k).gt.isa) istrand(k)=istrand(k)-2*isa-1 - enddo - do k=1,isa - do l=1,isa - if(istrand(k).eq.istrand(l).and.k.ne.l.or. & - istrand(k).eq.-istrand(l).and.k.ne.l) ltest=.false. - enddo - enddo - - lifb0=1 - do m=1,nifb - lifb(m)=0 - do k=1,isa-1 - if( & - ifb(m,1).eq.istrand(k).and.ifb(m,2).eq.istrand(k+1).or. & - ifb(m,2).eq.istrand(k).and.ifb(m,1).eq.istrand(k+1).or. & - -ifb(m,1).eq.istrand(k).and.-ifb(m,2).eq.istrand(k+1).or. & - -ifb(m,2).eq.istrand(k).and.-ifb(m,1).eq.istrand(k+1)) & - lifb(m)=1 - enddo - lifb0=lifb0*lifb(m) - enddo - - if (mod(isa,2).eq.0) then - do k=isa/2+1,isa - if (istrand(k).eq.1) ltest=.false. - enddo - else - do k=(isa+1)/2+1,isa - if (istrand(k).eq.1) ltest=.false. - enddo - endif - - IF (ltest.and.lifb0.eq.1) THEN - iconf=iconf+1 - - call var_to_geom(nvar,vorg) - - write (*,'(i5,i10,10i3)') iconf,ig,(istrand(k),k=1,isa) - write (iout,'(i5,i10,10i3)') iconf,ig,(istrand(k),k=1,isa) - write (linia,'(10i3)') (istrand(k),k=1,isa) - - do i=1,nres - do j=1,nres - ibc(i,j)=0 - enddo - enddo - - - do i=1,4 - if ( sign(1,istrand(i)).eq.sign(1,ifa(iabs(istrand(i)))) ) then - do j=1,nif - itmp(iabs(istrand(i)),j)=if(iabs(ifa(iabs(istrand(i)))),j) - enddo - else - do j=1,nif - itmp(iabs(istrand(i)),j)=if(iabs(ifa(iabs(istrand(i)))),nif-j+1) - enddo - endif - enddo - - do i=1,nif - write(*,*) (itmp(j,i),j=1,4) - enddo - - do i=1,nif -! ifa(1),ifa(2),ifa(3),ifa(4) -! if(1,i),if(2,i),if(3,i),if(4,i) - do k=1,isa-1 - ltest=.false. - do m=1,nifb - if( & - ifb(m,1).eq.istrand(k).and.ifb(m,2).eq.istrand(k+1).or. & - ifb(m,2).eq.istrand(k).and.ifb(m,1).eq.istrand(k+1).or. & - -ifb(m,1).eq.istrand(k).and.-ifb(m,2).eq.istrand(k+1).or. & - -ifb(m,2).eq.istrand(k).and.-ifb(m,1).eq.istrand(k+1)) & - then - ltest=.true. - goto 110 - endif - enddo - 110 continue - if (ltest) then - ibc(itmp(iabs(istrand(k)),i),itmp(iabs(istrand(k+1)),i))=-1 - else - ibc(itmp(iabs(istrand(k)),i),itmp(iabs(istrand(k+1)),i))=-2 - endif -! - if (k.lt.3) & - ibc(itmp(iabs(istrand(k)),i),itmp(iabs(istrand(k+2)),i))=-3 - if (k.lt.2) & - ibc(itmp(iabs(istrand(k)),i),itmp(iabs(istrand(k+3)),i))=-4 - enddo - enddo -!------------------------ - -! -! freeze sec.elements -! - do i=1,nres - mask(i)=1 - mask_phi(i)=1 - mask_theta(i)=1 - mask_side(i)=1 - enddo - - do j=1,nbfrag - do i=bfrag(1,j),bfrag(2,j) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - enddo - if (bfrag(3,j).le.bfrag(4,j)) then - do i=bfrag(3,j),bfrag(4,j) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - enddo - else - do i=bfrag(4,j),bfrag(3,j) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - enddo - endif - enddo - do j=1,nhfrag - do i=hfrag(1,j),hfrag(2,j) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - enddo - enddo - mask_r=.true. - -!------------------------ -! generate constrains -! - nhpb0=nhpb - call chainbuild - ind=0 - do i=1,nres-3 - do j=i+3,nres - ind=ind+1 - if ( ibc(i,j).eq.-1 .or. ibc(j,i).eq.-1) then - d0(ind)=DIST(i,j) - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else if ( ibc(i,j).eq.-2 .or. ibc(j,i).eq.-2) then - d0(ind)=5.0 - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else if ( ibc(i,j).eq.-3 .or. ibc(j,i).eq.-3) then - d0(ind)=11.0 - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else if ( ibc(i,j).eq.-4 .or. ibc(j,i).eq.-4) then - d0(ind)=16.0 - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else if ( ibc(i,j).gt.0 ) then - d0(ind)=DIST(i,ibc(i,j)) - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else if ( ibc(j,i).gt.0 ) then - d0(ind)=DIST(ibc(j,i),j) - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else - w(ind)=0.0 - endif - ddd(ind)=d0(ind) - enddo - enddo - call hpb_partition -!d-------------------------- - - write(iout,'(i3,2i4,a3,2i4,f7.2)') (i,ibc(ihpb(i),jhpb(i)),& - ibc(jhpb(i),ihpb(i)),' --',& - ihpb(i),jhpb(i),dhpb(i),i=1,nhpb) - -!d nhpb=0 -!d goto 901 -! -! -!el#ifdef MPI - call contact_cp_min(varia,ifun,iconf,linia,debug) - if (minim) then -!el#ifdef MPI - time0=MPI_WTIME() -!el#endif - call minimize(etot,varia,iretcode,nfun) - write(iout,*)'------------------------------------------------' - write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun,& - '+ DIST eval',ifun - -!el#ifdef MPI - time1=MPI_WTIME() -!el#endif - write (iout,'(a,f6.2,f8.2,a)')' Time for full min.',time1-time0,& - nfun/(time1-time0),' eval/s' - - write (linia,'(a10,10i3)') 'full_min',(istrand(k),k=1,isa) - call var_to_geom(nvar,varia) - call chainbuild - call write_pdb(900+iconf,linia,etot) - endif -!el#endif - call etotal(energy) - etot=energy(0) - call enerprint(energy) -!d call intout -!d call briefout(0,etot) -!d call secondary2(.true.) - - 901 CONTINUE -!test return -!ccccccccccccccccccccccccccccccccccc - ENDIF - ENDDO -!ccccccccccccccccccccccccccccccccccc - - return - 10 write (iout,'(a)') 'Error reading test structure.' - return - end subroutine test11 -!----------------------------------------------------------------------------- - subroutine test3 - - use geometry, only:dist -!el use minim -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - include 'mpif.h' -! 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.DISTFIT' - integer :: if(3,nres),nif - integer :: ibc(nres,nres),istrand(20) - integer :: ibd(nres),ifb(10,2),nifb,lifb(10),lifb0 - real(kind=8) :: time0,time1 - real(kind=8) :: energy(0:n_ene),ee - real(kind=8),dimension(6*nres) :: varia !(maxvar) (maxvar=6*maxres) -! - logical :: debug,ltest - character(len=50) :: linia - integer :: ieval,i,j,ind,in_pdb,nfun,iretcode - real(kind=8) :: etot -! - do i=1,nres - read (inp,*,err=20,end=20) if(1,i),if(2,i),if(3,i) - enddo - 20 nif=i-1 - write (*,'(a4,3i5)') ('if =',if(1,i),if(2,i),if(3,i),& - i=1,nif) - - -!------------------------ - call secondary2(debug) -!------------------------ - do i=1,nres - do j=1,nres - ibc(i,j)=0 - enddo - enddo - -! -! freeze sec.elements and store indexes for beta constrains -! - do i=1,nres - mask(i)=1 - mask_phi(i)=1 - mask_theta(i)=1 - mask_side(i)=1 - enddo - - do j=1,nbfrag - do i=bfrag(1,j),bfrag(2,j) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - enddo - if (bfrag(3,j).le.bfrag(4,j)) then - do i=bfrag(3,j),bfrag(4,j) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - ibc(bfrag(1,j)+i-bfrag(3,j),i)=-1 - enddo - else - do i=bfrag(4,j),bfrag(3,j) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - ibc(bfrag(2,j)-i+bfrag(4,j),i)=-1 - enddo - endif - enddo - do j=1,nhfrag - do i=hfrag(1,j),hfrag(2,j) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - enddo - enddo - mask_r=.true. - - -! ---------------- test -------------- - do i=1,nif - if (ibc(if(1,i),if(2,i)).eq.-1) then - ibc(if(1,i),if(2,i))=if(3,i) - ibc(if(1,i),if(3,i))=if(2,i) - else if (ibc(if(2,i),if(1,i)).eq.-1) then - ibc(if(2,i),if(1,i))=0 - ibc(if(1,i),if(2,i))=if(3,i) - ibc(if(1,i),if(3,i))=if(2,i) - else - ibc(if(1,i),if(2,i))=if(3,i) - ibc(if(1,i),if(3,i))=if(2,i) - endif - enddo - - do i=1,nres - do j=1,nres - if (ibc(i,j).ne.0) write(*,'(3i5)') i,j,ibc(i,j) - enddo - enddo -!------------------------ - call chainbuild - ind=0 - do i=1,nres-3 - do j=i+3,nres - ind=ind+1 - if ( ibc(i,j).eq.-1 ) then - d0(ind)=DIST(i,j) - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else if ( ibc(i,j).gt.0 ) then - d0(ind)=DIST(i,ibc(i,j)) - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else if ( ibc(j,i).gt.0 ) then - d0(ind)=DIST(ibc(j,i),j) - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else - w(ind)=0.0 - endif - enddo - enddo - call hpb_partition - -!d-------------------------- - write(*,'(i3,2i4,a3,2i4,f7.2)') (i,ibc(ihpb(i),jhpb(i)),& - ibc(jhpb(i),ihpb(i)),' --',& - ihpb(i),jhpb(i),dhpb(i),i=1,nhpb) - - - linia='dist' - debug=.true. - in_pdb=7 -! -!el#ifdef MPI - call contact_cp_min(varia,ieval,in_pdb,linia,debug) - if (minim) then -!el#ifdef MPI - time0=MPI_WTIME() -!el#endif - call minimize(etot,varia,iretcode,nfun) - write(iout,*)'------------------------------------------------' - write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun,& - '+ DIST eval',ieval - -!el#ifdef MPI - time1=MPI_WTIME() -!el#endif - write (iout,'(a,f6.2,f8.2,a)')' Time for full min.',time1-time0,& - nfun/(time1-time0),' eval/s' - - - call var_to_geom(nvar,varia) - call chainbuild - call write_pdb(999,'full min',etot) - endif -!el#endif - call etotal(energy) - etot=energy(0) - call enerprint(energy) - call intout - call briefout(0,etot) - call secondary2(.true.) - - return - 10 write (iout,'(a)') 'Error reading test structure.' - return - end subroutine test3 -!----------------------------------------------------------------------------- - subroutine test__ - -!el use minim -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - include 'mpif.h' -! 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.DISTFIT' - integer :: if(2,2),ind - integer :: iff(nres) - real(kind=8) :: time0,time1 - real(kind=8) :: energy(0:n_ene),ee - real(kind=8),dimension(nres) :: theta2,phi2,alph2,omeg2,& - theta1,phi1,alph1,omeg1 !(maxres) - real(kind=8),dimension(6*nres) :: varia,varia2 !(maxvar) (maxvar=6*maxres) -! - integer :: i,j,nn,ifun,iretcode,nfun - real(kind=8) :: etot - nn=0 - - read (inp,*,err=10,end=10) if(1,1),if(1,2),if(2,1),if(2,2) - write (iout,'(a4,4i5)') 'if =',if(1,1),if(1,2),if(2,1),if(2,2) - read (inp,*,err=10,end=10) (theta2(i),i=3,nres) - read (inp,*,err=10,end=10) (phi2(i),i=4,nres) - read (inp,*,err=10,end=10) (alph2(i),i=2,nres-1) - read (inp,*,err=10,end=10) (omeg2(i),i=2,nres-1) - do i=1,nres - theta2(i)=deg2rad*theta2(i) - phi2(i)=deg2rad*phi2(i) - alph2(i)=deg2rad*alph2(i) - omeg2(i)=deg2rad*omeg2(i) - enddo - do i=1,nres - theta1(i)=theta(i) - phi1(i)=phi(i) - alph1(i)=alph(i) - omeg1(i)=omeg(i) - enddo - - do i=1,nres - mask(i)=1 - enddo - - -!------------------------ - do i=1,nres - iff(i)=0 - enddo - do j=1,2 - do i=if(j,1),if(j,2) - iff(i)=1 - enddo - enddo - - call chainbuild - call geom_to_var(nvar,varia) - call write_pdb(1,'first structure',0d0) - - call secondary(.true.) - - call secondary2(.true.) - - do j=1,nbfrag - if ( (bfrag(3,j).lt.bfrag(4,j) .or. & - bfrag(4,j)-bfrag(2,j).gt.4) .and. & - bfrag(2,j)-bfrag(1,j).gt.3 ) then - nn=nn+1 - - if (bfrag(3,j).lt.bfrag(4,j)) then - write(iout,'(a6,i3,a1,i3,a1,i3,a1,i3)') & - "select",bfrag(1,j)-1,"-",bfrag(2,j)-1,& - ",",bfrag(3,j)-1,"-",bfrag(4,j)-1 - else - write(iout,'(a6,i3,a1,i3,a1,i3,a1,i3)') & - "select",bfrag(1,j)-1,"-",bfrag(2,j)-1,& - ",",bfrag(4,j)-1,"-",bfrag(3,j)-1 - endif - endif - enddo - - do i=1,nres - theta(i)=theta2(i) - phi(i)=phi2(i) - alph(i)=alph2(i) - omeg(i)=omeg2(i) - enddo - - call chainbuild - call geom_to_var(nvar,varia2) - call write_pdb(2,'second structure',0d0) - - - -!------------------------------------------------------- -!el#ifdef MPI - ifun=-1 - call contact_cp(varia,varia2,iff,ifun,7) - if (minim) then -!el#ifdef MPI - time0=MPI_WTIME() -!el#endif - call minimize(etot,varia,iretcode,nfun) - write(iout,*)'------------------------------------------------' - write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun,& - '+ DIST eval',ifun - -!el#ifdef MPI - time1=MPI_WTIME() -!el#endif - write (iout,'(a,f6.2,f8.2,a)')' Time for full min.',time1-time0,& - nfun/(time1-time0),' eval/s' - - - call var_to_geom(nvar,varia) - call chainbuild - call write_pdb(999,'full min',etot) - endif -!el#endif - call etotal(energy) - etot=energy(0) - call enerprint(energy) - call intout - call briefout(0,etot) - - return - 10 write (iout,'(a)') 'Error reading test structure.' - return - end subroutine test__ -!----------------------------------------------------------------------------- - 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,nres*nres/2),isec(nres,3) - logical :: lprint,not_done - real(kind=4) :: dcont(nres*nres/2),d - real(kind=4) :: rcomp = 7.0 - real(kind=4) :: rbeta = 5.2 - real(kind=4) :: ralfa = 5.2 - real(kind=4) :: r310 = 6.6 - real(kind=8),dimension(3) :: xpi,xpj - integer :: i,k,j,i1,j1,nbeta,nstrand,ii1,jj1,ij,iii1,jjj1,& - nhelix - call chainbuild -!d 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 -!d d = (c(1,i)-c(1,j))*(c(1,i)-c(1,j)) + -!d & (c(2,i)-c(2,j))*(c(2,i)-c(2,j)) + -!d & (c(3,i)-c(3,j))*(c(3,i)-c(3,j)) -!d 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 - -! finding parallel beta -!d 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 -!d 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 -!d 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 - -! finding antiparallel beta -!d 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 -!d 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 -!d 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 - - -! 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 -!d if (j1.eq.i1+3) write (iout,*) "found 1-4 ",i1,j1,dcont(i) -!d 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 -!d write (iout,*) i1,j1,not_done - enddo - j1=j1-1 - if (j1-ii1.gt.4) then - nhelix=nhelix+1 -!d 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 subroutine secondary -!----------------------------------------------------------------------------- - subroutine contact_cp2(var,var2,iff,ieval,in_pdb) - - use geometry, only:dist -!el use minim -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - include 'mpif.h' -! include 'COMMON.SBRIDGE' -! include 'COMMON.FFIELD' -! include 'COMMON.IOUNITS' -! include 'COMMON.DISTFIT' -! include 'COMMON.VAR' -! include 'COMMON.CHAIN' -! include 'COMMON.MINIM' - - character(len=50) :: linia - integer :: nf,ij(4) - real(kind=8),dimension(6*nres) :: var,var2 !(maxvar) (maxvar=6*maxres) - real(kind=8) :: time0,time1 - integer :: iff(nres),ieval - real(kind=8),dimension(nres) :: theta1,phi1,alph1,omeg1 !(maxres) - -!el local variables - integer :: in_pdb,i,j,ind,ipot0,maxmin0,maxfun0,nfun,iwsk,iretcode - real(kind=8) :: wstrain0,etot - integer :: maxres22 - maxres22=nres*(nres+1)/2 - - if(.not.allocated(DRDG)) allocate(DRDG(maxres22,maxres22)) !(MAXRES22,MAXRES) - call var_to_geom(nvar,var) - call chainbuild - nhpb0=nhpb - ind=0 - do i=1,nres-3 - do j=i+3,nres - ind=ind+1 - if ( iff(i).eq.1.and.iff(j).eq.1 ) then - d0(ind)=DIST(i,j) - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else - w(ind)=0.0 - endif - enddo - enddo - call hpb_partition - - do i=1,nres - theta1(i)=theta(i) - phi1(i)=phi(i) - alph1(i)=alph(i) - omeg1(i)=omeg(i) - enddo - - call var_to_geom(nvar,var2) - - do i=1,nres - if ( iff(i).eq.1 ) then - theta(i)=theta1(i) - phi(i)=phi1(i) - alph(i)=alph1(i) - omeg(i)=omeg1(i) - endif - enddo - - call chainbuild -!d call write_pdb(3,'combined structure',0d0) -!d time0=MPI_WTIME() - - NX=NRES-3 - NY=((NRES-4)*(NRES-5))/2 - call distfit(.true.,200) - -!d time1=MPI_WTIME() -!d write (iout,'(a,f6.2,a)') ' Time for distfit ',time1-time0,' sec' - - ipot0=ipot - maxmin0=maxmin - maxfun0=maxfun - wstrain0=wstrain - - ipot=6 - maxmin=2000 - maxfun=5000 - call geom_to_var(nvar,var) -!d time0=MPI_WTIME() - call minimize(etot,var,iretcode,nfun) - write(iout,*)'SUMSL return code is',iretcode,' eval SOFT',nfun - -!d time1=MPI_WTIME() -!d write (iout,'(a,f6.2,f8.2,a)')' Time for soft min.',time1-time0, -!d & nfun/(time1-time0),' SOFT eval/s' - call var_to_geom(nvar,var) - call chainbuild - - - iwsk=0 - nf=0 - if (iff(1).eq.1) then - iwsk=1 - nf=nf+1 - ij(nf)=0 - endif - do i=2,nres - if ( iwsk.eq.0.and.iff(i-1).eq.0.and.iff(i).eq.1 ) then - iwsk=1 - nf=nf+1 - ij(nf)=i - endif - if ( iwsk.eq.1.and.iff(i-1).eq.1.and.iff(i).eq.0 ) then - iwsk=0 - nf=nf+1 - ij(nf)=i-1 - endif - enddo - if (iff(nres).eq.1) then - nf=nf+1 - ij(nf)=nres - endif - - -!d write(linia,'(a6,i3,a1,i3,a1,i3,a1,i3)') -!d & "select",ij(1),"-",ij(2), -!d & ",",ij(3),"-",ij(4) -!d call write_pdb(in_pdb,linia,etot) - - - ipot=ipot0 - maxmin=maxmin0 - maxfun=maxfun0 -!d time0=MPI_WTIME() - call minimize(etot,var,iretcode,nfun) -!d write(iout,*)'SUMSL DIST return code is',iretcode,' eval ',nfun - ieval=nfun - -!d time1=MPI_WTIME() -!d write (iout,'(a,f6.2,f8.2,a)')' Time for DIST min.',time1-time0, -!d & nfun/(time1-time0),' eval/s' -!d call var_to_geom(nvar,var) -!d call chainbuild -!d call write_pdb(6,'dist structure',etot) - - - nhpb= nhpb0 - link_start=1 - link_end=nhpb - wstrain=wstrain0 - - return - end subroutine contact_cp2 -!----------------------------------------------------------------------------- - subroutine contact_cp(var,var2,iff,ieval,in_pdb) - - use geometry, only:dist -!el use minim -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.SBRIDGE' -! include 'COMMON.FFIELD' -! include 'COMMON.IOUNITS' -! include 'COMMON.DISTFIT' -! include 'COMMON.VAR' -! include 'COMMON.CHAIN' -! include 'COMMON.MINIM' - - character(len=50) :: linia - integer :: nf,ij(4) - real(kind=8) :: energy(0:n_ene) - real(kind=8),dimension(6*nres) :: var,var2 !(maxvar) (maxvar=6*maxres) - real(kind=8) :: time0,time1 - integer :: iff(nres),ieval - real(kind=8),dimension(nres) :: theta1,phi1,alph1,omeg1 !(maxres) - logical :: debug - -!el local variables - integer :: in_pdb,i,j,ind,iwsk - - debug=.false. -! debug=.true. - if (ieval.eq.-1) debug=.true. - - -! -! store selected dist. constrains from 1st structure -! -#ifdef OSF -! Intercept NaNs in the coordinates -! write(iout,*) (var(i),i=1,nvar) - x_sum=0.D0 - do i=1,nvar - x_sum=x_sum+var(i) - enddo - if (x_sum.ne.x_sum) then - write(iout,*)" *** contact_cp : Found NaN in coordinates" - call flush(iout) - print *," *** contact_cp : Found NaN in coordinates" - return - endif -#endif - - - call var_to_geom(nvar,var) - call chainbuild - nhpb0=nhpb - ind=0 - do i=1,nres-3 - do j=i+3,nres - ind=ind+1 - if ( iff(i).eq.1.and.iff(j).eq.1 ) then - d0(ind)=DIST(i,j) - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else - w(ind)=0.0 - endif - enddo - enddo - call hpb_partition - - do i=1,nres - theta1(i)=theta(i) - phi1(i)=phi(i) - alph1(i)=alph(i) - omeg1(i)=omeg(i) - enddo - -! -! freeze sec.elements from 2nd structure -! - do i=1,nres - mask_phi(i)=1 - mask_theta(i)=1 - mask_side(i)=1 - enddo - - call var_to_geom(nvar,var2) - call secondary2(debug) - do j=1,nbfrag - do i=bfrag(1,j),bfrag(2,j) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - enddo - if (bfrag(3,j).le.bfrag(4,j)) then - do i=bfrag(3,j),bfrag(4,j) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - enddo - else - do i=bfrag(4,j),bfrag(3,j) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - enddo - endif - enddo - do j=1,nhfrag - do i=hfrag(1,j),hfrag(2,j) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - enddo - enddo - mask_r=.true. - -! -! copy selected res from 1st to 2nd structure -! - - do i=1,nres - if ( iff(i).eq.1 ) then - theta(i)=theta1(i) - phi(i)=phi1(i) - alph(i)=alph1(i) - omeg(i)=omeg1(i) - endif - enddo - - if(debug) then -! -! prepare description in linia variable -! - iwsk=0 - nf=0 - if (iff(1).eq.1) then - iwsk=1 - nf=nf+1 - ij(nf)=1 - endif - do i=2,nres - if ( iwsk.eq.0.and.iff(i-1).eq.0.and.iff(i).eq.1 ) then - iwsk=1 - nf=nf+1 - ij(nf)=i - endif - if ( iwsk.eq.1.and.iff(i-1).eq.1.and.iff(i).eq.0 ) then - iwsk=0 - nf=nf+1 - ij(nf)=i-1 - endif - enddo - if (iff(nres).eq.1) then - nf=nf+1 - ij(nf)=nres - endif - - write(linia,'(a6,i3,a1,i3,a1,i3,a1,i3)') & - "SELECT",ij(1)-1,"-",ij(2)-1,& - ",",ij(3)-1,"-",ij(4)-1 - - endif -! -! run optimization -! - call contact_cp_min(var,ieval,in_pdb,linia,debug) - - return - end subroutine contact_cp -!----------------------------------------------------------------------------- - subroutine contact_cp_min(var,ieval,in_pdb,linia,debug) - -!el use minim -! -! input : theta,phi,alph,omeg,in_pdb,linia,debug -! output : var,ieval -! -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - include 'mpif.h' -! include 'COMMON.SBRIDGE' -! include 'COMMON.FFIELD' -! include 'COMMON.IOUNITS' -! include 'COMMON.DISTFIT' -! include 'COMMON.VAR' -! include 'COMMON.CHAIN' -! include 'COMMON.MINIM' - - character(len=50) :: linia - integer :: nf,ij(4) - real(kind=8) :: energy(0:n_ene) - real(kind=8),dimension(6*nres) :: var !(maxvar) (maxvar=6*maxres) - real(kind=8) :: time0,time1 - integer :: ieval,info(3) - logical :: debug,fail,reduce,change !check_var, - -!el local variables - integer :: in_pdb,i,ipot0,ipot01,maxmin0,maxfun0,maxmin01,maxfun01,& - iretcode,nfun - real(kind=8) :: wsc01,wscp01,welec01,wvdwpp01,wscloc01,wtor01,& - wtor_d01,wstrain0,etot - - write(iout,'(a20,i6,a20)') & - '------------------',in_pdb,'-------------------' -!el#ifdef MPI - if (debug) then - call chainbuild - call write_pdb(1000+in_pdb,'combined structure',0d0) -!el#ifdef MPI - time0=MPI_WTIME() -!el#endif - endif -!el#endif -! -! run optimization of distances -! -! uses d0(),w() and mask() for frozen 2D -! -!test--------------------------------------------- -!test NX=NRES-3 -!test NY=((NRES-4)*(NRES-5))/2 -!test call distfit(debug,5000) - - do i=1,nres - mask_side(i)=0 - enddo - - ipot01=ipot - maxmin01=maxmin - maxfun01=maxfun -! wstrain01=wstrain - wsc01=wsc - wscp01=wscp - welec01=welec - wvdwpp01=wvdwpp -! wang01=wang - wscloc01=wscloc - wtor01=wtor - wtor_d01=wtor_d - - ipot=6 - maxmin=2000 - maxfun=4000 -! wstrain=1.0 - wsc=0.0 - wscp=0.0 - welec=0.0 - wvdwpp=0.0 -! wang=0.0 - wscloc=0.0 - wtor=0.0 - wtor_d=0.0 - - call geom_to_var(nvar,var) -!de change=reduce(var) - if (check_var(var,info)) then - write(iout,*) 'cp_min error in input' - print *,'cp_min error in input' - return - endif - -!d call etotal(energy(0)) -!d call enerprint(energy(0)) -!d call check_eint -!el#ifdef MPI - time0=MPI_WTIME() -!dtest call minimize(etot,var,iretcode,nfun) -!dtest write(iout,*)'SUMSL return code is',iretcode,' eval SDIST',nfun - time1=MPI_WTIME() -!el#endif -!d call etotal(energy(0)) -!d call enerprint(energy(0)) -!d call check_eint - - do i=1,nres - mask_side(i)=1 - enddo - - ipot=ipot01 - maxmin=maxmin01 - maxfun=maxfun01 -! wstrain=wstrain01 - wsc=wsc01 - wscp=wscp01 - welec=welec01 - wvdwpp=wvdwpp01 -! wang=wang01 - wscloc=wscloc01 - wtor=wtor01 - wtor_d=wtor_d01 -!test-------------------------------------------------- - - if(debug) then -!el#ifdef MPI - time1=MPI_WTIME() -!el#endif - write (iout,'(a,f6.2,a)')' Time for distfit ',time1-time0,' sec' - call write_pdb(2000+in_pdb,'distfit structure',0d0) - endif - - ipot0=ipot - maxmin0=maxmin - maxfun0=maxfun - wstrain0=wstrain -! -! run soft pot. optimization -! with constrains: -! nhpb,ihpb(),jhpb(),forcon(),dhpb() and hpb_partition -! and frozen 2D: -! mask_phi(),mask_theta(),mask_side(),mask_r -! - ipot=6 - maxmin=2000 - maxfun=4000 -!el#ifdef MPI -!de change=reduce(var) -!de if (check_var(var,info)) write(iout,*) 'error before soft' -!el#ifdef MPI - time0=MPI_WTIME() -!el#endif - call minimize(etot,var,iretcode,nfun) - - write(iout,*)'SUMSL return code is',iretcode,' eval SOFT',nfun -!el#ifdef MPI - time1=MPI_WTIME() -!el#endif - write (iout,'(a,f6.2,f8.2,a)')' Time for soft min.',time1-time0,& - nfun/(time1-time0),' SOFT eval/s' - - if (debug) then - call var_to_geom(nvar,var) - call chainbuild - call write_pdb(3000+in_pdb,'soft structure',etot) - endif -!el#endif -! -! run full UNRES optimization with constrains and frozen 2D -! the same variables as soft pot. optimizatio -! - ipot=ipot0 - maxmin=maxmin0 - maxfun=maxfun0 -! -! check overlaps before calling full UNRES minim -! - call var_to_geom(nvar,var) - call chainbuild - call etotal(energy) -#ifdef OSF - write(iout,*) 'N7 ',energy(0) - if (energy(0).ne.energy(0)) then - write(iout,*) 'N7 error - gives NaN',energy(0) - endif -#endif - ieval=1 - if (energy(1).eq.1.0d20) then - write (iout,'(a,1pe14.5)')'#N7_OVERLAP evdw=1d20',energy(1) - call overlap_sc(fail) - if(.not.fail) then - call etotal(energy) - ieval=ieval+1 - write (iout,'(a,1pe14.5)')'#N7_OVERLAP evdw after',energy(1) - else - mask_r=.false. - nhpb= nhpb0 - link_start=1 - link_end=nhpb - wstrain=wstrain0 - return - endif - endif - call flush(iout) -! -!dte time0=MPI_WTIME() -!de change=reduce(var) -!de if (check_var(var,info)) then -!de write(iout,*) 'error before mask dist' -!de call var_to_geom(nvar,var) -!de call chainbuild -!de call write_pdb(10000+in_pdb,'before mask dist',etot) -!de endif -!dte call minimize(etot,var,iretcode,nfun) -!dte write(iout,*)'SUMSL MASK DIST return code is',iretcode, -!dte & ' eval ',nfun -!dte ieval=ieval+nfun -!dte -!dte time1=MPI_WTIME() -!dte write (iout,'(a,f6.2,f8.2,a)') -!dte & ' Time for mask dist min.',time1-time0, -!dte & nfun/(time1-time0),' eval/s' -!dte call flush(iout) -!el#ifdef MPI - if (debug) then - call var_to_geom(nvar,var) - call chainbuild - call write_pdb(4000+in_pdb,'mask dist',etot) - endif -! -! switch off freezing of 2D and -! run full UNRES optimization with constrains -! - mask_r=.false. -!el#ifdef MPI - time0=MPI_WTIME() -!el#endif -!de change=reduce(var) -!de if (check_var(var,info)) then -!de write(iout,*) 'error before dist' -!de call var_to_geom(nvar,var) -!de call chainbuild -!de call write_pdb(11000+in_pdb,'before dist',etot) -!de endif - - call minimize(etot,var,iretcode,nfun) - -!de change=reduce(var) -!de if (check_var(var,info)) then -!de write(iout,*) 'error after dist',ico -!de call var_to_geom(nvar,var) -!de call chainbuild -!de call write_pdb(12000+in_pdb+ico*1000,'after dist',etot) -!de endif - write(iout,*)'SUMSL DIST return code is',iretcode,' eval ',nfun - ieval=ieval+nfun - -!el#ifdef MPI - time1=MPI_WTIME() -!el#endif - write (iout,'(a,f6.2,f8.2,a)')' Time for dist min.',time1-time0,& - nfun/(time1-time0),' eval/s' - -!de call etotal(energy(0)) -!de write(iout,*) 'N7 after dist',energy(0) - call flush(iout) - - if (debug) then - call var_to_geom(nvar,var) - call chainbuild - call write_pdb(in_pdb,linia,etot) - endif -!el#endif -! -! reset constrains -! - nhpb= nhpb0 - link_start=1 - link_end=nhpb - wstrain=wstrain0 - - return - end subroutine contact_cp_min -!----------------------------------------------------------------------------- - subroutine softreg - - use geometry, only:dist -!el use minim -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - include 'mpif.h' -! 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' -! -! include 'COMMON.DISTFIT' - integer :: iff(nres) - real(kind=8) :: time0,time1 - real(kind=8) :: energy(0:n_ene),ee - real(kind=8),dimension(6*nres) :: var !(maxvar) (maxvar=6*maxres) -! - logical :: debug,ltest,fail - character(len=50) :: linia - integer :: ieval,i,j,in_pdb,ipot0,maxmin0,maxfun0,ico,nhpb_c,& - iretcode,nfun - real(kind=8) :: wstrain0,wang0,etot -! - linia='test' - debug=.true. - in_pdb=0 - -!------------------------ -! -! freeze sec.elements -! - 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 -! -! store dist. constrains -! - 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 -! -! run soft pot. optimization -! - ipot=6 - wang=3.0 - maxmin=2000 - maxfun=4000 - call geom_to_var(nvar,var) -!el#ifdef MPI - time0=MPI_WTIME() -!el#endif - call minimize(etot,var,iretcode,nfun) - - write(iout,*)'SUMSL return code is',iretcode,' eval SOFT',nfun -!el#ifdef MPI - time1=MPI_WTIME() -!el#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 -! -! run full UNRES optimization with constrains and frozen 2D -! the same variables as soft pot. optimizatio -! - ipot=ipot0 - wang=wang0 - maxmin=maxmin0 - maxfun=maxfun0 -!el#ifdef MPI - time0=MPI_WTIME() -!el#endif - call minimize(etot,var,iretcode,nfun) - write(iout,*)'SUMSL MASK DIST return code is',iretcode,& - ' eval ',nfun - ieval=nfun - -!el#ifdef MPI - time1=MPI_WTIME() -!el#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 -! -! switch off constrains and -! run full UNRES optimization with frozen 2D -! - -! -! reset constrains -! - nhpb_c=nhpb - nhpb=nhpb0 - link_start=1 - link_end=nhpb - wstrain=wstrain0 - -!el#ifdef MPI - time0=MPI_WTIME() -!el#endif - call minimize(etot,var,iretcode,nfun) - write(iout,*)'SUMSL MASK return code is',iretcode,' eval ',nfun - ieval=ieval+nfun - -!el#ifdef MPI - time1=MPI_WTIME() -!el#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. - - -! -! run full UNRES optimization with constrains and NO frozen 2D -! - - nhpb=nhpb_c - link_start=1 - link_end=nhpb - maxfun=maxfun0/5 - - do ico=1,5 - - wstrain=wstrain0/ico - -!el#ifdef MPI - time0=MPI_WTIME() -!el#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 - -!el#ifdef MPI - time1=MPI_WTIME() -!el#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 -! - nhpb=nhpb0 - link_start=1 - link_end=nhpb - wstrain=wstrain0 - maxfun=maxfun0 - - -! - if (minim) then -!el#ifdef MPI - time0=MPI_WTIME() -!el#endif - call minimize(etot,var,iretcode,nfun) - write(iout,*)'------------------------------------------------' - write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun,& - '+ DIST eval',ieval - -!el#ifdef MPI - time1=MPI_WTIME() -!el#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 -!el#endif - return - end subroutine softreg -!----------------------------------------------------------------------------- - subroutine beta_slide(i1,i2,i3,i4,i5,ieval,ij) - - use geometry, only:dist -!el use minim -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - include 'mpif.h' -! 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' - real(kind=8) :: time0,time1 - real(kind=8) :: energy(0:n_ene),ee - real(kind=8),dimension(6*nres) :: var !(maxvar) (maxvar=6*maxres) - integer :: jdata(5),isec(nres) -! -!el local variables - integer :: i1,i2,i3,i4,i5,ieval,ij - integer :: i,j,nft_sc,ishift,iretcode,nfun,maxfun0,ico - real(kind=8) :: etot,wscloc0,wstrain0 - - jdata(1)=i1 - jdata(2)=i2 - jdata(3)=i3 - jdata(4)=i4 - jdata(5)=i5 - - call secondary2(.false.) - - do i=1,nres - isec(i)=0 - enddo - do j=1,nbfrag - do i=bfrag(1,j),bfrag(2,j) - isec(i)=1 - enddo - do i=bfrag(4,j),bfrag(3,j),sign(1,bfrag(3,j)-bfrag(4,j)) - isec(i)=1 - enddo - enddo - do j=1,nhfrag - do i=hfrag(1,j),hfrag(2,j) - isec(i)=2 - enddo - enddo - -! -! cut strands at the ends -! - if (jdata(2)-jdata(1).gt.3) then - jdata(1)=jdata(1)+1 - jdata(2)=jdata(2)-1 - if (jdata(3).lt.jdata(4)) then - jdata(3)=jdata(3)+1 - jdata(4)=jdata(4)-1 - else - jdata(3)=jdata(3)-1 - jdata(4)=jdata(4)+1 - endif - endif - -!v call chainbuild -!v call etotal(energy(0)) -!v etot=energy(0) -!v write(iout,*) nnt,nct,etot -!v call write_pdb(ij*100,'first structure',etot) -!v write(iout,*) 'N16 test',(jdata(i),i=1,5) - -!------------------------ -! generate constrains -! - ishift=jdata(5)-2 - if(ishift.eq.0) ishift=-2 - nhpb0=nhpb - call chainbuild - do i=jdata(1),jdata(2) - isec(i)=-1 - if(jdata(4).gt.jdata(3))then - do j=jdata(3)+i-jdata(1)-2,jdata(3)+i-jdata(1)+2 - isec(j)=-1 -!d print *,i,j,j+ishift - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=1000.0 - dhpb(nhpb)=DIST(i,j+ishift) - enddo - else - do j=jdata(3)-i+jdata(1)+2,jdata(3)-i+jdata(1)-2,-1 - isec(j)=-1 -!d print *,i,j,j+ishift - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=1000.0 - dhpb(nhpb)=DIST(i,j+ishift) - enddo - endif - enddo - - do i=nnt,nct-2 - do j=i+2,nct - if(isec(i).gt.0.or.isec(j).gt.0) then -!d print *,i,j - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=0.1 - dhpb(nhpb)=DIST(i,j) - endif - enddo - enddo - - call hpb_partition - - call geom_to_var(nvar,var) - maxfun0=maxfun - wstrain0=wstrain - maxfun=4000/5 - - do ico=1,5 - - wstrain=wstrain0/ico - -!v time0=MPI_WTIME() - call minimize(etot,var,iretcode,nfun) - write(iout,'(a10,f6.3,a14,i3,a6,i5)') & - ' SUMSL DIST',wstrain,' return code is',iretcode,& - ' eval ',nfun - ieval=ieval+nfun -!v time1=MPI_WTIME() -!v write (iout,'(a,f6.2,f8.2,a)') -!v & ' Time for dist min.',time1-time0, -!v & nfun/(time1-time0),' eval/s' -!v call var_to_geom(nvar,var) -!v call chainbuild -!v call write_pdb(ij*100+ico,'dist cons',etot) - - enddo -! - nhpb=nhpb0 - call hpb_partition - wstrain=wstrain0 - maxfun=maxfun0 -! -!d print *,etot - wscloc0=wscloc - wscloc=10.0 - call sc_move(nnt,nct,100,100d0,nft_sc,etot) - wscloc=wscloc0 -!v call chainbuild -!v call etotal(energy(0)) -!v etot=energy(0) -!v call write_pdb(ij*100+10,'sc_move',etot) -!d call intout -!d print *,nft_sc,etot - - return - end subroutine beta_slide -!----------------------------------------------------------------------------- - subroutine beta_zip(i1,i2,ieval,ij) - -!el use minim -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - include 'mpif.h' -! 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' - real(kind=8) :: time0,time1 - real(kind=8) :: energy(0:n_ene),ee - real(kind=8),dimension(6*nres) :: var !(maxvar) (maxvar=6*maxres) - character(len=10) :: test -!el local variables - integer :: i1,i2,ieval,ij,ico,iretcode,nfun,maxfun0 - real(kind=8) :: etot,wstrain0 -!v call chainbuild -!v call etotal(energy(0)) -!v etot=energy(0) -!v write(test,'(2i5)') i1,i2 -!v call write_pdb(ij*100,test,etot) -!v write(iout,*) 'N17 test',i1,i2,etot,ij - -! -! generate constrains -! - nhpb0=nhpb - nhpb=nhpb+1 - ihpb(nhpb)=i1 - jhpb(nhpb)=i2 - forcon(nhpb)=1000.0 - dhpb(nhpb)=4.0 - - call hpb_partition - - call geom_to_var(nvar,var) - maxfun0=maxfun - wstrain0=wstrain - maxfun=1000/5 - - do ico=1,5 - wstrain=wstrain0/ico -!v time0=MPI_WTIME() - call minimize(etot,var,iretcode,nfun) - write(iout,'(a10,f6.3,a14,i3,a6,i5)') & - ' SUMSL DIST',wstrain,' return code is',iretcode,& - ' eval ',nfun - ieval=ieval+nfun -!v time1=MPI_WTIME() -!v write (iout,'(a,f6.2,f8.2,a)') -!v & ' Time for dist min.',time1-time0, -!v & nfun/(time1-time0),' eval/s' -! do not comment the next line - call var_to_geom(nvar,var) -!v call chainbuild -!v call write_pdb(ij*100+ico,'dist cons',etot) - enddo - - nhpb=nhpb0 - call hpb_partition - wstrain=wstrain0 - maxfun=maxfun0 - -!v call etotal(energy(0)) -!v etot=energy(0) -!v write(iout,*) 'N17 test end',i1,i2,etot,ij - - return - end subroutine beta_zip -!----------------------------------------------------------------------------- -! thread.F -!----------------------------------------------------------------------------- - subroutine thread_seq - - use geometry, only:dist - use random, only:iran_num - use control, only:tcpu - use regularize_, only:regularize - use mcm_data, only: nsave_part,nacc_tot -! Thread the sequence through a database of known structures -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - use MPI_data !include 'COMMON.INFO' - use MPI_ -#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 - integer :: ThreadId,ThreadType,Kwita -#endif - real(kind=8),dimension(6*nres) :: varia !(maxvar) (maxvar=6*maxres) - real(kind=8) :: przes(3),obr(3,3) - real(kind=8) :: time_for_thread - logical :: found_pattern,non_conv - character(len=32) :: head_pdb - real(kind=8) :: energia(0:n_ene) - integer :: i,j,ithread,itrial,ii,jj,nres_t,ist,ipattern,iretcode,& - link_end0,iproc - real(kind=8) :: dcj,rms,frac,frac_nn,co,etot,curr_tim,curr_tim1 - - n_ene_comp=nprint_ene -! -! Body -! -#ifdef MPI - if (me.eq.king) then - do i=1,nctasks - nsave_part(i)=0 - enddo - endif - nacc_tot=0 - - Kwita=0 -#endif - 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 -!d 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 -! Find long enough chain in the database - ii=iran_num(1,nseq) - nres_t=nres_base(1,ii) -! 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 -! If this point is reached, the pattern has not yet been examined. - 10 continue -! 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 -! 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) -! cref(j,i)=c(j,i) - enddo -!d write (iout,'(a,i4,3f10.5)') restyp(itype(i)),i,(c(j,i),j=1,3) - enddo -!d call fitsq(rms,c(1,nnt),cref(1,nnt),nct-nnt+1,przes,obr, -!d non_conv) -!d write (iout,'(a,f10.5)') -!d & 'Initial RMS deviation from reference structure:',rms - if (itype(nres).eq.ntyp1) 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.ntyp1) 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.) -!d print *,'Exit INT_FROM_CART.' -!d print *,'nhpb=',nhpb - do i=nss+1,nhpb - ii=ihpb(i) - jj=jhpb(i) - dhpb(i)=dist(ii,jj) -! write (iout,'(2i5,2f10.5)') ihpb(i),jhpb(i),dhpb(i),forcon(i) - enddo -! stop 'End generate' -! Generate SC conformations. - call sc_conf -! call intout -#ifdef MPI -!d print *,'Processor:',me,': exit GEN_SIDE.' -#else -!d print *,'Exit GEN_SIDE.' -#endif -! Calculate initial energy. - call chainbuild - call etotal(energia) - 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 -! 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) -! 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) -! call enerprint(energia(0)) - link_end=link_end0 -!d call chainbuild -!d call fitsq(rms,c(1,nnt),cref(1,nnt),nct-nnt+1,przes,obr,non_conv) -!d write (iout,'(a,f10.5)') -!d & '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) -! write (istat,'(i4,2x,a8,i4,11(1pe14.5),2(0pf8.3),f8.5)') -! & ithread,str_nam(ipattern),ist+1,(ener(k,ithread),k=1,11), -! & (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 -! 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 subroutine thread_seq -!----------------------------------------------------------------------------- - subroutine sc_conf - -! Sample (hopefully) optimal SC orientations given backcone conformation. -!el use comm_srutu - use random, only:iran_num -! 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' - real(kind=8),dimension(6*nres) :: varia !(maxvar) (maxvar=6*maxres) -!el integer :: icall -!el common /srutu/ icall - real(kind=8) :: energia(0:n_ene) - logical :: glycine,fail - integer :: i,maxsample,link_end0,ind_sc,isample - real(kind=8) :: alph0,omeg0,e1,e0 - - maxsample=10 - link_end0=link_end - link_end=min0(link_end,nss) - do i=nnt,nct - if (itype(i).ne.10) then -!d 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) - e0 = energia(0) - do isample=1,maxsample -! 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) -!d write (iout,'(a,i5,a,i4,2(a,f8.3),2(a,1pe14.5))') -!d & 'Step:',isample,' SC',ind_sc,' alpha',alph(ind_sc)*rad2deg, -!d & ' omega',omeg(ind_sc)*rad2deg,' old energy',e0,' new energy',e1 - e1=energia(0) - if (e0.le.e1) then - alph(ind_sc)=alph0 - omeg(ind_sc)=omeg0 - else - e0=e1 - endif - enddo - link_end=link_end0 - return - end subroutine sc_conf -!----------------------------------------------------------------------------- -! minim_jlee.F -!----------------------------------------------------------------------------- - logical function check_var(var,info) - - use MPI_data - use geometry_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.VAR' -! include 'COMMON.IOUNITS' -! include 'COMMON.GEO' -! include 'COMMON.SETUP' - real(kind=8),dimension(6*nres) :: var !(maxvar) (maxvar=6*maxres) - integer,dimension(3) :: info - integer :: i,j -! AL ------- - check_var=.false. - do i=nphi+ntheta+1,nphi+ntheta+nside -! Check the side chain "valence" angles alpha - if (var(i).lt.1.0d-7) then - write (iout,*) 'CHUJ NASTAPIL ABSOLUTNY!!!!!!!!!!!!' - write (iout,*) 'Processor',me,'received bad variables!!!!' - write (iout,*) 'Variables' - write (iout,'(8f10.4)') (rad2deg*var(j),j=1,nvar) - write (iout,*) 'Continuing calculations at this point',& - ' could destroy the results obtained so far... ABORTING!!!!!!' - write (iout,'(a19,i5,f10.4,a4,2i4,a3,i3)') & - 'valence angle alpha',i-nphi-ntheta,var(i),& - 'n it',info(1),info(2),'mv ',info(3) - write (*,*) 'CHUJ NASTAPIL ABSOLUTNY!!!!!!!!!!!!' - write (*,*) 'Processor',me,'received bad variables!!!!' - write (*,*) 'Variables' - write (*,'(8f10.4)') (rad2deg*var(j),j=1,nvar) - write (*,*) 'Continuing calculations at this point',& - ' could destroy the results obtained so far... ABORTING!!!!!!' - write (*,'(a19,i5,f10.4,a4,2i4,a3,i3)') & - 'valence angle alpha',i-nphi-ntheta,var(i),& - 'n it',info(1),info(2),'mv ',info(3) - check_var=.true. - return - endif - enddo -! Check the backbone "valence" angles theta - do i=nphi+1,nphi+ntheta - if (var(i).lt.1.0d-7) then - write (iout,*) 'CHUJ NASTAPIL ABSOLUTNY!!!!!!!!!!!!' - write (iout,*) 'Processor',me,'received bad variables!!!!' - write (iout,*) 'Variables' - write (iout,'(8f10.4)') (rad2deg*var(j),j=1,nvar) - write (iout,*) 'Continuing calculations at this point',& - ' could destroy the results obtained so far... ABORTING!!!!!!' - write (iout,'(a19,i5,f10.4,a4,2i4,a3,i3)') & - 'valence angle theta',i-nphi,var(i),& - 'n it',info(1),info(2),'mv ',info(3) - write (*,*) 'CHUJ NASTAPIL ABSOLUTNY!!!!!!!!!!!!' - write (*,*) 'Processor',me,'received bad variables!!!!' - write (*,*) 'Variables' - write (*,'(8f10.4)') (rad2deg*var(j),j=1,nvar) - write (*,*) 'Continuing calculations at this point',& - ' could destroy the results obtained so far... ABORTING!!!!!!' - write (*,'(a19,i5,f10.4,a4,2i4,a3,i3)') & - 'valence angle theta',i-nphi,var(i),& - 'n it',info(1),info(2),'mv ',info(3) - check_var=.true. - return - endif - enddo - return - end function check_var -!----------------------------------------------------------------------------- -! distfit.f -!----------------------------------------------------------------------------- - subroutine distfit(debug,maxit) - - use geometry_data, only: phi - use compare_data - use md_calc -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CHAIN' -! include 'COMMON.VAR' -! include 'COMMON.IOUNITS' -! include 'COMMON.DISTFIT' - integer :: i,maxit,MAXMAR,IT,IMAR - real(kind=8),DIMENSION(nres) :: X,DIAGH,phiold !(maxres) - logical :: debug,sing - real(kind=8) :: TOL,RL,F0,AIN,F1 - -!input------------------------------------ -! NX=NRES-3 -! NY=((NRES-4)*(NRES-5))/2 -!input------------------------------------ -!test MAXIT=20 - TOL=0.5 - MAXMAR=10 - RL=100.0 - - CALL TRANSFER(NRES,phi,phiold) - - F0=RDIF() - -!d WRITE (IOUT,*) 'DISTFIT: F0=',F0 - - - DO IT=1,MAXIT - CALL RDERIV - CALL HEVAL - - DO I=1,NX - DIAGH(I)=H(I,I) - ENDDO - RL=RL*0.1 - - DO IMAR=1,MAXMAR - DO I=1,NX - H(I,I)=DIAGH(I)+RL - ENDDO - CALL TRANSFER(NX,XX,X) - CALL BANACH(NX,NRES,H,X,sing) - AIN=0.0 - DO I=1,NX - AIN=AIN+DABS(X(I)) - ENDDO - IF (AIN.LT.0.1*TOL .AND. RL.LT.1.0E-4) THEN - if (debug) then - WRITE (IOUT,*) 'DISTFIT: CONVERGENCE HAS BEEN ACHIEVED' - WRITE (IOUT,*) 'IT=',it,'F=',F0 - endif - RETURN - ENDIF - DO I=4,NRES - phi(I)=phiold(I)+mask(i)*X(I-3) -! print *,X(I-3) - ENDDO - - F1=RDIF() -!d WRITE (IOUT,*) 'IMAR=',IMAR,' RL=',RL,' F1=',F1 - IF (F1.LT.F0) THEN - CALL TRANSFER(NRES,phi,phiold) - F0=F1 - GOTO 1 - ELSE IF (DABS(F1-F0).LT.1.0E-5) THEN - if (debug) then - WRITE (IOUT,*) 'DISTFIT: CANNOT IMPROVE DISTANCE FIT' - WRITE (IOUT,*) 'IT=',it,'F=',F1 - endif - RETURN - ENDIF - RL=RL*10.0 - ENDDO - WRITE (IOUT,*) 'DISTFIT: MARQUARDT PROCEDURE HAS FAILED' - WRITE (IOUT,*) 'IT=',it,'F=',F0 - CALL TRANSFER(NRES,phiold,phi) - RETURN - 1 continue -!d write (iout,*) "it",it," imar",imar," f0",f0 - enddo - WRITE (IOUT,*) 'DISTFIT: FINAL F=',F0,'after MAXIT=',maxit - return - end subroutine distfit -!----------------------------------------------------------------------------- - real(kind=8) function RDIF() - - use compare_data - use geometry, only: dist -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CHAIN' -! include 'COMMON.DISTFIT' - integer :: i,j,ind - real(kind=8) :: suma,DIJ -! print *,'in rdif' - - suma=0.0 - ind=0 - call chainbuild - do i=1,nres-3 - do j=i+3,nres - ind=ind+1 - if (w(ind).ne.0.0) then - DIJ=DIST(i,j) - suma=suma+w(ind)*(DIJ-d0(ind))*(DIJ-d0(ind)) - DDD(ind)=DIJ -! print '(2i3,i4,4f12.2)',i,j,ind,dij,d0(ind),w(ind),suma - endif - enddo - enddo - - RDIF=suma - return - end function RDIF -!----------------------------------------------------------------------------- - subroutine RDERIV - - use compare_data - use geometry_data - use geometry, only:dist -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CHAIN' -! include 'COMMON.DISTFIT' -! include 'COMMON.GEO' - integer :: i,j,k,l,I1,I2,IND - real(kind=8),DIMENSION(3) :: E12,R13,R24,PRODU - - DO I=1,NY - DO J=1,NX - DRDG(I,J)=0.0 - ENDDO - ENDDO - DO I=1,NX - I1=I+1 - I2=I+2 - CALL VEC(I1,I2,E12) - DO J=1,I - DO K=1,3 - R13(K)=C(K,J)-C(K,I1) - ENDDO - DO K=I2+1,NRES - DO L=1,3 - R24(L)=C(L,K)-C(L,I2) - ENDDO - IND=((J-1)*(2*NRES-J-6))/2+K-3 - PRODU(1)=R13(2)*R24(3)-R13(3)*R24(2) - PRODU(2)=R13(3)*R24(1)-R13(1)*R24(3) - PRODU(3)=R13(1)*R24(2)-R13(2)*R24(1) - DRDG(IND,I)=SCALAR(E12,PRODU)/DIST(J,K) - ENDDO - ENDDO - ENDDO - return - end subroutine RDERIV -!----------------------------------------------------------------------------- - subroutine HEVAL - - use compare_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CHAIN' -! include 'COMMON.DISTFIT' - integer :: i,k,j - real(kind=8) :: XI,HII,BKI,BKIWK,HIJ - - DO I=1,NX - XI=0.0 - HII=0.0 - DO K=1,NY - BKI=DRDG(K,I) - BKIWK=w(K)*BKI - XI=XI+BKIWK*(D0(K)-DDD(K)) - HII=HII+BKI*BKIWK - ENDDO - H(I,I)=HII - XX(I)=XI - DO J=I+1,NX - HIJ=0.0 - DO K=1,NY - HIJ=HIJ+DRDG(K,I)*DRDG(K,J)*w(K) - ENDDO - H(I,J)=HIJ - H(J,I)=HIJ - ENDDO - ENDDO - return - end subroutine HEVAL -!----------------------------------------------------------------------------- - subroutine VEC(I,J,U) -! - use geometry_data, only: C -! Find the unit vector from atom (I) to atom (J). Store in U. -! -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.CHAIN' - integer :: I,J,K - real(kind=8),DIMENSION(3) :: U - real(kind=8) :: ANORM,UK - - ANORM=0.0 - DO K=1,3 - UK=C(K,J)-C(K,I) - ANORM=ANORM+UK*UK - U(K)=UK - ENDDO - ANORM=SQRT(ANORM) - DO K=1,3 - U(K)=U(K)/ANORM - ENDDO - return - end subroutine VEC -!----------------------------------------------------------------------------- - subroutine TRANSFER(N,X1,X2) - -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' - integer :: N,I - real(kind=8),DIMENSION(N) :: X1,X2 - DO 1 I=1,N - 1 X2(I)=X1(I) - return - end subroutine TRANSFER -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - subroutine alloc_compare_arrays - - maxres22=nres*(nres+1)/2 -! common.dbase -! common /struct/ in io_common: read_threadbase -! allocate(cart_base !(3,maxres_base,maxseq) -! allocate(nres_base !(3,maxseq) -! allocate(str_nam !(maxseq) -! common.distfit -! COMMON /c_frag/ in io_conf: readpdb - if(.not.allocated(bfrag)) allocate(bfrag(4,nres/3)) !(4,maxres/3) - if(.not.allocated(hfrag)) allocate(hfrag(2,nres/3)) !(2,maxres/3) -! COMMON /WAGI/ - allocate(w(maxres22),d0(maxres22)) !(maxres22) -! COMMON /POCHODNE/ -!el allocate(DRDG(maxres22,maxres22)) !(MAXRES22,MAXRES) - allocate(DDD(maxres22)) !(maxres22) - allocate(H(nres,nres)) !(MAXRES,MAXRES) - allocate(XX(nres)) !(MAXRES) -! COMMON /frozen/ - allocate(mask(nres)) !(maxres) -! common.thread -! common /thread/ - allocate(iexam(2,maxthread),ipatt(2,maxthread)) !(2,maxthread) -! common /thread1/ - allocate(ener0(n_ene+2,maxthread),ener(n_ene+2,maxthread)) !(n_ene+2,maxthread) - - return - end subroutine alloc_compare_arrays -!----------------------------------------------------------------------------- -#endif -!----------------------------------------------------------------------------- - end module compare diff --git a/source/unres/control.F90 b/source/unres/control.F90 new file mode 100644 index 0000000..8d22bf0 --- /dev/null +++ b/source/unres/control.F90 @@ -0,0 +1,2160 @@ + module control +!----------------------------------------------------------------------------- + use io_units + use names + use MPI_data + use geometry_data + use energy_data + use control_data + use minim_data + use geometry, only:int_bounds +#ifndef CLUSTER + use csa_data +#ifdef WHAM_RUN + use wham_data +#endif +#endif + implicit none +!----------------------------------------------------------------------------- +! commom.control +! common /cntrl/ +! integer :: modecalc,iscode,indpdb,indback,indphi,iranconf,& +! icheckgrad,iprint,i2ndstr,mucadyn,constr_dist,symetr +! 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 +!... minim = .true. means DO minimization. +!... energy_dec = .true. means print energy decomposition matrix +!----------------------------------------------------------------------------- +! common.time1 +! FOUND_NAN - set by calcf to stop sumsl via stopx +! COMMON/TIME1/ + real(kind=8) :: STIME,BATIME,PREVTIM,RSTIME +!el real(kind=8) :: TIMLIM,SAFETY +!el real(kind=8) :: WALLTIME +! COMMON/STOPTIM/ + integer :: ISTOP +! common /sumsl_flag/ + logical :: FOUND_NAN +! common /timing/ + real(kind=8) :: t_init +! time_bcast,time_reduce,time_gather,& +! time_sendrecv,time_barrier_e,time_barrier_g,time_scatter,& + !t_eelecij, +! time_allreduce,& +! time_lagrangian,time_cartgrad,& +! time_sumgradient,time_intcartderiv,time_inttocart,time_intfcart,& +! time_mat,time_fricmatmult,& +! time_scatter_fmat,time_scatter_ginv,& +! time_scatter_fmatmult,time_scatter_ginvmult,& +! t_eshort,t_elong,t_etotal +!----------------------------------------------------------------------------- +! initialize_p.F +!----------------------------------------------------------------------------- +! block data +! integer,parameter :: MaxMoveType = 4 +! character(len=14),dimension(-1:MaxMoveType+1) :: MovTypID=(/'pool','chain regrow',& +! character :: MovTypID(-1:MaxMoveType+1)=(/'pool','chain regrow',& +! 'multi-bond','phi','theta','side chain','total'/) +! Conversion from poises to molecular unit and the gas constant +!el real(kind=8) :: cPoise=2.9361d0, Rb=0.001986d0 +!----------------------------------------------------------------------------- +! common /przechowalnia/ subroutines: init_int_table,add_int,add_int_from + integer,dimension(:),allocatable :: iturn3_start_all,& + iturn3_end_all,iturn4_start_all,iturn4_end_all,iatel_s_all,& + iatel_e_all !(0:max_fg_procs) + integer,dimension(:,:),allocatable :: ielstart_all,& + ielend_all !(maxres,0:max_fg_procs-1) + +! common /przechowalnia/ subroutine: init_int_table + integer,dimension(:),allocatable :: ntask_cont_from_all,& + ntask_cont_to_all !(0:max_fg_procs-1) + integer,dimension(:,:),allocatable :: itask_cont_from_all,& + itask_cont_to_all !(0:max_fg_procs-1,0:max_fg_procs-1) +!----------------------------------------------------------------------------- +! +! +!----------------------------------------------------------------------------- + contains +!----------------------------------------------------------------------------- +! initialize_p.F +!----------------------------------------------------------------------------- + subroutine initialize +! +! Define constants and zero out tables. +! + use comm_iofile + use comm_machsw + use MCM_data, only: MovTypID +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif +#ifndef ISNAN + external proc_proc +#ifdef WINPGI +!MS$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' +! implicit none +! Common blocks from the diagonalization routines +!el integer :: IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(400) +!el integer :: KDIAG,ICORFL,IXDR +!el COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA +!el COMMON /MACHSW/ KDIAG,ICORFL,IXDR + logical :: mask_r +! real*8 text1 /'initial_i'/ + real(kind=4) :: rr + +!local variables el + integer :: i,j,k,l,ichir1,ichir2,iblock,m,maxit + +#if .not. defined(WHAM_RUN) && .not. defined(CLUSTER) + mask_r=.false. +#ifndef ISNAN +! NaNQ initialization + i=-1 + rr=dacos(100.0d0) +#ifdef WINPGI + idumm=proc_proc(rr,i) +#elif defined(WHAM_RUN) + call proc_proc(rr,i) +#endif +#endif + + kdiag=0 + icorfl=0 + iw=2 + + allocate(MovTypID(-1:MaxMoveType+1)) + MovTypID=(/'pool ','chain regrow ',& + 'multi-bond ','phi ','theta ',& + 'side chain ','total '/) +#endif +! +! The following is just to define auxiliary variables used in angle conversion +! + 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 +!el#ifdef CLUSTER +!el Rgas = 1.987D-3 +!el#endif +! +! Define I/O units. +! + inp= 1 + iout= 2 + ipdbin= 3 + ipdb= 7 +#ifdef CLUSTER + imol2= 18 + jplot= 19 +!el jstatin=10 + imol2= 4 + jrms=30 +#else + icart = 30 + imol2= 4 + ithep_pdb=51 + irotam_pdb=52 + irest1=55 + irest2=56 + iifrag=57 + ientin=18 + ientout=19 +!rc for write_rmsbank1 + izs1=21 +!dr include secondary structure prediction bias + isecpred=27 +#endif + igeom= 8 + intin= 9 + ithep= 11 + irotam=12 + itorp= 13 + itordp= 23 + ielep= 14 + isidep=15 +#if defined(WHAM_RUN) || defined(CLUSTER) + isidep1=22 !wham +#else +! +! CSA I/O units (separated from others especially for Jooyoung) +! + 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 +!rc for ifc error 118 + icsa_pdb=42 +#endif + iscpp=25 + icbase=16 + ifourier=20 + istat= 17 + ibond = 28 + isccor = 29 +#ifdef WHAM_RUN +! +! WHAM files +! + ihist=30 + iweight=31 + izsc=32 +#endif +#if defined(WHAM_RUN) || defined(CLUSTER) +! +! setting the mpi variables for WHAM +! + fgprocs=1 + nfgtasks=1 + nfgtasks1=1 +#endif +! +! Set default weights of the energy terms. +! + wsc=1.0D0 ! in wham: wlong=1.0D0 + welec=1.0D0 + wtor =1.0D0 + wang =1.0D0 + wscloc=1.0D0 + wstrain=1.0D0 +! +! Zero out tables. +! +! print '(a,$)','Inside initialize' +! 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 +! do ichir1=-1,1 +! do ichir2=-1,1 +! athet(j,i,ichir1,ichir2)=0.0D0 +! bthet(j,i,ichir1,ichir2)=0.0D0 +! enddo +! enddo +! enddo +! do j=0,3 +! polthet(j,i)=0.0D0 +! enddo +! do j=1,3 +! gthet(j,i)=0.0D0 +! enddo +! theta0(i)=0.0D0 +! sig0(i)=0.0D0 +! sigc0(i)=0.0D0 +! do j=1,maxlob +! bsc(j,i)=0.0D0 +! do k=1,3 +! censc(k,j,i)=0.0D0 +! enddo +! do k=1,3 +! do l=1,3 +! gaussc(l,k,j,i)=0.0D0 +! enddo +! enddo +! nlob(i)=0 +! enddo +! enddo +! nlob(ntyp1)=0 +! dsc(ntyp1)=0.0D0 +! do i=-maxtor,maxtor +! itortyp(i)=0 +!c write (iout,*) "TU DOCHODZE",i,itortyp(i) +! do iblock=1,2 +! do j=-maxtor,maxtor +! do k=1,maxterm +! v1(k,j,i,iblock)=0.0D0 +! v2(k,j,i,iblock)=0.0D0 +! enddo +! enddo +! enddo +! enddo +! do iblock=1,2 +! do i=-maxtor,maxtor +! do j=-maxtor,maxtor +! do k=-maxtor,maxtor +! do l=1,maxtermd_1 +! v1c(1,l,i,j,k,iblock)=0.0D0 +! v1s(1,l,i,j,k,iblock)=0.0D0 +! v1c(2,l,i,j,k,iblock)=0.0D0 +! v1s(2,l,i,j,k,iblock)=0.0D0 +! enddo !l +! do l=1,maxtermd_2 +! do m=1,maxtermd_2 +! v2c(m,l,i,j,k,iblock)=0.0D0 +! v2s(m,l,i,j,k,iblock)=0.0D0 +! enddo !m +! enddo !l +! enddo !k +! enddo !j +! enddo !i +! enddo !iblock + +! do i=1,maxres +! itype(i)=0 +! itel(i)=0 +! enddo +! 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 +! +! Initialize timing. +! + call set_timers +! +! Initialize variables used in minimization. +! +!c maxfun=5000 +!c maxit=2000 + maxfun=500 + maxit=200 + tolf=1.0D-2 + rtolf=5.0D-4 +! +! Initialize the variables responsible for the mode of gradient storage. +! + nfl=0 + icg=1 + +#ifdef WHAM_RUN + allocate(iww(max_eneW)) + do i=1,14 + do j=1,14 + if (print_order(i).eq.j) then + iww(print_order(i))=j + goto 1121 + endif + enddo +1121 continue + enddo +#endif + +#if defined(WHAM_RUN) || defined(CLUSTER) + ndih_constr=0 + +! allocate(ww0(max_eneW)) +! ww0 = reshape((/1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,& +! 1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,0.4d0,1.0d0,& +! 1.0d0,0.0d0,0.0/), shape(ww0)) +! + calc_grad=.false. +! Set timers and counters for the respective routines + t_func = 0.0d0 + t_grad = 0.0d0 + t_fhel = 0.0d0 + t_fbet = 0.0d0 + t_ghel = 0.0d0 + t_gbet = 0.0d0 + t_viol = 0.0d0 + t_gviol = 0.0d0 + n_func = 0 + n_grad = 0 + n_fhel = 0 + n_fbet = 0 + n_ghel = 0 + n_gbet = 0 + n_viol = 0 + n_gviol = 0 + n_map = 0 +#endif +! +! Initialize constants used to split the energy into long- and short-range +! components +! + r_cut=2.0d0 + rlamb=0.3d0 +#ifndef SPLITELE + nprint_ene=nprint_ene-1 +#endif + return + end subroutine initialize +!----------------------------------------------------------------------------- + subroutine init_int_table + + use geometry, only:int_bounds1 +!el use MPI_data +!el implicit none +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' + integer,dimension(15) :: blocklengths,displs +#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' +!el integer,dimension(0:nfgtasks) :: iturn3_start_all,iturn3_end_all,& +!el iturn4_start_all,iturn4_end_all,iatel_s_all,iatel_e_all !(0:max_fg_procs) +!el integer,dimension(nres,0:nfgtasks) :: ielstart_all,& +!el ielend_all !(maxres,0:max_fg_procs-1) +!el integer,dimension(0:nfgtasks-1) :: ntask_cont_from_all,& +!el ntask_cont_to_all !(0:max_fg_procs-1), +!el integer,dimension(0:nfgtasks-1,0:nfgtasks-1) :: itask_cont_from_all,& +!el itask_cont_to_all !(0:max_fg_procs-1,0:max_fg_procs-1) + +!el common /przechowalnia/ iturn3_start_all,iturn3_end_all,& +!el iturn4_start_all,iturn4_end_all,iatel_s_all,iatel_e_all,& +!el ielstart_all,ielend_all,ntask_cont_from_all,itask_cont_from_all,& +!el ntask_cont_to_all,itask_cont_to_all + + integer :: FG_GROUP,CONT_FROM_GROUP,CONT_TO_GROUP + logical :: scheck,lprint,flag + +!el local variables + integer :: ind_scint=0,ind_scint_old,ii,jj,i,j,iint + +#ifdef MPI + integer :: my_sc_int(0:nfgtasks-1),my_ele_int(0:nfgtasks-1) + integer :: my_sc_intt(0:nfgtasks),my_ele_intt(0:nfgtasks) + integer :: n_sc_int_tot,my_sc_inde,my_sc_inds,ind_sctint,npept + integer :: nele_int_tot,my_ele_inds,my_ele_inde,ind_eleint_old,& + ind_eleint,ijunk,nele_int_tot_vdw,my_ele_inds_vdw,& + my_ele_inde_vdw,ind_eleint_vdw,ind_eleint_vdw_old,& + nscp_int_tot,my_scp_inds,my_scp_inde,ind_scpint,& + ind_scpint_old,nsumgrad,nlen,ngrad_start,ngrad_end,& + ierror,k,ierr,iaux,ncheck_to,ncheck_from,ind_typ,& + ichunk,int_index_old + +!el allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1) +!el allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1) + +!... Determine the numbers of start and end SC-SC interaction +!... to deal with by current processor. +!write (iout,*) '******INIT_INT_TABLE nres=',nres,' nnt=',nnt,' nct=',nct + do i=0,nfgtasks-1 + itask_cont_from(i)=fg_rank + itask_cont_to(i)=fg_rank + enddo + lprint=energy_dec +! lprint=.true. + 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) +!write (iout,*) 'INIT_INT_TABLE nres=',nres,' nnt=',nnt,' nct=',nct + 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 +!el common /przechowalnia/ + allocate(iturn3_start_all(0:nfgtasks)) + allocate(iturn3_end_all(0:nfgtasks)) + allocate(iturn4_start_all(0:nfgtasks)) + allocate(iturn4_end_all(0:nfgtasks)) + allocate(iatel_s_all(0:nfgtasks)) + allocate(iatel_e_all(0:nfgtasks)) + allocate(ielstart_all(nres,0:nfgtasks-1)) + allocate(ielend_all(nres,0:nfgtasks-1)) + + allocate(ntask_cont_from_all(0:nfgtasks-1)) + allocate(ntask_cont_to_all(0:nfgtasks-1)) + allocate(itask_cont_from_all(0:nfgtasks-1,0:nfgtasks-1)) + allocate(itask_cont_to_all(0:nfgtasks-1,0:nfgtasks-1)) +!el---------- +! lprint=.false. + do i=1,nres !el !maxres + nint_gr(i)=0 + nscp_gr(i)=0 + ielstart(i)=0 + ielend(i)=0 + do j=1,maxint_gr + istart(i,j)=0 + iend(i,j)=0 + iscpstart(i,j)=0 + iscpend(i,j)=0 + enddo + enddo + ind_scint=0 + ind_scint_old=0 +!d write (iout,*) 'ns=',ns,' nss=',nss,' ihpb,jhpb', +!d & (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 +!d write (iout,*) 'i=',i,' scheck=',scheck,' jj=',jj + if (scheck) then + if (jj.eq.i+1) then +#ifdef MPI +! 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 +! 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 + if (iatsc_s.eq.0) iatsc_s=1 +#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 !?? wham ispp=2 +#ifdef MPI +! 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 +! 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) +! write (iout,*) "my_ele_inds_vdw",my_ele_inds_vdw, +! & " 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) +! write (iout,*) i," ielstart_vdw",ielstart_vdw(i), +! & " 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 ! ?? wham iatel_e=nct-3 + do i=iatel_s,iatel_e + ielstart(i)=i+4 ! ?? wham +2 + 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 +! iscp=3 + iscp=2 +! 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 +!d 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 +!d 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 (iatscp_s.eq.0) iatscp_s=1 + 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 +! 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 + 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 + igrad_end=((2*nlen+1) & + -sqrt(float((2*nlen-1)**2-8*(ngrad_end-1))))/2 +!el allocate(jgrad_start(igrad_start:igrad_end)) +!el allocate(jgrad_end(igrad_start:igrad_end)) !(maxres) + jgrad_start(igrad_start)= & + ngrad_start-(2*nlen-igrad_start)*(igrad_start-1)/2 & + +igrad_start + jgrad_end(igrad_start)=nres + 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,nfgtasks-1 + do j=1,nres + 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),nres,MPI_INTEGER,& + ielstart_all(1,0),nres,MPI_INTEGER,FG_COMM,IERROR) + call MPI_Allgather(ielend(1),nres,MPI_INTEGER,& + ielend_all(1,0),nres,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. +!el allocate(iturn3_sent(4,iturn3_start:iturn3_end)) +!el allocate(iturn4_sent(4,iturn4_start:iturn4_end)) !(4,maxres) + 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 +! write (iout,*) "Loop forward" +! call flush(iout) + do i=iatel_s,iatel_e +! write (iout,*) "from loop i=",i +! call flush(iout) + do j=ielstart(i),ielend(i) + call add_int_from(i,j,ntask_cont_from,itask_cont_from) + enddo + enddo +! write (iout,*) "Loop backward iatel_e-1",iatel_e-1, +! & " iatel_e",iatel_e +! call flush(iout) + nat_sent=0 + do i=iatel_s,iatel_e +! write (iout,*) "i",i," ielstart",ielstart(i), +! & " ielend",ielend(i) +! 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) +! write (iout,*) "Gather ntask_cont_from ended" +! call flush(iout) + call MPI_Gather(itask_cont_from(0),nfgtasks,MPI_INTEGER,& + itask_cont_from_all(0,0),nfgtasks,MPI_INTEGER,king,& + FG_COMM,IERR) +! write (iout,*) "Gather itask_cont_from ended" +! call flush(iout) + call MPI_Gather(ntask_cont_to,1,MPI_INTEGER,ntask_cont_to_all,& + 1,MPI_INTEGER,king,FG_COMM,IERR) +! write (iout,*) "Gather ntask_cont_to ended" +! call flush(iout) + call MPI_Gather(itask_cont_to,nfgtasks,MPI_INTEGER,& + itask_cont_to_all,nfgtasks,MPI_INTEGER,king,FG_COMM,IERR) +! write (iout,*) "Gather itask_cont_to ended" +! 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) +! 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) +! write (iout,*) "flag broadcast ended flag=",flag +! 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) +! write (iout,*) "MPI_Comm_group ended" +! 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 ) +! write (iout,*) "Ranks translated i=",i +! 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) + +!el allocate(lentyp(0:nfgtasks-1)) +#ifndef MATGATHER +! 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 +! do i=1,4 +! blocklengths(i)=4 +! 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 +! write (iout,*) "blocklengths and displs" +! do i=1,4 +! write (iout,*) i,blocklengths(i),displs(i) +! enddo +! call flush(iout) +! call MPI_Type_indexed(4,blocklengths(1),displs(1), +! & MPI_DOUBLE_PRECISION,MPI_ROTAT1(ind_typ),IERROR) +! call MPI_Type_commit(MPI_ROTAT1(ind_typ),IERROR) +! write (iout,*) "MPI_ROTAT1",MPI_ROTAT1 +! do i=1,4 +! blocklengths(i)=2 +! 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 +! write (iout,*) "blocklengths and displs" +! do i=1,4 +! write (iout,*) i,blocklengths(i),displs(i) +! enddo +! call flush(iout) +! call MPI_Type_indexed(4,blocklengths(1),displs(1), +! & MPI_DOUBLE_PRECISION,MPI_ROTAT2(ind_typ),IERROR) +! call MPI_Type_commit(MPI_ROTAT2(ind_typ),IERROR) +! 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)*nres !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)*nres !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)*nres !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)*nres !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)*nres !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. .not. 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 + ibondp_end=nct-1 + ivec_start=1 + ivec_end=nres-1 + iset_start=3 + iset_end=nres+1 + iint_start=2 + iint_end=nres-1 +#endif +!el common /przechowalnia/ +! deallocate(iturn3_start_all) +! deallocate(iturn3_end_all) +! deallocate(iturn4_start_all) +! deallocate(iturn4_end_all) +! deallocate(iatel_s_all) +! deallocate(iatel_e_all) +! deallocate(ielstart_all) +! deallocate(ielend_all) + +! deallocate(ntask_cont_from_all) +! deallocate(ntask_cont_to_all) +! deallocate(itask_cont_from_all) +! deallocate(itask_cont_to_all) +!el---------- + return + end subroutine init_int_table +#ifdef MPI +!----------------------------------------------------------------------------- + subroutine add_int(ii,jj,itask,ntask_cont_to,itask_cont_to,flag) + +!el implicit none +! include "DIMENSIONS" +! include "COMMON.INTERACT" +! include "COMMON.SETUP" +! include "COMMON.IOUNITS" + integer :: ii,jj,ntask_cont_to + integer,dimension(4) :: itask + integer :: itask_cont_to(0:nfgtasks-1) !(0:max_fg_procs-1) + logical :: flag +!el integer,dimension(0:nfgtasks) :: iturn3_start_all,iturn3_end_all,iturn4_start_all,& +!el iturn4_end_all,iatel_s_all,iatel_e_all !(0:max_fg_procs) +!el integer,dimension(nres,0:nfgtasks-1) :: ielstart_all,ielend_all !(maxres,0:max_fg_procs-1) +!el common /przechowalnia/ iturn3_start_all,iturn3_end_all,iturn4_start_all,& +!el iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all + integer :: iproc,isent,k,l +! Determines whether to send interaction ii,jj to other processors; a given +! interaction can be sent to at most 2 processors. +! Sets flag=.true. if interaction ii,jj needs to be sent to at least +! 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 +! write (iout,*) "ii",ii," jj",jj +! Loop over processors to check if anybody could need interaction ii,jj + do iproc=0,fg_rank-1 +! 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 +! write (iout,*) "turn3 to iproc",iproc," ij",ii,jj,"kl",k,l +! 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 +! 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 +! write (iout,*) "turn3 to iproc",iproc," ij",ii,jj," kl",k,l +! 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 subroutine add_int +!----------------------------------------------------------------------------- + subroutine add_int_from(ii,jj,ntask_cont_from,itask_cont_from) + +!el use MPI_data +!el 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:nfgtasks-1) !(0:max_fg_procs) + logical :: flag +!el integer,dimension(0:nfgtasks) :: iturn3_start_all,iturn3_end_all,& +!el iturn4_start_all,iturn4_end_all,iatel_s_all,iatel_e_all !(0:max_fg_procs) +!el integer,dimension(nres,0:nfgtasks-1) :: ielstart_all,ielend_all !(maxres,0:max_fg_procs-1) +!el common /przechowalnia/ iturn3_start_all,iturn3_end_all,iturn4_start_all,& +!el iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all + 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 +! 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 +! 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 subroutine add_int_from +!----------------------------------------------------------------------------- + subroutine add_task(iproc,ntask_cont,itask_cont) + +!el use MPI_data +!el implicit none +! include "DIMENSIONS" + integer :: iproc,ntask_cont,itask_cont(0:nfgtasks-1) !(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 subroutine add_task +#endif +!----------------------------------------------------------------------------- +#if defined MPI || defined WHAM_RUN + 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,int_index_old + 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 + return 1 + else + jat_end=last_atom + endif + if (lprn) write (iout,*) 'jat_end',jat_end + endif + return + end subroutine int_partition +#endif +!----------------------------------------------------------------------------- +#ifndef CLUSTER + 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' +#ifdef MPI + call int_bounds(nhpb,link_start,link_end) + write (iout,*) 'Processor',fg_rank,' CG group',kolor,& + ' absolute rank',MyRank,& + ' nhpb',nhpb,' link_start=',link_start,& + ' link_end',link_end +#else + link_start=1 + link_end=nhpb +#endif + return + end subroutine hpb_partition +#endif +!----------------------------------------------------------------------------- +! misc.f in module io_base +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- +! parmread.F +!----------------------------------------------------------------------------- + subroutine getenv_loc(var, val) + + character(*) :: var, val + +#ifdef WINIFL + character(len=2000) :: line +!el external ilen + + open (196,file='env',status='old',readonly,shared) + iread=0 +! write(*,*)'looking for ',var +10 read(196,*,err=11,end=11)line + iread=index(line,var) +! write(*,*)iread,' ',var,' ',line + if (iread.eq.0) go to 10 +! write(*,*)'---> ',line +11 continue + if(iread.eq.0) then +! write(*,*)'CHUJ' + val='' + else + iread=iread+ilen(var)+1 + read (line(iread:),*,err=12,end=12) val +! write(*,*)'OK: ',var,' = ',val + endif + close(196) + return +12 val='' + close(196) +#elif (defined CRAY) + integer :: lennam,lenval,ierror +! +! getenv using a POSIX call, useful on the T3D +! Sept 1996, comment out error check on advice of H. Pritchard +! + lennam = len(var) + if(lennam.le.0) stop '--error calling getenv--' + call pxfgetenv(var,lennam,val,lenval,ierror) +!-HP- if(ierror.ne.0) stop '--error returned by pxfgetenv--' +#else + call getenv(var,val) +#endif + + return + end subroutine getenv_loc +!----------------------------------------------------------------------------- +! readrtns_CSA.F +!----------------------------------------------------------------------------- + subroutine setup_var + + integer :: i +! 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' +! Set up variable list. + ntheta=nres-2 + nphi=nres-3 + nvar=ntheta+nphi + nside=0 + do i=2,nres-1 +#ifdef WHAM_RUN + if (itype(i).ne.10) then +#else + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then +#endif + 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 +!d write (iout,'(3i4)') (i,ialph(i,1),ialph(i,2),i=2,nres-1) + return + end subroutine setup_var +!----------------------------------------------------------------------------- +! rescode.f +!----------------------------------------------------------------------------- + integer function rescode(iseq,nam,itype) + + use io_base, only: ucase +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.NAMES' +! include 'COMMON.IOUNITS' + character(len=3) :: nam !,ucase + integer :: iseq,itype,i + + if (itype.eq.0) then + + do i=-ntyp1,ntyp1 + if (ucase(nam).eq.restyp(i)) then + rescode=i + return + endif + enddo + + else + + do i=-ntyp1,ntyp1 + if (nam(1:1).eq.onelet(i)) then + rescode=i + return + endif + enddo + + endif + write (iout,10) iseq,nam + stop + 10 format ('**** Error - residue',i4,' has an unresolved name ',a3) + end function rescode +!----------------------------------------------------------------------------- +! timing.F +!----------------------------------------------------------------------------- +! $Date: 1994/10/05 16:41:52 $ +! $Revision: 2.2 $ +! + subroutine set_timers +! +!el implicit none +!el real(kind=8) :: tcpu +! include 'COMMON.TIME1' +!#ifdef MP +#ifdef MPI + include 'mpif.h' +#endif +! Diminish the assigned time limit a little so that there is some time to +! end a batch job +! timlim=batime-150.0 +! Calculate the initial time, if it is not zero (e.g. for the SUN). + stime=tcpu() +#if .not. defined(WHAM_RUN) && .not. defined(CLUSTER) +#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 +#endif +!d print *,' in SET_TIMERS stime=',stime + return + end subroutine set_timers +!----------------------------------------------------------------------------- +#ifndef CLUSTER + logical function stopx(nf) +! This function returns .true. if one of the following reasons to exit SUMSL +! occurs. The "reason" code is stored in WHATSUP passed thru a COMMON block: +! +!... WHATSUP = 0 - go on, no reason to stop. Stopx will return .false. +!... 1 - Time up in current node; +!... 2 - STOP signal was received from another node because the +!... node's task was accomplished (parallel only); +!... -1 - STOP signal was received from another node because of error; +!... -2 - STOP signal was received from another node, because +!... the node's time was up. +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +!el#ifdef WHAM_RUN +!el use control_data, only:WhatsUp +!el#endif +#ifdef MP +!el use MPI_data !include 'COMMON.INFO' + include 'mpif.h' +#endif + integer :: nf +!el logical :: ovrtim + +! include 'COMMON.IOUNITS' +! include 'COMMON.TIME1' + integer :: Kwita + +!d print *,'Processor',MyID,' NF=',nf +!d write (iout,*) "stopx: ",nf +#ifndef WHAM_RUN +#ifndef MPI + if (ovrtim()) then +! Finish if time is up. + stopx = .true. + WhatsUp=1 +#ifdef MPL + else if (mod(nf,100).eq.0) then +! Other processors might have finished. Check this every 100th function +! evaluation. +! 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 +!d 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. +!d write (iout,*) "stopx set at .false." +#endif + +#ifdef OSF +! Check for FOUND_NAN flag + if (FOUND_NAN) then + write(iout,*)" *** stopx : Found a NaN" + stopx=.true. + endif +#endif +#else + if (ovrtim()) then +! Finish if time is up. + stopx = .true. + WhatsUp=1 + else if (cutoffviol) then + stopx = .true. + WhatsUp=2 + else + stopx=.false. + endif +#endif + return + end function stopx +!----------------------------------------------------------------------------- +#else + logical function stopx(nf) +! +! .................................................................. +! +! *****PURPOSE... +! THIS FUNCTION MAY SERVE AS THE STOPX (ASYNCHRONOUS INTERRUPTION) +! FUNCTION FOR THE NL2SOL (NONLINEAR LEAST-SQUARES) PACKAGE AT +! THOSE INSTALLATIONS WHICH DO NOT WISH TO IMPLEMENT A +! DYNAMIC STOPX. +! +! *****ALGORITHM NOTES... +! AT INSTALLATIONS WHERE THE NL2SOL SYSTEM IS USED +! INTERACTIVELY, THIS DUMMY STOPX SHOULD BE REPLACED BY A +! FUNCTION THAT RETURNS .TRUE. IF AND ONLY IF THE INTERRUPT +! (BREAK) KEY HAS BEEN PRESSED SINCE THE LAST CALL ON STOPX. +! +! $$$ MODIFIED FOR USE AS THE TIMER ROUTINE. +! $$$ WHEN THE TIME LIMIT HAS BEEN +! $$$ REACHED STOPX IS SET TO .TRUE AND INITIATES (IN ITSUM) +! $$$ AND ORDERLY EXIT OUT OF SUMSL. IF ARRAYS IV AND V ARE +! $$$ SAVED, THE SUMSL ROUTINES CAN BE RESTARTED AT THE SAME +! $$$ POINT AT WHICH THEY WERE INTERRUPTED. +! +! .................................................................. +! +! include 'DIMENSIONS' + integer :: nf +! logical ovrtim +! include 'COMMON.IOUNITS' +! include 'COMMON.TIME1' +#ifdef MPL +! include 'COMMON.INFO' + integer :: Kwita + +!d print *,'Processor',MyID,' NF=',nf +#endif + if (ovrtim()) then +! Finish if time is up. + stopx = .true. +#ifdef MPL + else if (mod(nf,100).eq.0) then +! Other processors might have finished. Check this every 100th function +! evaluation. +!d print *,'Processor ',MyID,' is checking STOP: nf=',nf + call recv_stop_sig(Kwita) + if (Kwita.eq.-1) then + write (iout,'(a,i4,a,i5)') 'Processor',& + MyID,' has received STOP signal in STOPX; NF=',nf + write (*,'(a,i4,a,i5)') 'Processor',& + MyID,' has received STOP signal in STOPX; NF=',nf + stopx=.true. + else + stopx=.false. + endif +#endif + else + stopx = .false. + endif + return + end function stopx +#endif +!----------------------------------------------------------------------------- + logical function ovrtim() + +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' +! include 'COMMON.TIME1' +!el real(kind=8) :: tcpu + real(kind=8) :: curtim +#ifdef MPI + include "mpif.h" + curtim = MPI_Wtime()-walltime +#else + curtim= tcpu() +#endif +! curtim is the current time in seconds. +! write (iout,*) "curtim",curtim," timlim",timlim," safety",safety +#ifndef WHAM_RUN + if (curtim .ge. timlim - safety) then + 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 +#else + ovrtim=.false. +#endif +!elwrite (iout,*) "ovrtim",ovrtim + return + end function ovrtim +!----------------------------------------------------------------------------- + real(kind=8) function tcpu() + +! include 'COMMON.TIME1' + real(kind=8) :: seconds +#ifdef ES9000 +!*************************** +! Next definition for EAGLE (ibm-es9000) + real(kind=8) :: micseconds + integer :: rcode + tcpu=cputime(micseconds,rcode) + tcpu=(micseconds/1.0E6) - stime +!*************************** +#endif +#ifdef SUN +!*************************** +! Next definitions for sun + REAL(kind=8) :: ECPU,ETIME,ETCPU + real(kind=8),dimension(2) :: tarray + tcpu=etime(tarray) + tcpu=tarray(1) +!*************************** +#endif +#ifdef KSR +!*************************** +! Next definitions for ksr +! this function uses the ksr timer ALL_SECONDS from the PMON library to +! return the elapsed time in seconds + tcpu= all_seconds() - stime +!*************************** +#endif +#ifdef SGI +!*************************** +! Next definitions for sgi + real(kind=4) :: timar(2), etime + seconds = etime(timar) +!d print *,'seconds=',seconds,' stime=',stime +! usrsec = timar(1) +! syssec = timar(2) + tcpu=seconds - stime +!*************************** +#endif + +#ifdef LINUX +!*************************** +! Next definitions for sgi + real(kind=4) :: timar(2), etime + seconds = etime(timar) +!d print *,'seconds=',seconds,' stime=',stime +! usrsec = timar(1) +! syssec = timar(2) + tcpu=seconds - stime +!*************************** +#endif + + +#ifdef CRAY +!*************************** +! Next definitions for Cray +! call date(curdat) +! curdat=curdat(1:9) +! call clock(curtim) +! curtim=curtim(1:8) + cpusec = second() + tcpu=cpusec - stime +!*************************** +#endif +#ifdef AIX +!*************************** +! Next definitions for RS6000 + integer(kind=4) :: i1,mclock + i1 = mclock() + tcpu = (i1+0.0D0)/100.0D0 +#endif +#ifdef WINPGI +!*************************** +! next definitions for windows NT Digital fortran + real(kind=4) :: time_real + call cpu_time(time_real) + tcpu = time_real +#endif +#ifdef WINIFL +!*************************** +! next definitions for windows NT Digital fortran + real(kind=4) :: time_real + call cpu_time(time_real) + tcpu = time_real +#endif + tcpu = 0d0 !el + return + end function tcpu +!----------------------------------------------------------------------------- +#ifndef CLUSTER + subroutine dajczas(rntime,hrtime,mintime,sectime) + +! include 'COMMON.IOUNITS' + integer :: ihr,imn,isc + real(kind=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 ,& + ' minutes ', I2 ,' seconds *****') + return + end subroutine dajczas +!----------------------------------------------------------------------------- + subroutine print_detailed_timing + +!el use MPI_data +! implicit real*8 (a-h,o-z) +! include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif +! include 'COMMON.IOUNITS' +! include 'COMMON.TIME1' +! include 'COMMON.SETUP' + real(kind=8) :: time1,time_barrier + time_barrier = 0.0d0 +#ifdef MPI !el + time1=MPI_WTIME() +#endif !el + 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 +!el#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 subroutine print_detailed_timing +#endif +!----------------------------------------------------------------------------- +!----------------------------------------------------------------------------- + end module control diff --git a/source/unres/control.f90 b/source/unres/control.f90 deleted file mode 100644 index 8d22bf0..0000000 --- a/source/unres/control.f90 +++ /dev/null @@ -1,2160 +0,0 @@ - module control -!----------------------------------------------------------------------------- - use io_units - use names - use MPI_data - use geometry_data - use energy_data - use control_data - use minim_data - use geometry, only:int_bounds -#ifndef CLUSTER - use csa_data -#ifdef WHAM_RUN - use wham_data -#endif -#endif - implicit none -!----------------------------------------------------------------------------- -! commom.control -! common /cntrl/ -! integer :: modecalc,iscode,indpdb,indback,indphi,iranconf,& -! icheckgrad,iprint,i2ndstr,mucadyn,constr_dist,symetr -! 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 -!... minim = .true. means DO minimization. -!... energy_dec = .true. means print energy decomposition matrix -!----------------------------------------------------------------------------- -! common.time1 -! FOUND_NAN - set by calcf to stop sumsl via stopx -! COMMON/TIME1/ - real(kind=8) :: STIME,BATIME,PREVTIM,RSTIME -!el real(kind=8) :: TIMLIM,SAFETY -!el real(kind=8) :: WALLTIME -! COMMON/STOPTIM/ - integer :: ISTOP -! common /sumsl_flag/ - logical :: FOUND_NAN -! common /timing/ - real(kind=8) :: t_init -! time_bcast,time_reduce,time_gather,& -! time_sendrecv,time_barrier_e,time_barrier_g,time_scatter,& - !t_eelecij, -! time_allreduce,& -! time_lagrangian,time_cartgrad,& -! time_sumgradient,time_intcartderiv,time_inttocart,time_intfcart,& -! time_mat,time_fricmatmult,& -! time_scatter_fmat,time_scatter_ginv,& -! time_scatter_fmatmult,time_scatter_ginvmult,& -! t_eshort,t_elong,t_etotal -!----------------------------------------------------------------------------- -! initialize_p.F -!----------------------------------------------------------------------------- -! block data -! integer,parameter :: MaxMoveType = 4 -! character(len=14),dimension(-1:MaxMoveType+1) :: MovTypID=(/'pool','chain regrow',& -! character :: MovTypID(-1:MaxMoveType+1)=(/'pool','chain regrow',& -! 'multi-bond','phi','theta','side chain','total'/) -! Conversion from poises to molecular unit and the gas constant -!el real(kind=8) :: cPoise=2.9361d0, Rb=0.001986d0 -!----------------------------------------------------------------------------- -! common /przechowalnia/ subroutines: init_int_table,add_int,add_int_from - integer,dimension(:),allocatable :: iturn3_start_all,& - iturn3_end_all,iturn4_start_all,iturn4_end_all,iatel_s_all,& - iatel_e_all !(0:max_fg_procs) - integer,dimension(:,:),allocatable :: ielstart_all,& - ielend_all !(maxres,0:max_fg_procs-1) - -! common /przechowalnia/ subroutine: init_int_table - integer,dimension(:),allocatable :: ntask_cont_from_all,& - ntask_cont_to_all !(0:max_fg_procs-1) - integer,dimension(:,:),allocatable :: itask_cont_from_all,& - itask_cont_to_all !(0:max_fg_procs-1,0:max_fg_procs-1) -!----------------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------------- - contains -!----------------------------------------------------------------------------- -! initialize_p.F -!----------------------------------------------------------------------------- - subroutine initialize -! -! Define constants and zero out tables. -! - use comm_iofile - use comm_machsw - use MCM_data, only: MovTypID -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -!MS$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' -! implicit none -! Common blocks from the diagonalization routines -!el integer :: IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(400) -!el integer :: KDIAG,ICORFL,IXDR -!el COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA -!el COMMON /MACHSW/ KDIAG,ICORFL,IXDR - logical :: mask_r -! real*8 text1 /'initial_i'/ - real(kind=4) :: rr - -!local variables el - integer :: i,j,k,l,ichir1,ichir2,iblock,m,maxit - -#if .not. defined(WHAM_RUN) && .not. defined(CLUSTER) - mask_r=.false. -#ifndef ISNAN -! NaNQ initialization - i=-1 - rr=dacos(100.0d0) -#ifdef WINPGI - idumm=proc_proc(rr,i) -#elif defined(WHAM_RUN) - call proc_proc(rr,i) -#endif -#endif - - kdiag=0 - icorfl=0 - iw=2 - - allocate(MovTypID(-1:MaxMoveType+1)) - MovTypID=(/'pool ','chain regrow ',& - 'multi-bond ','phi ','theta ',& - 'side chain ','total '/) -#endif -! -! The following is just to define auxiliary variables used in angle conversion -! - 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 -!el#ifdef CLUSTER -!el Rgas = 1.987D-3 -!el#endif -! -! Define I/O units. -! - inp= 1 - iout= 2 - ipdbin= 3 - ipdb= 7 -#ifdef CLUSTER - imol2= 18 - jplot= 19 -!el jstatin=10 - imol2= 4 - jrms=30 -#else - icart = 30 - imol2= 4 - ithep_pdb=51 - irotam_pdb=52 - irest1=55 - irest2=56 - iifrag=57 - ientin=18 - ientout=19 -!rc for write_rmsbank1 - izs1=21 -!dr include secondary structure prediction bias - isecpred=27 -#endif - igeom= 8 - intin= 9 - ithep= 11 - irotam=12 - itorp= 13 - itordp= 23 - ielep= 14 - isidep=15 -#if defined(WHAM_RUN) || defined(CLUSTER) - isidep1=22 !wham -#else -! -! CSA I/O units (separated from others especially for Jooyoung) -! - 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 -!rc for ifc error 118 - icsa_pdb=42 -#endif - iscpp=25 - icbase=16 - ifourier=20 - istat= 17 - ibond = 28 - isccor = 29 -#ifdef WHAM_RUN -! -! WHAM files -! - ihist=30 - iweight=31 - izsc=32 -#endif -#if defined(WHAM_RUN) || defined(CLUSTER) -! -! setting the mpi variables for WHAM -! - fgprocs=1 - nfgtasks=1 - nfgtasks1=1 -#endif -! -! Set default weights of the energy terms. -! - wsc=1.0D0 ! in wham: wlong=1.0D0 - welec=1.0D0 - wtor =1.0D0 - wang =1.0D0 - wscloc=1.0D0 - wstrain=1.0D0 -! -! Zero out tables. -! -! print '(a,$)','Inside initialize' -! 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 -! do ichir1=-1,1 -! do ichir2=-1,1 -! athet(j,i,ichir1,ichir2)=0.0D0 -! bthet(j,i,ichir1,ichir2)=0.0D0 -! enddo -! enddo -! enddo -! do j=0,3 -! polthet(j,i)=0.0D0 -! enddo -! do j=1,3 -! gthet(j,i)=0.0D0 -! enddo -! theta0(i)=0.0D0 -! sig0(i)=0.0D0 -! sigc0(i)=0.0D0 -! do j=1,maxlob -! bsc(j,i)=0.0D0 -! do k=1,3 -! censc(k,j,i)=0.0D0 -! enddo -! do k=1,3 -! do l=1,3 -! gaussc(l,k,j,i)=0.0D0 -! enddo -! enddo -! nlob(i)=0 -! enddo -! enddo -! nlob(ntyp1)=0 -! dsc(ntyp1)=0.0D0 -! do i=-maxtor,maxtor -! itortyp(i)=0 -!c write (iout,*) "TU DOCHODZE",i,itortyp(i) -! do iblock=1,2 -! do j=-maxtor,maxtor -! do k=1,maxterm -! v1(k,j,i,iblock)=0.0D0 -! v2(k,j,i,iblock)=0.0D0 -! enddo -! enddo -! enddo -! enddo -! do iblock=1,2 -! do i=-maxtor,maxtor -! do j=-maxtor,maxtor -! do k=-maxtor,maxtor -! do l=1,maxtermd_1 -! v1c(1,l,i,j,k,iblock)=0.0D0 -! v1s(1,l,i,j,k,iblock)=0.0D0 -! v1c(2,l,i,j,k,iblock)=0.0D0 -! v1s(2,l,i,j,k,iblock)=0.0D0 -! enddo !l -! do l=1,maxtermd_2 -! do m=1,maxtermd_2 -! v2c(m,l,i,j,k,iblock)=0.0D0 -! v2s(m,l,i,j,k,iblock)=0.0D0 -! enddo !m -! enddo !l -! enddo !k -! enddo !j -! enddo !i -! enddo !iblock - -! do i=1,maxres -! itype(i)=0 -! itel(i)=0 -! enddo -! 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 -! -! Initialize timing. -! - call set_timers -! -! Initialize variables used in minimization. -! -!c maxfun=5000 -!c maxit=2000 - maxfun=500 - maxit=200 - tolf=1.0D-2 - rtolf=5.0D-4 -! -! Initialize the variables responsible for the mode of gradient storage. -! - nfl=0 - icg=1 - -#ifdef WHAM_RUN - allocate(iww(max_eneW)) - do i=1,14 - do j=1,14 - if (print_order(i).eq.j) then - iww(print_order(i))=j - goto 1121 - endif - enddo -1121 continue - enddo -#endif - -#if defined(WHAM_RUN) || defined(CLUSTER) - ndih_constr=0 - -! allocate(ww0(max_eneW)) -! ww0 = reshape((/1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,& -! 1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,0.4d0,1.0d0,& -! 1.0d0,0.0d0,0.0/), shape(ww0)) -! - calc_grad=.false. -! Set timers and counters for the respective routines - t_func = 0.0d0 - t_grad = 0.0d0 - t_fhel = 0.0d0 - t_fbet = 0.0d0 - t_ghel = 0.0d0 - t_gbet = 0.0d0 - t_viol = 0.0d0 - t_gviol = 0.0d0 - n_func = 0 - n_grad = 0 - n_fhel = 0 - n_fbet = 0 - n_ghel = 0 - n_gbet = 0 - n_viol = 0 - n_gviol = 0 - n_map = 0 -#endif -! -! Initialize constants used to split the energy into long- and short-range -! components -! - r_cut=2.0d0 - rlamb=0.3d0 -#ifndef SPLITELE - nprint_ene=nprint_ene-1 -#endif - return - end subroutine initialize -!----------------------------------------------------------------------------- - subroutine init_int_table - - use geometry, only:int_bounds1 -!el use MPI_data -!el implicit none -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - integer,dimension(15) :: blocklengths,displs -#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' -!el integer,dimension(0:nfgtasks) :: iturn3_start_all,iturn3_end_all,& -!el iturn4_start_all,iturn4_end_all,iatel_s_all,iatel_e_all !(0:max_fg_procs) -!el integer,dimension(nres,0:nfgtasks) :: ielstart_all,& -!el ielend_all !(maxres,0:max_fg_procs-1) -!el integer,dimension(0:nfgtasks-1) :: ntask_cont_from_all,& -!el ntask_cont_to_all !(0:max_fg_procs-1), -!el integer,dimension(0:nfgtasks-1,0:nfgtasks-1) :: itask_cont_from_all,& -!el itask_cont_to_all !(0:max_fg_procs-1,0:max_fg_procs-1) - -!el common /przechowalnia/ iturn3_start_all,iturn3_end_all,& -!el iturn4_start_all,iturn4_end_all,iatel_s_all,iatel_e_all,& -!el ielstart_all,ielend_all,ntask_cont_from_all,itask_cont_from_all,& -!el ntask_cont_to_all,itask_cont_to_all - - integer :: FG_GROUP,CONT_FROM_GROUP,CONT_TO_GROUP - logical :: scheck,lprint,flag - -!el local variables - integer :: ind_scint=0,ind_scint_old,ii,jj,i,j,iint - -#ifdef MPI - integer :: my_sc_int(0:nfgtasks-1),my_ele_int(0:nfgtasks-1) - integer :: my_sc_intt(0:nfgtasks),my_ele_intt(0:nfgtasks) - integer :: n_sc_int_tot,my_sc_inde,my_sc_inds,ind_sctint,npept - integer :: nele_int_tot,my_ele_inds,my_ele_inde,ind_eleint_old,& - ind_eleint,ijunk,nele_int_tot_vdw,my_ele_inds_vdw,& - my_ele_inde_vdw,ind_eleint_vdw,ind_eleint_vdw_old,& - nscp_int_tot,my_scp_inds,my_scp_inde,ind_scpint,& - ind_scpint_old,nsumgrad,nlen,ngrad_start,ngrad_end,& - ierror,k,ierr,iaux,ncheck_to,ncheck_from,ind_typ,& - ichunk,int_index_old - -!el allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1) -!el allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1) - -!... Determine the numbers of start and end SC-SC interaction -!... to deal with by current processor. -!write (iout,*) '******INIT_INT_TABLE nres=',nres,' nnt=',nnt,' nct=',nct - do i=0,nfgtasks-1 - itask_cont_from(i)=fg_rank - itask_cont_to(i)=fg_rank - enddo - lprint=energy_dec -! lprint=.true. - 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) -!write (iout,*) 'INIT_INT_TABLE nres=',nres,' nnt=',nnt,' nct=',nct - 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 -!el common /przechowalnia/ - allocate(iturn3_start_all(0:nfgtasks)) - allocate(iturn3_end_all(0:nfgtasks)) - allocate(iturn4_start_all(0:nfgtasks)) - allocate(iturn4_end_all(0:nfgtasks)) - allocate(iatel_s_all(0:nfgtasks)) - allocate(iatel_e_all(0:nfgtasks)) - allocate(ielstart_all(nres,0:nfgtasks-1)) - allocate(ielend_all(nres,0:nfgtasks-1)) - - allocate(ntask_cont_from_all(0:nfgtasks-1)) - allocate(ntask_cont_to_all(0:nfgtasks-1)) - allocate(itask_cont_from_all(0:nfgtasks-1,0:nfgtasks-1)) - allocate(itask_cont_to_all(0:nfgtasks-1,0:nfgtasks-1)) -!el---------- -! lprint=.false. - do i=1,nres !el !maxres - nint_gr(i)=0 - nscp_gr(i)=0 - ielstart(i)=0 - ielend(i)=0 - do j=1,maxint_gr - istart(i,j)=0 - iend(i,j)=0 - iscpstart(i,j)=0 - iscpend(i,j)=0 - enddo - enddo - ind_scint=0 - ind_scint_old=0 -!d write (iout,*) 'ns=',ns,' nss=',nss,' ihpb,jhpb', -!d & (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 -!d write (iout,*) 'i=',i,' scheck=',scheck,' jj=',jj - if (scheck) then - if (jj.eq.i+1) then -#ifdef MPI -! 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 -! 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 - if (iatsc_s.eq.0) iatsc_s=1 -#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 !?? wham ispp=2 -#ifdef MPI -! 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 -! 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) -! write (iout,*) "my_ele_inds_vdw",my_ele_inds_vdw, -! & " 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) -! write (iout,*) i," ielstart_vdw",ielstart_vdw(i), -! & " 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 ! ?? wham iatel_e=nct-3 - do i=iatel_s,iatel_e - ielstart(i)=i+4 ! ?? wham +2 - 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 -! iscp=3 - iscp=2 -! 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 -!d 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 -!d 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 (iatscp_s.eq.0) iatscp_s=1 - 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 -! 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 - 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 - igrad_end=((2*nlen+1) & - -sqrt(float((2*nlen-1)**2-8*(ngrad_end-1))))/2 -!el allocate(jgrad_start(igrad_start:igrad_end)) -!el allocate(jgrad_end(igrad_start:igrad_end)) !(maxres) - jgrad_start(igrad_start)= & - ngrad_start-(2*nlen-igrad_start)*(igrad_start-1)/2 & - +igrad_start - jgrad_end(igrad_start)=nres - 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,nfgtasks-1 - do j=1,nres - 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),nres,MPI_INTEGER,& - ielstart_all(1,0),nres,MPI_INTEGER,FG_COMM,IERROR) - call MPI_Allgather(ielend(1),nres,MPI_INTEGER,& - ielend_all(1,0),nres,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. -!el allocate(iturn3_sent(4,iturn3_start:iturn3_end)) -!el allocate(iturn4_sent(4,iturn4_start:iturn4_end)) !(4,maxres) - 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 -! write (iout,*) "Loop forward" -! call flush(iout) - do i=iatel_s,iatel_e -! write (iout,*) "from loop i=",i -! call flush(iout) - do j=ielstart(i),ielend(i) - call add_int_from(i,j,ntask_cont_from,itask_cont_from) - enddo - enddo -! write (iout,*) "Loop backward iatel_e-1",iatel_e-1, -! & " iatel_e",iatel_e -! call flush(iout) - nat_sent=0 - do i=iatel_s,iatel_e -! write (iout,*) "i",i," ielstart",ielstart(i), -! & " ielend",ielend(i) -! 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) -! write (iout,*) "Gather ntask_cont_from ended" -! call flush(iout) - call MPI_Gather(itask_cont_from(0),nfgtasks,MPI_INTEGER,& - itask_cont_from_all(0,0),nfgtasks,MPI_INTEGER,king,& - FG_COMM,IERR) -! write (iout,*) "Gather itask_cont_from ended" -! call flush(iout) - call MPI_Gather(ntask_cont_to,1,MPI_INTEGER,ntask_cont_to_all,& - 1,MPI_INTEGER,king,FG_COMM,IERR) -! write (iout,*) "Gather ntask_cont_to ended" -! call flush(iout) - call MPI_Gather(itask_cont_to,nfgtasks,MPI_INTEGER,& - itask_cont_to_all,nfgtasks,MPI_INTEGER,king,FG_COMM,IERR) -! write (iout,*) "Gather itask_cont_to ended" -! 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) -! 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) -! write (iout,*) "flag broadcast ended flag=",flag -! 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) -! write (iout,*) "MPI_Comm_group ended" -! 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 ) -! write (iout,*) "Ranks translated i=",i -! 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) - -!el allocate(lentyp(0:nfgtasks-1)) -#ifndef MATGATHER -! 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 -! do i=1,4 -! blocklengths(i)=4 -! 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 -! write (iout,*) "blocklengths and displs" -! do i=1,4 -! write (iout,*) i,blocklengths(i),displs(i) -! enddo -! call flush(iout) -! call MPI_Type_indexed(4,blocklengths(1),displs(1), -! & MPI_DOUBLE_PRECISION,MPI_ROTAT1(ind_typ),IERROR) -! call MPI_Type_commit(MPI_ROTAT1(ind_typ),IERROR) -! write (iout,*) "MPI_ROTAT1",MPI_ROTAT1 -! do i=1,4 -! blocklengths(i)=2 -! 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 -! write (iout,*) "blocklengths and displs" -! do i=1,4 -! write (iout,*) i,blocklengths(i),displs(i) -! enddo -! call flush(iout) -! call MPI_Type_indexed(4,blocklengths(1),displs(1), -! & MPI_DOUBLE_PRECISION,MPI_ROTAT2(ind_typ),IERROR) -! call MPI_Type_commit(MPI_ROTAT2(ind_typ),IERROR) -! 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)*nres !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)*nres !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)*nres !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)*nres !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)*nres !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. .not. 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 - ibondp_end=nct-1 - ivec_start=1 - ivec_end=nres-1 - iset_start=3 - iset_end=nres+1 - iint_start=2 - iint_end=nres-1 -#endif -!el common /przechowalnia/ -! deallocate(iturn3_start_all) -! deallocate(iturn3_end_all) -! deallocate(iturn4_start_all) -! deallocate(iturn4_end_all) -! deallocate(iatel_s_all) -! deallocate(iatel_e_all) -! deallocate(ielstart_all) -! deallocate(ielend_all) - -! deallocate(ntask_cont_from_all) -! deallocate(ntask_cont_to_all) -! deallocate(itask_cont_from_all) -! deallocate(itask_cont_to_all) -!el---------- - return - end subroutine init_int_table -#ifdef MPI -!----------------------------------------------------------------------------- - subroutine add_int(ii,jj,itask,ntask_cont_to,itask_cont_to,flag) - -!el implicit none -! include "DIMENSIONS" -! include "COMMON.INTERACT" -! include "COMMON.SETUP" -! include "COMMON.IOUNITS" - integer :: ii,jj,ntask_cont_to - integer,dimension(4) :: itask - integer :: itask_cont_to(0:nfgtasks-1) !(0:max_fg_procs-1) - logical :: flag -!el integer,dimension(0:nfgtasks) :: iturn3_start_all,iturn3_end_all,iturn4_start_all,& -!el iturn4_end_all,iatel_s_all,iatel_e_all !(0:max_fg_procs) -!el integer,dimension(nres,0:nfgtasks-1) :: ielstart_all,ielend_all !(maxres,0:max_fg_procs-1) -!el common /przechowalnia/ iturn3_start_all,iturn3_end_all,iturn4_start_all,& -!el iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all - integer :: iproc,isent,k,l -! Determines whether to send interaction ii,jj to other processors; a given -! interaction can be sent to at most 2 processors. -! Sets flag=.true. if interaction ii,jj needs to be sent to at least -! 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 -! write (iout,*) "ii",ii," jj",jj -! Loop over processors to check if anybody could need interaction ii,jj - do iproc=0,fg_rank-1 -! 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 -! write (iout,*) "turn3 to iproc",iproc," ij",ii,jj,"kl",k,l -! 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 -! 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 -! write (iout,*) "turn3 to iproc",iproc," ij",ii,jj," kl",k,l -! 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 subroutine add_int -!----------------------------------------------------------------------------- - subroutine add_int_from(ii,jj,ntask_cont_from,itask_cont_from) - -!el use MPI_data -!el 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:nfgtasks-1) !(0:max_fg_procs) - logical :: flag -!el integer,dimension(0:nfgtasks) :: iturn3_start_all,iturn3_end_all,& -!el iturn4_start_all,iturn4_end_all,iatel_s_all,iatel_e_all !(0:max_fg_procs) -!el integer,dimension(nres,0:nfgtasks-1) :: ielstart_all,ielend_all !(maxres,0:max_fg_procs-1) -!el common /przechowalnia/ iturn3_start_all,iturn3_end_all,iturn4_start_all,& -!el iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all - 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 -! 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 -! 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 subroutine add_int_from -!----------------------------------------------------------------------------- - subroutine add_task(iproc,ntask_cont,itask_cont) - -!el use MPI_data -!el implicit none -! include "DIMENSIONS" - integer :: iproc,ntask_cont,itask_cont(0:nfgtasks-1) !(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 subroutine add_task -#endif -!----------------------------------------------------------------------------- -#if defined MPI || defined WHAM_RUN - 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,int_index_old - 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 - return 1 - else - jat_end=last_atom - endif - if (lprn) write (iout,*) 'jat_end',jat_end - endif - return - end subroutine int_partition -#endif -!----------------------------------------------------------------------------- -#ifndef CLUSTER - 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' -#ifdef MPI - call int_bounds(nhpb,link_start,link_end) - write (iout,*) 'Processor',fg_rank,' CG group',kolor,& - ' absolute rank',MyRank,& - ' nhpb',nhpb,' link_start=',link_start,& - ' link_end',link_end -#else - link_start=1 - link_end=nhpb -#endif - return - end subroutine hpb_partition -#endif -!----------------------------------------------------------------------------- -! misc.f in module io_base -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- -! parmread.F -!----------------------------------------------------------------------------- - subroutine getenv_loc(var, val) - - character(*) :: var, val - -#ifdef WINIFL - character(len=2000) :: line -!el external ilen - - open (196,file='env',status='old',readonly,shared) - iread=0 -! write(*,*)'looking for ',var -10 read(196,*,err=11,end=11)line - iread=index(line,var) -! write(*,*)iread,' ',var,' ',line - if (iread.eq.0) go to 10 -! write(*,*)'---> ',line -11 continue - if(iread.eq.0) then -! write(*,*)'CHUJ' - val='' - else - iread=iread+ilen(var)+1 - read (line(iread:),*,err=12,end=12) val -! write(*,*)'OK: ',var,' = ',val - endif - close(196) - return -12 val='' - close(196) -#elif (defined CRAY) - integer :: lennam,lenval,ierror -! -! getenv using a POSIX call, useful on the T3D -! Sept 1996, comment out error check on advice of H. Pritchard -! - lennam = len(var) - if(lennam.le.0) stop '--error calling getenv--' - call pxfgetenv(var,lennam,val,lenval,ierror) -!-HP- if(ierror.ne.0) stop '--error returned by pxfgetenv--' -#else - call getenv(var,val) -#endif - - return - end subroutine getenv_loc -!----------------------------------------------------------------------------- -! readrtns_CSA.F -!----------------------------------------------------------------------------- - subroutine setup_var - - integer :: i -! 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' -! Set up variable list. - ntheta=nres-2 - nphi=nres-3 - nvar=ntheta+nphi - nside=0 - do i=2,nres-1 -#ifdef WHAM_RUN - if (itype(i).ne.10) then -#else - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then -#endif - 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 -!d write (iout,'(3i4)') (i,ialph(i,1),ialph(i,2),i=2,nres-1) - return - end subroutine setup_var -!----------------------------------------------------------------------------- -! rescode.f -!----------------------------------------------------------------------------- - integer function rescode(iseq,nam,itype) - - use io_base, only: ucase -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.NAMES' -! include 'COMMON.IOUNITS' - character(len=3) :: nam !,ucase - integer :: iseq,itype,i - - if (itype.eq.0) then - - do i=-ntyp1,ntyp1 - if (ucase(nam).eq.restyp(i)) then - rescode=i - return - endif - enddo - - else - - do i=-ntyp1,ntyp1 - if (nam(1:1).eq.onelet(i)) then - rescode=i - return - endif - enddo - - endif - write (iout,10) iseq,nam - stop - 10 format ('**** Error - residue',i4,' has an unresolved name ',a3) - end function rescode -!----------------------------------------------------------------------------- -! timing.F -!----------------------------------------------------------------------------- -! $Date: 1994/10/05 16:41:52 $ -! $Revision: 2.2 $ -! - subroutine set_timers -! -!el implicit none -!el real(kind=8) :: tcpu -! include 'COMMON.TIME1' -!#ifdef MP -#ifdef MPI - include 'mpif.h' -#endif -! Diminish the assigned time limit a little so that there is some time to -! end a batch job -! timlim=batime-150.0 -! Calculate the initial time, if it is not zero (e.g. for the SUN). - stime=tcpu() -#if .not. defined(WHAM_RUN) && .not. defined(CLUSTER) -#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 -#endif -!d print *,' in SET_TIMERS stime=',stime - return - end subroutine set_timers -!----------------------------------------------------------------------------- -#ifndef CLUSTER - logical function stopx(nf) -! This function returns .true. if one of the following reasons to exit SUMSL -! occurs. The "reason" code is stored in WHATSUP passed thru a COMMON block: -! -!... WHATSUP = 0 - go on, no reason to stop. Stopx will return .false. -!... 1 - Time up in current node; -!... 2 - STOP signal was received from another node because the -!... node's task was accomplished (parallel only); -!... -1 - STOP signal was received from another node because of error; -!... -2 - STOP signal was received from another node, because -!... the node's time was up. -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -!el#ifdef WHAM_RUN -!el use control_data, only:WhatsUp -!el#endif -#ifdef MP -!el use MPI_data !include 'COMMON.INFO' - include 'mpif.h' -#endif - integer :: nf -!el logical :: ovrtim - -! include 'COMMON.IOUNITS' -! include 'COMMON.TIME1' - integer :: Kwita - -!d print *,'Processor',MyID,' NF=',nf -!d write (iout,*) "stopx: ",nf -#ifndef WHAM_RUN -#ifndef MPI - if (ovrtim()) then -! Finish if time is up. - stopx = .true. - WhatsUp=1 -#ifdef MPL - else if (mod(nf,100).eq.0) then -! Other processors might have finished. Check this every 100th function -! evaluation. -! 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 -!d 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. -!d write (iout,*) "stopx set at .false." -#endif - -#ifdef OSF -! Check for FOUND_NAN flag - if (FOUND_NAN) then - write(iout,*)" *** stopx : Found a NaN" - stopx=.true. - endif -#endif -#else - if (ovrtim()) then -! Finish if time is up. - stopx = .true. - WhatsUp=1 - else if (cutoffviol) then - stopx = .true. - WhatsUp=2 - else - stopx=.false. - endif -#endif - return - end function stopx -!----------------------------------------------------------------------------- -#else - logical function stopx(nf) -! -! .................................................................. -! -! *****PURPOSE... -! THIS FUNCTION MAY SERVE AS THE STOPX (ASYNCHRONOUS INTERRUPTION) -! FUNCTION FOR THE NL2SOL (NONLINEAR LEAST-SQUARES) PACKAGE AT -! THOSE INSTALLATIONS WHICH DO NOT WISH TO IMPLEMENT A -! DYNAMIC STOPX. -! -! *****ALGORITHM NOTES... -! AT INSTALLATIONS WHERE THE NL2SOL SYSTEM IS USED -! INTERACTIVELY, THIS DUMMY STOPX SHOULD BE REPLACED BY A -! FUNCTION THAT RETURNS .TRUE. IF AND ONLY IF THE INTERRUPT -! (BREAK) KEY HAS BEEN PRESSED SINCE THE LAST CALL ON STOPX. -! -! $$$ MODIFIED FOR USE AS THE TIMER ROUTINE. -! $$$ WHEN THE TIME LIMIT HAS BEEN -! $$$ REACHED STOPX IS SET TO .TRUE AND INITIATES (IN ITSUM) -! $$$ AND ORDERLY EXIT OUT OF SUMSL. IF ARRAYS IV AND V ARE -! $$$ SAVED, THE SUMSL ROUTINES CAN BE RESTARTED AT THE SAME -! $$$ POINT AT WHICH THEY WERE INTERRUPTED. -! -! .................................................................. -! -! include 'DIMENSIONS' - integer :: nf -! logical ovrtim -! include 'COMMON.IOUNITS' -! include 'COMMON.TIME1' -#ifdef MPL -! include 'COMMON.INFO' - integer :: Kwita - -!d print *,'Processor',MyID,' NF=',nf -#endif - if (ovrtim()) then -! Finish if time is up. - stopx = .true. -#ifdef MPL - else if (mod(nf,100).eq.0) then -! Other processors might have finished. Check this every 100th function -! evaluation. -!d print *,'Processor ',MyID,' is checking STOP: nf=',nf - call recv_stop_sig(Kwita) - if (Kwita.eq.-1) then - write (iout,'(a,i4,a,i5)') 'Processor',& - MyID,' has received STOP signal in STOPX; NF=',nf - write (*,'(a,i4,a,i5)') 'Processor',& - MyID,' has received STOP signal in STOPX; NF=',nf - stopx=.true. - else - stopx=.false. - endif -#endif - else - stopx = .false. - endif - return - end function stopx -#endif -!----------------------------------------------------------------------------- - logical function ovrtim() - -! include 'DIMENSIONS' -! include 'COMMON.IOUNITS' -! include 'COMMON.TIME1' -!el real(kind=8) :: tcpu - real(kind=8) :: curtim -#ifdef MPI - include "mpif.h" - curtim = MPI_Wtime()-walltime -#else - curtim= tcpu() -#endif -! curtim is the current time in seconds. -! write (iout,*) "curtim",curtim," timlim",timlim," safety",safety -#ifndef WHAM_RUN - if (curtim .ge. timlim - safety) then - 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 -#else - ovrtim=.false. -#endif -!elwrite (iout,*) "ovrtim",ovrtim - return - end function ovrtim -!----------------------------------------------------------------------------- - real(kind=8) function tcpu() - -! include 'COMMON.TIME1' - real(kind=8) :: seconds -#ifdef ES9000 -!*************************** -! Next definition for EAGLE (ibm-es9000) - real(kind=8) :: micseconds - integer :: rcode - tcpu=cputime(micseconds,rcode) - tcpu=(micseconds/1.0E6) - stime -!*************************** -#endif -#ifdef SUN -!*************************** -! Next definitions for sun - REAL(kind=8) :: ECPU,ETIME,ETCPU - real(kind=8),dimension(2) :: tarray - tcpu=etime(tarray) - tcpu=tarray(1) -!*************************** -#endif -#ifdef KSR -!*************************** -! Next definitions for ksr -! this function uses the ksr timer ALL_SECONDS from the PMON library to -! return the elapsed time in seconds - tcpu= all_seconds() - stime -!*************************** -#endif -#ifdef SGI -!*************************** -! Next definitions for sgi - real(kind=4) :: timar(2), etime - seconds = etime(timar) -!d print *,'seconds=',seconds,' stime=',stime -! usrsec = timar(1) -! syssec = timar(2) - tcpu=seconds - stime -!*************************** -#endif - -#ifdef LINUX -!*************************** -! Next definitions for sgi - real(kind=4) :: timar(2), etime - seconds = etime(timar) -!d print *,'seconds=',seconds,' stime=',stime -! usrsec = timar(1) -! syssec = timar(2) - tcpu=seconds - stime -!*************************** -#endif - - -#ifdef CRAY -!*************************** -! Next definitions for Cray -! call date(curdat) -! curdat=curdat(1:9) -! call clock(curtim) -! curtim=curtim(1:8) - cpusec = second() - tcpu=cpusec - stime -!*************************** -#endif -#ifdef AIX -!*************************** -! Next definitions for RS6000 - integer(kind=4) :: i1,mclock - i1 = mclock() - tcpu = (i1+0.0D0)/100.0D0 -#endif -#ifdef WINPGI -!*************************** -! next definitions for windows NT Digital fortran - real(kind=4) :: time_real - call cpu_time(time_real) - tcpu = time_real -#endif -#ifdef WINIFL -!*************************** -! next definitions for windows NT Digital fortran - real(kind=4) :: time_real - call cpu_time(time_real) - tcpu = time_real -#endif - tcpu = 0d0 !el - return - end function tcpu -!----------------------------------------------------------------------------- -#ifndef CLUSTER - subroutine dajczas(rntime,hrtime,mintime,sectime) - -! include 'COMMON.IOUNITS' - integer :: ihr,imn,isc - real(kind=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 ,& - ' minutes ', I2 ,' seconds *****') - return - end subroutine dajczas -!----------------------------------------------------------------------------- - subroutine print_detailed_timing - -!el use MPI_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif -! include 'COMMON.IOUNITS' -! include 'COMMON.TIME1' -! include 'COMMON.SETUP' - real(kind=8) :: time1,time_barrier - time_barrier = 0.0d0 -#ifdef MPI !el - time1=MPI_WTIME() -#endif !el - 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 -!el#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 subroutine print_detailed_timing -#endif -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - end module control diff --git a/source/wham/CMakeLists.txt b/source/wham/CMakeLists.txt new file mode 100644 index 0000000..de978d3 --- /dev/null +++ b/source/wham/CMakeLists.txt @@ -0,0 +1,291 @@ +# +# CMake project file for WHAM single chain version +# + +enable_language (Fortran) + +#================================ +# Set source file lists +#================================ + +# dummy library for automatic dependency +set(UNRES_WHAM_SRC_DATA + wham_data.f90 + w_compar_data.f90 + w_comm_local.f90 +) +set(UNRES_WHAM_SRC0 + ../unres/data/names.f90 + ../unres/data/io_units.f90 + ../unres/data/calc_data.f90 + ../unres/data/compare_data.f90 + ../unres/data/control_data.f90 + ../unres/data/CSA_data.f90 + ../unres/data/energy_data.f90 + ../unres/data/geometry_data.f90 + ../unres/data/MCM_data.f90 + ../unres/data/MD_data.f90 + ../unres/data/minim_data.f90 + ../unres/data/MPI_data.f90 + ../unres/data/comm_local.f90 + ../unres/math.f90 + ../unres/geometry.f90 + ../unres/io_base.f90 + ../unres/energy.f90 + ../unres/control.F90 + ../unres/io_config.f90 + ../unres/regularize.f90 + ../unres/compare.F90 + io_database.f90 + io_wham.f90 + conform_compar.f90 + enecalc.f90 + wham_calc.f90 + work_partition.f90 + wham.f90 +) + + +#================================================ +# Set compiler flags for different sourcefiles +#================================================ +if (Fortran_COMPILER_NAME STREQUAL "ifort") + set (CMAKE_Fortran_FLAGS_RELEASE " ") + set (CMAKE_Fortran_FLAGS_DEBUG "-O0 -g ") + set(FFLAGS0 "-fpp -mcmodel=medium -shared-intel " ) +elseif (Fortran_COMPILER_NAME STREQUAL "gfortran") + set(FFLAGS0 "-fpp -std=legacy -mcmodel=medium -g ") +elseif (Fortran_COMPILER_NAME STREQUAL "pgf90") + set(FFLAGS0 "-fpp -mcmodel=medium -Mlarge_arrays ") +else () + set(FFLAGS0 "-fpp -g -mcmodel=medium " ) +endif (Fortran_COMPILER_NAME STREQUAL "ifort") + + +#========================================= +# Add MPI compiler flags +#========================================= +if(UNRES_WITH_MPI) + set(FFLAGS0 "${FFLAGS0} -I${MPI_Fortran_INCLUDE_PATH}") +endif(UNRES_WITH_MPI) + +set_property(SOURCE ${UNRES_WHAM_SRC0} PROPERTY COMPILE_FLAGS ${FFLAGS0} ) +set_property(SOURCE ${UNRES_WHAM_SRC_DATA} PROPERTY COMPILE_FLAGS ${FFLAGS0} ) + +#========================================= +# Settings for GAB force field +#========================================= + +if(UNRES_MD_FF STREQUAL "GAB" ) + # set preprocesor flags + set(CPPFLAGS "PROCOR -DSPLITELE -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DSCCORPDB" ) + +#========================================= +# Settings for E0LL2Y force field +#========================================= +elseif(UNRES_MD_FF STREQUAL "E0LL2Y") + # set preprocesor flags + set(CPPFLAGS "PROCOR -DSPLITELE -DSCCORPDB" ) +elseif(UNRES_MD_FF STREQUAL "4P") + set(CPPFLAGS "SPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DSCCORPDB" ) +endif(UNRES_MD_FF STREQUAL "GAB") + + +#========================================= +# Additional flags +#========================================= +set(CPPFLAGS "${CPPFLAGS} -DUNRES -DISNAN -DWHAM_RUN ") + + +#========================================= +# 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") +elseif (Fortran_COMPILER_NAME STREQUAL "pgf90") + set(CPPFLAGS "${CPPFLAGS} -DPGI") + FILE(COPY ${CMAKE_SOURCE_DIR}/source/lib/isnan_pgi.f DESTINATION ${CMAKE_CURRENT_BINARY_DIR} ) + list(APPEND UNRES_WHAM_SRC0 ${CMAKE_CURRENT_BINARY_DIR}/isnan_pgi.f) + set(CMAKE_EXE_LINKER_FLAGS "-Bdynamic") +endif (Fortran_COMPILER_NAME STREQUAL "ifort") + +#========================================= +# Add MPI preprocessor flags +#========================================= +set(CPPFLAGS "${CPPFLAGS} -DMPI") + +#========================================= +# Add 64-bit specific preprocessor flags +#========================================= +if (architektura STREQUAL "64") + set(CPPFLAGS "${CPPFLAGS} -DAMD64") +endif (architektura STREQUAL "64") + +#========================================= +# Apply preprocesor flags to *.F files +#========================================= +set_property(SOURCE ${UNRES_WHAM_SRC0} PROPERTY COMPILE_DEFINITIONS ${CPPFLAGS} ) +set_property(SOURCE ${UNRES_WHAM_SRC_DATA} PROPERTY COMPILE_DEFINITIONS ${CPPFLAGS} ) + +#======================================== +# Setting binary name +#======================================== +set(UNRES_WHAM_BIN "wham_${Fortran_COMPILER_NAME}_MPI_${UNRES_MD_FF}.exe") + +#========================================= +# cinfo.f workaround for CMake +#========================================= +# get the current date +TODAY(DATE) +# generate cinfo.f + +set(CINFO "${CMAKE_CURRENT_BINARY_DIR}/cinfo.f90") +FILE(WRITE ${CINFO} +"! CMake generated file cinfo.f90 + subroutine cinfo + use io_units + write(iout,*)'++++ Compile info ++++' + write(iout,*)'Version ${UNRES_MAJOR}.${UNRES_MINOR} build ${UNRES_PATCH}' +") + +CINFO_FORMAT(${CINFO} "Compiled" "${DATE}" ) +CINFO_FORMAT(${CINFO} "Compiled by" "$ENV{USER}@$ENV{HOST}" ) +CINFO_FORMAT(${CINFO} "OS name:" "${CMAKE_SYSTEM_NAME}" ) +CINFO_FORMAT(${CINFO} "OS release:" "${CMAKE_SYSTEM}" ) +CINFO_FORMAT(${CINFO} "Fortran Compiler:" "${CMAKE_Fortran_COMPILER}" ) +CINFO_FORMAT(${CINFO} "MD Force field:" "${UNRES_MD_FF}" ) +CINFO_FORMAT(${CINFO} "CPPFLAGS =" "${CPPFLAGS}") + +FILE(APPEND ${CINFO} +" write(iout,*)'++++ End of compile info ++++' + return + end ") + +# set include path +set_property(SOURCE ${CMAKE_CURRENT_BINARY_DIR}/cinfo.f90 PROPERTY COMPILE_FLAGS "${FFLAGS0} -I${CMAKE_CURRENT_SOURCE_DIR}" ) +#set_property(SOURCE proc_proc.c PROPERTY COMPILE_FLAGS "-D${CPPFLAGS}") + +#========================================= +# Set full unres CSA sources +#========================================= +set(UNRES_WHAM_SRCS ${UNRES_WHAM_SRC0} ${CMAKE_CURRENT_BINARY_DIR}/cinfo.f90 ) + +#========================================= +# Build the binary +#========================================= +add_executable(UNRES_WHAM_BIN ${UNRES_WHAM_SRCS} ) +add_library(wham_data_lib ${UNRES_WHAM_SRC_DATA}) +target_link_libraries (UNRES_WHAM_BIN wham_data_lib) +set_target_properties(UNRES_WHAM_BIN PROPERTIES OUTPUT_NAME ${UNRES_WHAM_BIN}) +set_property(TARGET UNRES_WHAM_BIN PROPERTY RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/bin ) +#add_dependencies (${UNRES_BIN} ${UNRES_XDRFLIB}) + +#========================================= +# Link libraries +#========================================= +# link MPI libraries +target_link_libraries( UNRES_WHAM_BIN ${MPI_Fortran_LIBRARIES} ) +# link libxdrf.a +target_link_libraries( UNRES_WHAM_BIN xdrf ) + +#========================================= +# Install Path +#========================================= +install(TARGETS UNRES_WHAM_BIN DESTINATION ${CMAKE_INSTALL_PREFIX}) + + +#========================================= +# TESTS +#========================================= + +# MESSAGE (STATUS "${MPI_Fortran_LIBRARIES}") + if ("${MPI_Fortran_LIBRARIES}" MATCHES "lam") + MESSAGE (STATUS "LAM MPI library detected") + set (boot_lam "-boot") + else() + set (boot_lam "") + endif() + + if (UNRES_SRUN) + set (np "-n") + set (mpiexec "srun") + elseif(UNRES_MPIRUN) + set (np "-np") + set (mpiexec "mpirun") + else() + set (np "-np") + set (mpiexec "mpiexec") + endif() + + +FILE(WRITE ${CMAKE_CURRENT_BINARY_DIR}/scripts/wham_mpi_E0LL2Y.sh +"#!/bin/sh +export POT=GB +export PREFIX=$1 +#----------------------------------------------------------------------------- +WHAM_BIN=${CMAKE_BINARY_DIR}/bin/${UNRES_WHAM_BIN} +#----------------------------------------------------------------------------- +DD=${CMAKE_SOURCE_DIR}/PARAM +export BONDPAR=$DD/bond_AM1.parm +export THETPAR=$DD/theta_abinitio.parm +export ROTPAR=$DD/rotamers_AM1_aura.10022007.parm +export TORPAR=$DD/torsion_631Gdp.parm +export TORDPAR=$DD/torsion_double_631Gdp.parm +export ELEPAR=$DD/electr_631Gdp.parm +export SIDEPAR=$DD/scinter_$POT.parm +export FOURIER=$DD/fourier_opt.parm.1igd_hc_iter3_3 +export SCPPAR=$DD/scp.parm +export SCCORPAR=$DD/sccor_am1_pawel.dat +export THETPARPDB=$DD/thetaml.5parm +export ROTPARPDB=$DD/scgauss.parm +export PATTERN=$DD/patterns.cart +export CONTFUNC=GB +export SIDEP=$DD/contact.3.parm +export SCRATCHDIR=. +#----------------------------------------------------------------------------- +echo CTEST_FULL_OUTPUT +${mpiexec} ${boot_lam} ${np} $2 $WHAM_BIN +./wham_check.sh $1 +") + +# +# File permissions workaround +# +FILE( COPY ${CMAKE_CURRENT_BINARY_DIR}/scripts/wham_mpi_E0LL2Y.sh + DESTINATION ${CMAKE_CURRENT_BINARY_DIR} + FILE_PERMISSIONS OWNER_READ OWNER_WRITE OWNER_EXECUTE GROUP_READ GROUP_EXECUTE WORLD_READ WORLD_EXECUTE +) + +FILE(COPY ${CMAKE_SOURCE_DIR}/ctest/wham_check.sh + DESTINATION ${CMAKE_CURRENT_BINARY_DIR} + FILE_PERMISSIONS OWNER_READ OWNER_WRITE OWNER_EXECUTE GROUP_READ GROUP_EXECUTE WORLD_READ WORLD_EXECUTE +) + +FILE(COPY ${CMAKE_SOURCE_DIR}/ctest/1L2Y_wham.inp + DESTINATION ${CMAKE_CURRENT_BINARY_DIR} ) + +FILE(COPY ${CMAKE_SOURCE_DIR}/ctest/1L2Y_remd_MD000.cx + DESTINATION ${CMAKE_CURRENT_BINARY_DIR} ) + +FILE(COPY ${CMAKE_SOURCE_DIR}/ctest/1L2Y.pdb + DESTINATION ${CMAKE_CURRENT_BINARY_DIR} ) + + +if(UNRES_MD_FF STREQUAL "E0LL2Y") + add_test(NAME WHAM_remd COMMAND sh ${CMAKE_CURRENT_BINARY_DIR}/wham_mpi_E0LL2Y.sh 1L2Y_wham 2 ) +endif(UNRES_MD_FF STREQUAL "E0LL2Y") diff --git a/source/wham/Makefile b/source/wham/Makefile index a4628bd..b2024c4 100644 --- a/source/wham/Makefile +++ b/source/wham/Makefile @@ -142,8 +142,8 @@ io_base.o: ${UNRES_FILE}/io_base.f90 energy.o: ${UNRES_FILE}/energy.f90 ${FC} ${FFLAGSE} ${CPPFLAGS} ${UNRES_FILE}/energy.f90 -control.o: ${UNRES_FILE}/control.f90 - ${FC} ${FFLAGS} ${CPPFLAGS} ${UNRES_FILE}/control.f90 +control.o: ${UNRES_FILE}/control.F90 + ${FC} ${FFLAGS} ${CPPFLAGS} ${UNRES_FILE}/control.F90 io_config.o: ${UNRES_FILE}/io_config.f90 ${FC} ${FFLAGS2} ${CPPFLAGS} ${UNRES_FILE}/io_config.f90 @@ -151,8 +151,8 @@ io_config.o: ${UNRES_FILE}/io_config.f90 regularize.o: ${UNRES_FILE}/regularize.f90 ${FC} ${FFLAGS} ${CPPFLAGS} ${UNRES_FILE}/regularize.f90 -compare.o: ${UNRES_FILE}/compare.f90 - ${FC} ${FFLAGS} ${CPPFLAGS} ${UNRES_FILE}/compare.f90 +compare.o: ${UNRES_FILE}/compare.F90 + ${FC} ${FFLAGS} ${CPPFLAGS} ${UNRES_FILE}/compare.F90 proc_proc.o: proc_proc.c diff --git a/source/wham/cinfo.f90 b/source/wham/cinfo.f90 index cee591d..c50d882 100644 --- a/source/wham/cinfo.f90 +++ b/source/wham/cinfo.f90 @@ -1,11 +1,11 @@ ! DO NOT EDIT THIS FILE - IT HAS BEEN GENERATED BY COMPINFO.C -! 0 0 1255 +! 0 0 1257 subroutine cinfo ! include 'COMMON.IOUNITS' use IO_UNITS write(iout,*)'++++ Compile info ++++' - write(iout,*)'Version 0.0 build 1255' - write(iout,*)'compiled Wed Feb 15 06:18:23 2017' + write(iout,*)'Version 0.0 build 1257' + write(iout,*)'compiled Wed Feb 15 09:01:33 2017' write(iout,*)'compiled by czarek@piasek4' write(iout,*)'OS name: Linux ' write(iout,*)'OS release: 3.2.0-111-generic ' -- 1.7.9.5